th-desugar 1.13.1 → 1.14

raw patch · 25 files changed

+594/−987 lines, 25 filesdep −faildep −semigroupsdep ~basedep ~template-haskellPVP ok

version bump matches the API change (PVP)

Dependencies removed: fail, semigroups

Dependency ranges changed: base, template-haskell

API changes (from Hackage documentation)

Files

• CHANGES.md +27/−0
• Language/Haskell/TH/Desugar.hs +1/−10
• Language/Haskell/TH/Desugar/AST.hs +25/−51
• Language/Haskell/TH/Desugar/Core.hs +304/−193
• Language/Haskell/TH/Desugar/Expand.hs +1/−49
• Language/Haskell/TH/Desugar/FV.hs +0/−3
• Language/Haskell/TH/Desugar/Lift.hs +1/−5
• Language/Haskell/TH/Desugar/Match.hs +2/−5
• Language/Haskell/TH/Desugar/OMap.hs +18/−27
• Language/Haskell/TH/Desugar/OMap/Strict.hs +16/−15
• Language/Haskell/TH/Desugar/OSet.hs +11/−15
• Language/Haskell/TH/Desugar/Reify.hs +15/−172
• Language/Haskell/TH/Desugar/Subst.hs +0/−4
• Language/Haskell/TH/Desugar/Sweeten.hs +16/−175
• Language/Haskell/TH/Desugar/Util.hs +12/−53
• README.md +4/−0
• Test/Dec.hs +4/−16
• Test/DsDec.hs +4/−17
• Test/ReifyTypeCUSKs.hs +16/−34
• Test/ReifyTypeSigs.hs +0/−3
• Test/Run.hs +28/−53
• Test/Splices.hs +49/−76
• Test/T158Exp.hs +14/−0
• Test/T159Decs.hs +20/−0
• th-desugar.cabal +6/−11

@@ -1,6 +1,33 @@ `th-desugar` release notes ========================== +Version 1.14 [2022.08.23]+-------------------------+* Support GHC 9.4.+* Drop support for GHC 7.8 and 7.10. As a consequence of this, the+  `strictToBang` function was removed as it no longer serves a useful purpose.+* Desugared lambda expressions and guards that bind multiple patterns can now+  have patterns with unlifted types. The desugared code uses `UnboxedTuples` to+  make this possible, so if you load the desugared code into GHCi on prior to+  GHC 9.2, you will need to enable `-fobject-code`.+* `th-desugar` now desugars `PromotedInfixT` and `PromotedUInfixT`, which were+  added in GHC 9.4. Mirroring the existing treatment of other `Promoted*`+  `Type`s, `PromotedInfixT` is desugared to an application of a `DConT` applied+  to two arguments, just like `InfixT` is desugared. Similarly, attempting to+  desugar a `PromotedUInfixT` results in an error, just like attempting to+  desugar a `UInfixT` would be.+* `th-desugar` now supports `DefaultD` (i.e., `default` declarations) and+  `OpaqueP` (i.e., `OPAQUE` pragmas), which were added in GHC 9.4.+* `th-desugar` now desugars `LamCasesE` (i.e., `\cases` expressions), which was+  added in GHC 9.4. A `\cases` expression is desugared to an ordinary lambda+  expression, much like `\case` is currently desugared.+* Fix an inconsistency which caused non-exhaustive `case` expressions to be+  desugared into uses of `EmptyCase`. Non-exhaustive `case` expressions are now+  desugared into code that throws a "`Non-exhaustive patterns in...`" error at+  runtime, just as all other forms of non-exhaustive expressions are desugared.+* Fix a bug in which `expandType` would not expand closed type families when+  applied to arguments containing type variables.+ Version 1.13.1 [2022.05.20] --------------------------- * Allow building with `mtl-2.3.*`.

@@ -51,9 +51,7 @@   DerivingClause, dsDerivClause, dsLetDec,   dsMatches, dsBody, dsGuards, dsDoStmts, dsComp, dsClauses,   dsBangType, dsVarBangType,-#if __GLASGOW_HASKELL__ > 710   dsTypeFamilyHead, dsFamilyResultSig,-#endif #if __GLASGOW_HASKELL__ >= 801   dsPatSynDir, #endif@@ -97,10 +95,7 @@   tupleDegree_maybe, tupleNameDegree_maybe,   unboxedSumDegree_maybe, unboxedSumNameDegree_maybe,   unboxedTupleDegree_maybe, unboxedTupleNameDegree_maybe,-  strictToBang, isTypeKindName, typeKindName,-#if __GLASGOW_HASKELL__ >= 800-  bindIP,-#endif+  isTypeKindName, typeKindName, bindIP,   mkExtraDKindBinders, dTyVarBndrToDType, changeDTVFlags, toposortTyVarsOf,    -- ** 'FunArgs' and 'VisFunArg'@@ -139,10 +134,6 @@ import qualified Data.Map as M import qualified Data.Set as S import Prelude hiding ( exp )--#if __GLASGOW_HASKELL__ < 710-import Control.Applicative-#endif  -- | This class relates a TH type with its th-desugar type and allows -- conversions back and forth. The functional dependency goes only one

@@ -28,7 +28,7 @@           | DLetE [DLetDec] DExp           | DSigE DExp DType           | DStaticE DExp-          deriving (Eq, Show, Typeable, Data, Generic)+          deriving (Eq, Show, Data, Generic)   -- | Corresponds to TH's @Pat@ type.@@ -39,7 +39,7 @@           | DBangP DPat           | DSigP DPat DType           | DWildP-          deriving (Eq, Show, Typeable, Data, Generic)+          deriving (Eq, Show, Data, Generic)  -- | Corresponds to TH's @Type@ type, used to represent -- types and kinds.@@ -53,7 +53,7 @@            | DArrowT            | DLitT TyLit            | DWildCardT-           deriving (Eq, Show, Typeable, Data, Generic)+           deriving (Eq, Show, Data, Generic)  -- | The type variable binders in a @forall@. data DForallTelescope@@ -64,7 +64,7 @@   | DForallInvis [DTyVarBndrSpec]     -- ^ An invisible @forall@ (e.g., @forall a {b} c -> {...}@),     --   where each binder has a 'Specificity'.-  deriving (Eq, Show, Typeable, Data, Generic)+  deriving (Eq, Show, Data, Generic)  -- | Kinds are types. Corresponds to TH's @Kind@ type DKind = DType@@ -79,7 +79,7 @@ data DTyVarBndr flag   = DPlainTV Name flag   | DKindedTV Name flag DKind-  deriving (Eq, Show, Typeable, Data, Generic, Functor)+  deriving (Eq, Show, Data, Generic, Functor)  -- | Corresponds to TH's @TyVarBndrSpec@ type DTyVarBndrSpec = DTyVarBndr Specificity@@ -89,11 +89,11 @@  -- | Corresponds to TH's @Match@ type. data DMatch = DMatch DPat DExp-  deriving (Eq, Show, Typeable, Data, Generic)+  deriving (Eq, Show, Data, Generic)  -- | Corresponds to TH's @Clause@ type. data DClause = DClause [DPat] DExp-  deriving (Eq, Show, Typeable, Data, Generic)+  deriving (Eq, Show, Data, Generic)  -- | Declarations as used in a @let@ statement. data DLetDec = DFunD Name [DClause]@@ -101,12 +101,12 @@              | DSigD Name DType              | DInfixD Fixity Name              | DPragmaD DPragma-             deriving (Eq, Show, Typeable, Data, Generic)+             deriving (Eq, Show, Data, Generic)  -- | Is it a @newtype@ or a @data@ type? data NewOrData = Newtype                | Data-               deriving (Eq, Show, Typeable, Data, Generic)+               deriving (Eq, Show, Data, Generic)  -- | Corresponds to TH's @Dec@ type. data DDec = DLetDec DLetDec@@ -135,18 +135,14 @@           | DKiSigD Name DKind               -- DKiSigD is part of DDec, not DLetDec, because standalone kind               -- signatures can only appear on the top level.-          deriving (Eq, Show, Typeable, Data, Generic)--#if __GLASGOW_HASKELL__ < 711-data Overlap = Overlappable | Overlapping | Overlaps | Incoherent-  deriving (Eq, Ord, Show, Typeable, Data, Generic)-#endif+          | DDefaultD [DType]+          deriving (Eq, Show, Data, Generic)  -- | Corresponds to TH's 'PatSynDir' type data DPatSynDir = DUnidir              -- ^ @pattern P x {<-} p@                 | DImplBidir           -- ^ @pattern P x {=} p@                 | DExplBidir [DClause] -- ^ @pattern P x {<-} p where P x = e@-                deriving (Eq, Show, Typeable, Data, Generic)+                deriving (Eq, Show, Data, Generic)  -- | Corresponds to TH's 'PatSynType' type type DPatSynType = DType@@ -157,24 +153,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 (Eq, Show, Typeable, Data, Generic)+  deriving (Eq, Show, Data, Generic) #endif  -- | Corresponds to TH's 'TypeFamilyHead' type data DTypeFamilyHead = DTypeFamilyHead Name [DTyVarBndrUnit] DFamilyResultSig                                        (Maybe InjectivityAnn)-                     deriving (Eq, Show, Typeable, Data, Generic)+                     deriving (Eq, Show, Data, Generic)  -- | Corresponds to TH's 'FamilyResultSig' type data DFamilyResultSig = DNoSig                       | DKindSig DKind                       | DTyVarSig DTyVarBndrUnit-                      deriving (Eq, Show, Typeable, Data, Generic)--#if __GLASGOW_HASKELL__ <= 710-data InjectivityAnn = InjectivityAnn Name [Name]-  deriving (Eq, Ord, Show, Typeable, Data, Generic)-#endif+                      deriving (Eq, Show, Data, Generic)  -- | Corresponds to TH's 'Con' type. Unlike 'Con', all 'DCon's reflect GADT -- syntax. This is beneficial for @th-desugar@'s since it means@@ -193,13 +184,13 @@ -- * A 'DCon' always has an explicit return type. data DCon = DCon [DTyVarBndrSpec] DCxt Name DConFields                  DType  -- ^ The GADT result type-          deriving (Eq, Show, Typeable, Data, Generic)+          deriving (Eq, Show, 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 (Eq, Show, Typeable, Data, Generic)+                deriving (Eq, Show, 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@@ -251,28 +242,10 @@ -- | Corresponds to TH's @VarBangType@ type. type DVarBangType = (Name, Bang, DType) -#if __GLASGOW_HASKELL__ <= 710--- | Corresponds to TH's definition-data SourceUnpackedness = NoSourceUnpackedness-                        | SourceNoUnpack-                        | SourceUnpack-  deriving (Eq, Ord, Show, Typeable, Data, Generic)---- | Corresponds to TH's definition-data SourceStrictness = NoSourceStrictness-                      | SourceLazy-                      | SourceStrict-  deriving (Eq, Ord, Show, Typeable, Data, Generic)---- | Corresponds to TH's definition-data Bang = Bang SourceUnpackedness SourceStrictness-  deriving (Eq, Ord, Show, Typeable, Data, Generic)-#endif- -- | Corresponds to TH's @Foreign@ type. data DForeign = DImportF Callconv Safety String Name DType               | DExportF Callconv String Name DType-              deriving (Eq, Show, Typeable, Data, Generic)+              deriving (Eq, Show, Data, Generic)  -- | Corresponds to TH's @Pragma@ type. data DPragma = DInlineP Name Inline RuleMatch Phases@@ -282,16 +255,17 @@              | DAnnP AnnTarget DExp              | DLineP Int String              | DCompleteP [Name] (Maybe Name)-             deriving (Eq, Show, Typeable, Data, Generic)+             | DOpaqueP Name+             deriving (Eq, Show, Data, Generic)  -- | Corresponds to TH's @RuleBndr@ type. data DRuleBndr = DRuleVar Name                | DTypedRuleVar Name DType-               deriving (Eq, Show, Typeable, Data, Generic)+               deriving (Eq, Show, Data, Generic)  -- | Corresponds to TH's @TySynEqn@ type (to store type family equations). data DTySynEqn = DTySynEqn (Maybe [DTyVarBndrUnit]) DType DType-               deriving (Eq, Show, Typeable, Data, Generic)+               deriving (Eq, Show, Data, Generic)  -- | Corresponds to TH's @Info@ type. data DInfo = DTyConI DDec (Maybe [DInstanceDec])@@ -304,17 +278,17 @@                -- ^ The @Int@ is the arity; the @Bool@ is whether this tycon                -- is unlifted.            | DPatSynI Name DPatSynType-           deriving (Eq, Show, Typeable, Data, Generic)+           deriving (Eq, Show, Data, Generic)  type DInstanceDec = DDec -- ^ Guaranteed to be an instance declaration  -- | Corresponds to TH's @DerivClause@ type. data DDerivClause = DDerivClause (Maybe DDerivStrategy) DCxt-                  deriving (Eq, Show, Typeable, Data, Generic)+                  deriving (Eq, Show, Data, Generic)  -- | Corresponds to TH's @DerivStrategy@ type. data DDerivStrategy = DStockStrategy     -- ^ A \"standard\" derived instance                     | DAnyclassStrategy  -- ^ @-XDeriveAnyClass@                     | DNewtypeStrategy   -- ^ @-XGeneralizedNewtypeDeriving@                     | DViaStrategy DType -- ^ @-XDerivingVia@-                    deriving (Eq, Show, Typeable, Data, Generic)+                    deriving (Eq, Show, Data, Generic)

@@ -7,7 +7,7 @@ processing. The desugared types and constructors are prefixed with a D. -} -{-# LANGUAGE TemplateHaskell, LambdaCase, CPP, ScopedTypeVariables,+{-# LANGUAGE TemplateHaskellQuotes, LambdaCase, CPP, ScopedTypeVariables,              TupleSections, DeriveDataTypeable, DeriveGeneric #-}  module Language.Haskell.TH.Desugar.Core where@@ -23,30 +23,17 @@ import Control.Monad.Trans (MonadTrans(..)) import Control.Monad.Writer (MonadWriter(..), WriterT(..)) import Control.Monad.Zip-import Data.Data (Data, Typeable)+import Data.Data (Data) import Data.Either (lefts) import Data.Foldable as F hiding (concat, notElem) import qualified Data.Map as M import Data.Map (Map)-import Data.Maybe (mapMaybe)+import Data.Maybe (isJust, mapMaybe) import Data.Monoid (All(..)) import qualified Data.Set as S import Data.Set (Set) import Data.Traversable -#if __GLASGOW_HASKELL__ < 709-import Control.Applicative-import Data.Monoid (Monoid(..))-#endif--#if __GLASGOW_HASKELL__ > 710-import Data.Maybe (isJust)-#endif--#if __GLASGOW_HASKELL__ >= 800-import qualified Control.Monad.Fail as MonadFail-#endif- #if __GLASGOW_HASKELL__ >= 803 import GHC.OverloadedLabels ( fromLabel ) #endif@@ -109,7 +96,7 @@ #endif                   []) (NormalB rhs) [] dsExp (MultiIfE guarded_exps) =-  let failure = DAppE (DVarE 'error) (DLitE (StringL "Non-exhaustive guards in multi-way if")) in+  let failure = mkErrorMatchExpr MultiWayIfAlt in   dsGuards guarded_exps failure dsExp (LetE decs exp) = do   (decs', ip_binder) <- dsLetDecs decs@@ -155,10 +142,8 @@                     InfixC field1 _name field2 -> non_record [field1, field2]                     RecC _name fields -> reorder_fields fields                     ForallC _ _ c -> reorder c-#if __GLASGOW_HASKELL__ >= 800                     GadtC _names fields _ret_ty -> non_record fields                     RecGadtC _names fields _ret_ty -> reorder_fields fields-#endif      reorder_fields fields = reorderFields con_name fields field_exps                                           (repeat $ DVarE 'undefined)@@ -183,11 +168,7 @@                   _ -> impossible "Record update with no fields listed."   info <- reifyWithLocals first_name   applied_type <- case info of-#if __GLASGOW_HASKELL__ > 710                     VarI _name ty _m_dec -> extract_first_arg ty-#else-                    VarI _name ty _m_dec _fixity -> extract_first_arg ty-#endif                     _ -> impossible "Record update with an invalid field name."   type_name <- extract_type_name applied_type   (_, cons) <- getDataD "This seems to be an error in GHC." type_name@@ -220,10 +201,8 @@          has_names (RecC _con_name args) =           args_contain_names args-#if __GLASGOW_HASKELL__ >= 800         has_names (RecGadtC _con_name args _ret_ty) =           args_contain_names args-#endif         has_names (ForallC _ _ c) = has_names c         has_names _               = False @@ -236,24 +215,17 @@      con_to_dmatch :: DsMonad q => Con -> q DMatch     con_to_dmatch (RecC con_name args) = rec_con_to_dmatch con_name args-#if __GLASGOW_HASKELL__ >= 800     -- We're assuming the GADT constructor has only one Name here, but since     -- this constructor was reified, this assumption should always hold true.     con_to_dmatch (RecGadtC [con_name] args _ret_ty) = rec_con_to_dmatch con_name args-#endif     con_to_dmatch (ForallC _ _ c) = con_to_dmatch c     con_to_dmatch _ = impossible "Internal error within th-desugar." -    error_match = DMatch DWildP (DAppE (DVarE 'error)-                   (DLitE (StringL "Non-exhaustive patterns in record update")))+    error_match = DMatch DWildP (mkErrorMatchExpr RecUpd)      fst_of_3 (x, _, _) = x-#if __GLASGOW_HASKELL__ >= 709 dsExp (StaticE exp) = DStaticE <$> dsExp exp-#endif-#if __GLASGOW_HASKELL__ > 710 dsExp (UnboundVarE n) = return (DVarE n)-#endif #if __GLASGOW_HASKELL__ >= 801 dsExp (AppTypeE exp ty) = DAppTypeE <$> dsExp exp <*> dsType ty dsExp (UnboxedSumE exp alt arity) =@@ -275,7 +247,36 @@     comp :: DExp -> String -> DExp     comp acc f = DVarE '(.) `DAppE` mkGetFieldProj f `DAppE` acc #endif+#if __GLASGOW_HASKELL__ >= 903+dsExp (LamCasesE clauses) = do+  clauses' <- dsClauses CaseAlt clauses+  numArgs <-+    case clauses' of+      (DClause pats _:_) -> return $ length pats+      [] -> fail "\\cases expression must have at least one alternative"+  args <- replicateM numArgs (newUniqueName "x")+  return $ DLamE args $ DCaseE (mkUnboxedTupleDExp (map DVarE args))+                               (map dClauseToUnboxedTupleMatch clauses')+#endif +-- | Convert a 'DClause' to a 'DMatch' by bundling all of the clause's patterns+-- into a match on a single unboxed tuple pattern. That is, convert this:+--+-- @+-- f x y z = rhs+-- @+--+-- To this:+--+-- @+-- f (# x, y, z #) = rhs+-- @+--+-- This is used to desugar @\\cases@ expressions into lambda expressions.+dClauseToUnboxedTupleMatch :: DClause -> DMatch+dClauseToUnboxedTupleMatch (DClause pats rhs) =+  DMatch (mkUnboxedTupleDPat pats) rhs+ #if __GLASGOW_HASKELL__ >= 809 dsTup :: DsMonad q => (Int -> Name) -> [Maybe Exp] -> q DExp dsTup = ds_tup@@ -328,8 +329,8 @@   = return $ DLamE names exp   | otherwise   = do arg_names <- replicateM (length pats) (newUniqueName "arg")-       let scrutinee = mkTupleDExp (map DVarE arg_names)-           match     = DMatch (mkTupleDPat pats) exp+       let scrutinee = mkUnboxedTupleDExp (map DVarE arg_names)+           match     = DMatch (mkUnboxedTupleDPat pats) exp        return $ DLamE arg_names (DCaseE scrutinee [match])   where     stripDVarP_maybe :: DPat -> Maybe Name@@ -352,7 +353,7 @@     go [] = return []     go (Match pat body where_decs : rest) = do       rest' <- go rest-      let failure = DCaseE (DVarE scr) rest'  -- this might be an empty case.+      let failure = maybeDCaseE CaseAlt (DVarE scr) rest'       exp' <- dsBody body where_decs failure       (pat', exp'') <- dsPatOverExp pat exp'       uni_pattern <- isUniversalPattern pat' -- incomplete attempt at #6@@ -381,9 +382,9 @@ maybeDLetE decs exp = DLetE decs exp  -- | If matches is non-empty, make a case statement; otherwise make an error statement-maybeDCaseE :: String -> DExp -> [DMatch] -> DExp-maybeDCaseE err _     []      = DAppE (DVarE 'error) (DLitE (StringL err))-maybeDCaseE _   scrut matches = DCaseE scrut matches+maybeDCaseE :: MatchContext -> DExp -> [DMatch] -> DExp+maybeDCaseE mc _     []      = mkErrorMatchExpr mc+maybeDCaseE _  scrut matches = DCaseE scrut matches  -- | Desugar guarded expressions dsGuards :: DsMonad q@@ -515,17 +516,13 @@     -- enabled by default, so simply use MonadFail.fail. (That happens to     -- be the same as Prelude.fail in 8.8+.)     mk_fail_name = return fail_MonadFail_name-#elif __GLASGOW_HASKELL__ >= 800+#else     mk_fail_name = do       mfd <- qIsExtEnabled MonadFailDesugaring       return $ if mfd then fail_MonadFail_name else fail_Prelude_name-#else-    mk_fail_name = return fail_Prelude_name #endif -#if __GLASGOW_HASKELL__ >= 800-    fail_MonadFail_name = mk_qual_do_name mb_mod 'MonadFail.fail-#endif+    fail_MonadFail_name = mk_qual_do_name mb_mod 'Fail.fail  #if __GLASGOW_HASKELL__ < 807     fail_Prelude_name = mk_qual_do_name mb_mod 'Prelude.fail@@ -616,10 +613,8 @@                      InfixC field1 _name field2 -> non_record [field1, field2]                      RecC _name fields -> reorder_fields_pat fields                      ForallC _ _ c -> reorder c-#if __GLASGOW_HASKELL__ >= 800                      GadtC _names fields _ret_ty -> non_record fields                      RecGadtC _names fields _ret_ty -> reorder_fields_pat fields-#endif      reorder_fields_pat fields = reorderFieldsPat con_name fields field_pats @@ -676,11 +671,7 @@   [ddec]     <- dsDec dec   dinstances <- dsDecs instances   return $ DTyConI ddec (Just dinstances)-#if __GLASGOW_HASKELL__ > 710 dsInfo (ClassOpI name ty parent) =-#else-dsInfo (ClassOpI name ty parent _fixity) =-#endif   DVarI name <$> dsType ty <*> pure (Just parent) dsInfo (TyConI dec) = do   [ddec] <- dsDec dec@@ -691,21 +682,12 @@   return $ DTyConI ddec (Just dinstances) dsInfo (PrimTyConI name arity unlifted) =   return $ DPrimTyConI name arity unlifted-#if __GLASGOW_HASKELL__ > 710 dsInfo (DataConI name ty parent) =   DVarI name <$> dsType ty <*> pure (Just parent) dsInfo (VarI name ty Nothing) =   DVarI name <$> dsType ty <*> pure Nothing dsInfo (VarI name _ (Just _)) =   impossible $ "Declaration supplied with variable: " ++ show name-#else-dsInfo (DataConI name ty parent _fixity) =-  DVarI name <$> dsType ty <*> pure (Just parent)-dsInfo (VarI name ty Nothing _fixity) =-  DVarI name <$> dsType ty <*> pure Nothing-dsInfo (VarI name _ (Just _) _) =-  impossible $ "Declaration supplied with variable: " ++ show name-#endif dsInfo (TyVarI name ty) = DTyVarI name <$> dsType ty #if __GLASGOW_HASKELL__ >= 801 dsInfo (PatSynI name ty) = DPatSynI name <$> dsType ty@@ -719,44 +701,25 @@ dsDec :: DsMonad q => Dec -> q [DDec] dsDec d@(FunD {}) = dsTopLevelLetDec d dsDec d@(ValD {}) = dsTopLevelLetDec d-#if __GLASGOW_HASKELL__ > 710 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) =-  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 dsTvbUnit tvbs <*> dsType ty) dsDec (ClassD cxt n tvbs fds decs) =   (:[]) <$> (DClassD <$> dsCxt cxt <*> pure n <*> mapM dsTvbUnit tvbs                      <*> pure fds <*> dsDecs decs)-#if __GLASGOW_HASKELL__ >= 711 dsDec (InstanceD over cxt ty decs) =   (:[]) <$> (DInstanceD over Nothing <$> dsCxt cxt <*> dsType ty <*> dsDecs decs)-#else-dsDec (InstanceD cxt ty decs) =-  (:[]) <$> (DInstanceD Nothing Nothing <$> dsCxt cxt <*> dsType ty <*> dsDecs decs)-#endif dsDec d@(SigD {}) = dsTopLevelLetDec d dsDec (ForeignD f) = (:[]) <$> (DForeignD <$> dsForeign f) dsDec d@(InfixD {}) = dsTopLevelLetDec d dsDec d@(PragmaD {}) = dsTopLevelLetDec d-#if __GLASGOW_HASKELL__ > 710 dsDec (OpenTypeFamilyD tfHead) =   (:[]) <$> (DOpenTypeFamilyD <$> dsTypeFamilyHead tfHead) dsDec (DataFamilyD n tvbs m_k) =   (:[]) <$> (DDataFamilyD n <$> mapM dsTvbUnit tvbs <*> mapM dsType m_k)-#else-dsDec (FamilyD TypeFam n tvbs m_k) = do-  (:[]) <$> (DOpenTypeFamilyD <$> dsTypeFamilyHead n tvbs m_k)-dsDec (FamilyD DataFam n tvbs m_k) =-  (:[]) <$> (DDataFamilyD n <$> mapM dsTvbUnit tvbs <*> mapM dsType m_k)-#endif #if __GLASGOW_HASKELL__ >= 807 dsDec (DataInstD cxt mtvbs lhs mk cons derivings) =   case unfoldType lhs of@@ -766,33 +729,21 @@   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+#else 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) =-  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__ >= 807 dsDec (TySynInstD eqn) = (:[]) <$> (DTySynInstD <$> dsTySynEqn unusedArgument eqn) #else dsDec (TySynInstD n eqn) = (:[]) <$> (DTySynInstD <$> dsTySynEqn n eqn) #endif-#if __GLASGOW_HASKELL__ > 710 dsDec (ClosedTypeFamilyD tfHead eqns) =   (:[]) <$> (DClosedTypeFamilyD <$> dsTypeFamilyHead tfHead                                 <*> mapM (dsTySynEqn (typeFamilyHeadName tfHead)) eqns)-#else-dsDec (ClosedTypeFamilyD n tvbs m_k eqns) = do-  (:[]) <$> (DClosedTypeFamilyD <$> dsTypeFamilyHead n tvbs m_k-                                <*> mapM (dsTySynEqn n) eqns)-#endif dsDec (RoleAnnotD n roles) = return [DRoleAnnotD n roles]-#if __GLASGOW_HASKELL__ >= 709 #if __GLASGOW_HASKELL__ >= 801 dsDec (PatSynD n args dir pat) = do   dir' <- dsPatSynDir n dir@@ -809,13 +760,15 @@   (:[]) <$> (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 #if __GLASGOW_HASKELL__ >= 809 dsDec (KiSigD n ki) = (:[]) <$> (DKiSigD n <$> dsType ki) #endif+#if __GLASGOW_HASKELL__ >= 903+dsDec (DefaultD tys) = (:[]) <$> (DDefaultD <$> mapM dsType tys)+#endif  -- | Desugar a 'DataD' or 'NewtypeD'. dsDataDec :: DsMonad q@@ -859,7 +812,6 @@                            <*> concatMapM (dsCon h98_tvbs h98_fam_inst_type) cons                            <*> mapM dsDerivClause derivings) -#if __GLASGOW_HASKELL__ > 710 -- | Desugar a @FamilyResultSig@ dsFamilyResultSig :: DsMonad q => FamilyResultSig -> q DFamilyResultSig dsFamilyResultSig NoSig          = return DNoSig@@ -875,18 +827,6 @@  typeFamilyHeadName :: TypeFamilyHead -> Name typeFamilyHeadName (TypeFamilyHead n _ _ _) = n-#else--- | Desugar bits and pieces into a 'DTypeFamilyHead'-dsTypeFamilyHead :: DsMonad q-                 => Name -> [TyVarBndrUnit] -> Maybe Kind -> q DTypeFamilyHead-dsTypeFamilyHead n tvbs m_kind = do-  result_sig <- case m_kind of-    Nothing -> return DNoSig-    Just k  -> DKindSig <$> dsType k-  DTypeFamilyHead n <$> mapM dsTvbUnit tvbs-                    <*> pure result_sig-                    <*> pure Nothing-#endif  -- | Desugar @Dec@s that can appear in a @let@ expression. See the -- documentation for 'dsLetDec' for an explanation of what the return type@@ -933,7 +873,7 @@ -- '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+  clauses' <- dsClauses (FunRhs name) clauses   return ([DFunD name clauses'], id) dsLetDec (ValD pat body where_decs) = do   (pat', vars) <- dsPatX pat@@ -941,8 +881,7 @@   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))+    error_exp = mkErrorMatchExpr (LetDecRhs pat) dsLetDec (SigD name ty) = do   ty' <- dsType ty   return ([DSigD name ty'], id)@@ -1046,7 +985,6 @@   dcons' <- dsCon' con   return $ flip map dcons' $ \(n, dtvbs', dcxt', fields, m_gadt_type) ->     (n, dtvbs ++ dtvbs', dcxt ++ dcxt', fields, m_gadt_type)-#if __GLASGOW_HASKELL__ > 710 dsCon' (GadtC nms btys rty) = do   dbtys <- mapM dsBangType btys   drty  <- dsType rty@@ -1065,26 +1003,15 @@   drty   <- dsType rty   return $ flip map nms $ \nm ->     (nm, [], [], DRecC dvbtys, Just drty)-#endif -#if __GLASGOW_HASKELL__ > 710--- | Desugar a @BangType@ (or a @StrictType@, if you're old-fashioned)+-- | Desugar a @BangType@. dsBangType :: DsMonad q => BangType -> q DBangType dsBangType (b, ty) = (b, ) <$> dsType ty --- | Desugar a @VarBangType@ (or a @VarStrictType@, if you're old-fashioned)+-- | Desugar a @VarBangType@. dsVarBangType :: DsMonad q => VarBangType -> q DVarBangType dsVarBangType (n, b, ty) = (n, b, ) <$> dsType ty-#else--- | Desugar a @BangType@ (or a @StrictType@, if you're old-fashioned)-dsBangType :: DsMonad q => StrictType -> q DBangType-dsBangType (b, ty) = (strictToBang b, ) <$> dsType ty --- | Desugar a @VarBangType@ (or a @VarStrictType@, if you're old-fashioned)-dsVarBangType :: DsMonad q => VarStrictType -> q DVarBangType-dsVarBangType (n, b, ty) = (n, strictToBang b, ) <$> dsType ty-#endif- -- | Desugar a @Foreign@. dsForeign :: DsMonad q => Foreign -> q DForeign dsForeign (ImportF cc safety str n ty) = DImportF cc safety str n <$> dsType ty@@ -1112,12 +1039,13 @@                                                       <*> pure phases #endif dsPragma (AnnP target exp)               = DAnnP target <$> dsExp exp-#if __GLASGOW_HASKELL__ >= 709 dsPragma (LineP n str)                   = return $ DLineP n str-#endif #if __GLASGOW_HASKELL__ >= 801 dsPragma (CompleteP cls mty)             = return $ DCompleteP cls mty #endif+#if __GLASGOW_HASKELL__ >= 903+dsPragma (OpaqueP n)                     = return $ DOpaqueP n+#endif  -- | Desugar a @RuleBndr@. dsRuleBndr :: DsMonad q => RuleBndr -> q DRuleBndr@@ -1143,37 +1071,67 @@  -- | Desugar clauses to a function definition dsClauses :: DsMonad q-          => Name         -- ^ Name of the function+          => MatchContext -- ^ The context in which the clauses arise           -> [Clause]     -- ^ Clauses to desugar           -> q [DClause] dsClauses _ [] = return []-dsClauses n (Clause pats (NormalB exp) where_decs : rest) = do+dsClauses mc (Clause pats (NormalB exp) where_decs : rest) = do   -- this case is necessary to maintain the roundtrip property.-  rest' <- dsClauses n rest+  rest' <- dsClauses mc rest   exp' <- dsExp 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+dsClauses mc clauses@(Clause outer_pats _ _ : _) = do   arg_names <- replicateM (length outer_pats) (newUniqueName "arg")-  let scrutinee = mkTupleDExp (map DVarE arg_names)+  let scrutinee = mkUnboxedTupleDExp (map DVarE arg_names)   clause <- DClause (map DVarP arg_names) <$>               (DCaseE scrutinee <$> foldrM (clause_to_dmatch scrutinee) [] clauses)   return [clause]   where     clause_to_dmatch :: DsMonad q => DExp -> Clause -> [DMatch] -> q [DMatch]     clause_to_dmatch scrutinee (Clause pats body where_decs) failure_matches = do-      let failure_exp = maybeDCaseE ("Non-exhaustive patterns in " ++ (show n))-                                    scrutinee failure_matches+      let failure_exp = maybeDCaseE mc scrutinee failure_matches       exp <- dsBody body where_decs failure_exp       (pats', exp') <- dsPatsOverExp pats exp       uni_pats <- fmap getAll $ concatMapM (fmap All . isUniversalPattern) pats'-      let match = DMatch (mkTupleDPat pats') exp'+      let match = DMatch (mkUnboxedTupleDPat pats') exp'       if uni_pats       then return [match]       else return (match : failure_matches) +-- | The context of a pattern match. This is used to produce+-- @Non-exhaustive patterns in...@ messages that are tailored to specific+-- situations. Compare this to GHC's @HsMatchContext@ data type+-- (https://gitlab.haskell.org/ghc/ghc/-/blob/81cf52bb301592ff3d043d03eb9a0d547891a3e1/compiler/Language/Haskell/Syntax/Expr.hs#L1662-1695),+-- from which the @MatchContext@ data type takes inspiration.+data MatchContext+  = FunRhs Name+    -- ^ A pattern matching on an argument of a function binding+  | LetDecRhs Pat+    -- ^ A pattern in a @let@ declaration+  | RecUpd+    -- ^ A record update+  | MultiWayIfAlt+    -- ^ Guards in a multi-way if alternative+  | CaseAlt+    -- ^ Patterns and guards in a case alternative++-- | Construct an expression that throws an error when encountering a pattern+-- at runtime that is not covered by pattern matching.+mkErrorMatchExpr :: MatchContext -> DExp+mkErrorMatchExpr mc =+  DAppE (DVarE 'error) (DLitE (StringL ("Non-exhaustive patterns in " ++ pp_context)))+  where+    pp_context =+      case mc of+        FunRhs n      -> show n+        LetDecRhs pat -> pprint pat+        RecUpd        -> "record update"+        MultiWayIfAlt -> "multi-way if"+        CaseAlt       -> "case"+ -- | Desugar a type dsType :: DsMonad q => Type -> q DType #if __GLASGOW_HASKELL__ >= 900@@ -1188,10 +1146,8 @@ dsType (SigT ty ki) = DSigT <$> dsType ty <*> dsType ki dsType (VarT name) = return $ DVarT name dsType (ConT name) = return $ DConT name-  -- the only difference between ConT and PromotedT is the name lookup. Here, we assume-  -- that the TH quote mechanism figured out the right name. Note that lookupDataName name-  -- does not necessarily work, because `name` has its original module attached, which-  -- may not be in scope.+-- The PromotedT case is identical to the ConT case above.+-- See Note [Desugaring promoted types]. dsType (PromotedT name) = return $ DConT name dsType (TupleT n) = return $ DConT (tupleTypeName n) dsType (UnboxedTupleT n) = return $ DConT (unboxedTupleTypeName n)@@ -1203,15 +1159,11 @@ dsType StarT = return $ DConT typeKindName dsType ConstraintT = return $ DConT ''Constraint dsType (LitT lit) = return $ DLitT lit-#if __GLASGOW_HASKELL__ >= 709 dsType EqualityT = return $ DConT ''(~)-#endif-#if __GLASGOW_HASKELL__ > 710-dsType (InfixT t1 n t2) = DAppT <$> (DAppT (DConT n) <$> dsType t1) <*> dsType t2-dsType (UInfixT _ _ _) = fail "Cannot desugar unresolved infix operators."+dsType (InfixT t1 n t2) = dsInfixT t1 n t2+dsType (UInfixT{}) = dsUInfixT dsType (ParensT t) = dsType t dsType WildCardT = return DWildCardT-#endif #if __GLASGOW_HASKELL__ >= 801 dsType (UnboxedSumT arity) = return $ DConT (unboxedSumTypeName arity) #endif@@ -1225,6 +1177,12 @@ dsType (ForallVisT tvbs ty) =   DForallT <$> (DForallVis <$> mapM dsTvbUnit tvbs) <*> dsType ty #endif+#if __GLASGOW_HASKELL__ >= 903+-- The PromotedInfixT case is identical to the InfixT case above.+-- See Note [Desugaring promoted types].+dsType (PromotedInfixT t1 n t2) = dsInfixT t1 n t2+dsType PromotedUInfixT{} = dsUInfixT+#endif  #if __GLASGOW_HASKELL__ >= 900 -- | Desugar a 'TyVarBndr'.@@ -1270,8 +1228,45 @@ types of data constructors: since th-desugar doesn't currently support linear types, we pretend as if MulArrowT does not exist. As a result, the type of `Just` would be locally reified as `a -> Maybe a`, not `a #-> Maybe a`.++Note [Desugaring promoted types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+ConT and PromotedT both contain Names as a payload, the only difference being+that PromotedT is intended to refer exclusively to promoted data constructor+Names, while ConT can refer to both type and data constructor Names alike.++When desugaring a PromotedT, we make the assumption that the TH quoting+mechanism produced the correct Name and wrap the name in a DConT. In other+words, we desugar ConT and PromotedT identically. This assumption about+PromotedT may not always be correct, however. Consider this example:++  data a :+: b = Inl a | Inr b+  data Exp a = ... | Exp :+: Exp++How should `PromotedT (mkName ":+:")` be desugared? Morally, it ought to be+desugared to a DConT that contains (:+:) the data constructor, not (:+:) the+type constructor. Deciding between the two is not always straightforward,+however. We could use the `lookupDataName` function to try and distinguish+between the two Names, but this may not necessarily work. This is because the+Name passed to `lookupDataName` could have its original module attached, which+may not be in scope.++Long story short: we make things simple (albeit slightly wrong) by desugaring+ConT and PromotedT identically. We'll wait for someone to complain about the+wrongness of this approach before researching a more accurate solution.++Note that the same considerations also apply to InfixT and PromotedInfixT,+which are also desugared identically. -} +-- | Desugar an infix 'Type'.+dsInfixT :: DsMonad q => Type -> Name -> Type -> q DType+dsInfixT t1 n t2 = DAppT <$> (DAppT (DConT n) <$> dsType t1) <*> dsType t2++-- | We cannot desugar unresolved infix operators, so fail if we encounter one.+dsUInfixT :: Fail.MonadFail m => m a+dsUInfixT = fail "Cannot desugar unresolved infix operators."+ -- | Desugar a 'TyVarBndrSpec'. dsTvbSpec :: DsMonad q => TyVarBndrSpec -> q DTyVarBndrSpec #if __GLASGOW_HASKELL__ >= 900@@ -1302,16 +1297,11 @@ dsDerivClause :: DsMonad q => DerivingClause -> q DDerivClause dsDerivClause (DerivClause mds cxt) =   DDerivClause <$> mapM dsDerivStrategy mds <*> dsCxt cxt-#elif __GLASGOW_HASKELL__ >= 711+#else type DerivingClause = Pred  dsDerivClause :: DsMonad q => DerivingClause -> q DDerivClause dsDerivClause p = DDerivClause Nothing <$> dsPred p-#else-type DerivingClause = Name--dsDerivClause :: DsMonad q => DerivingClause -> q DDerivClause-dsDerivClause n = pure $ DDerivClause Nothing [DConT n] #endif  #if __GLASGOW_HASKELL__ >= 801@@ -1330,19 +1320,11 @@ dsPatSynDir :: DsMonad q => Name -> PatSynDir -> q DPatSynDir dsPatSynDir _ Unidir              = pure DUnidir dsPatSynDir _ ImplBidir           = pure DImplBidir-dsPatSynDir n (ExplBidir clauses) = DExplBidir <$> dsClauses n clauses+dsPatSynDir n (ExplBidir clauses) = DExplBidir <$> dsClauses (FunRhs n) clauses #endif  -- | Desugar a @Pred@, flattening any internal tuples dsPred :: DsMonad q => Pred -> q DCxt-#if __GLASGOW_HASKELL__ < 709-dsPred (ClassP n tys) = do-  ts' <- mapM dsType tys-  return [foldl DAppT (DConT n) ts']-dsPred (EqualP t1 t2) = do-  ts' <- mapM dsType [t1, t2]-  return [foldl DAppT (DConT ''(~)) ts']-#else dsPred t   | Just ts <- splitTuple_maybe t   = concatMapM dsPred ts@@ -1376,12 +1358,10 @@ dsPred t@(LitT _) =   impossible $ "Type literal seen as head of constraint: " ++ show t dsPred EqualityT = return [DConT ''(~)]-#if __GLASGOW_HASKELL__ > 710-dsPred (InfixT t1 n t2) = (:[]) <$> (DAppT <$> (DAppT (DConT n) <$> dsType t1) <*> dsType t2)-dsPred (UInfixT _ _ _) = fail "Cannot desugar unresolved infix operators."+dsPred (InfixT t1 n t2) = (:[]) <$> dsInfixT t1 n t2+dsPred (UInfixT{}) = dsUInfixT dsPred (ParensT t) = dsPred t dsPred WildCardT = return [DWildCardT]-#endif #if __GLASGOW_HASKELL__ >= 801 dsPred t@(UnboxedSumT {}) =   impossible $ "Unboxed sum seen as head of constraint: " ++ show t@@ -1401,6 +1381,11 @@ #if __GLASGOW_HASKELL__ >= 900 dsPred MulArrowT = impossible "Linear arrow seen as head of constraint." #endif+#if __GLASGOW_HASKELL__ >= 903+dsPred t@PromotedInfixT{} =+  impossible $ "Promoted infix type seen as head of constraint: " ++ show t+dsPred PromotedUInfixT{} = dsUInfixT+#endif  -- | Desugar a quantified constraint. dsForallPred :: DsMonad q => [TyVarBndrSpec] -> Cxt -> Pred -> q DCxt@@ -1411,7 +1396,6 @@                          (DForallInvis <$> mapM dsTvbSpec tvbs) <*> dsCxt cxt <*> pure p')     _    -> fail "Cannot desugar constraint tuples in the body of a quantified constraint"               -- See GHC #15334.-#endif  -- | Like 'reify', but safer and desugared. Uses local declarations where -- available.@@ -1466,21 +1450,41 @@         Nothing -> return $ deflt : rest'     reorder (_ : _) [] = error "Internal error in th-desugar." +-- mkTupleDExp, mkUnboxedTupleDExp, and friends construct tuples, avoiding the+-- use of 1-tuples. These are used to create auxiliary tuple values when+-- desugaring pattern-matching constructs to simpler forms.+-- See Note [Auxiliary tuples in pattern matching].+ -- | Make a tuple 'DExp' from a list of 'DExp's. Avoids using a 1-tuple. mkTupleDExp :: [DExp] -> DExp mkTupleDExp [exp] = exp mkTupleDExp exps = foldl DAppE (DConE $ tupleDataName (length exps)) exps +-- | Make an unboxed tuple 'DExp' from a list of 'DExp's. Avoids using a 1-tuple.+mkUnboxedTupleDExp :: [DExp] -> DExp+mkUnboxedTupleDExp [exp] = exp+mkUnboxedTupleDExp exps = foldl DAppE (DConE $ unboxedTupleDataName (length exps)) exps+ -- | Make a tuple 'Exp' from a list of 'Exp's. Avoids using a 1-tuple. mkTupleExp :: [Exp] -> Exp mkTupleExp [exp] = exp mkTupleExp exps = foldl AppE (ConE $ tupleDataName (length exps)) exps +-- | Make an unboxed tuple 'Exp' from a list of 'Exp's. Avoids using a 1-tuple.+mkUnboxedTupleExp :: [Exp] -> Exp+mkUnboxedTupleExp [exp] = exp+mkUnboxedTupleExp exps = foldl AppE (ConE $ unboxedTupleDataName (length exps)) exps+ -- | Make a tuple 'DPat' from a list of 'DPat's. Avoids using a 1-tuple. mkTupleDPat :: [DPat] -> DPat mkTupleDPat [pat] = pat mkTupleDPat pats = DConP (tupleDataName (length pats)) [] pats +-- | Make an unboxed tuple 'DPat' from a list of 'DPat's. Avoids using a 1-tuple.+mkUnboxedTupleDPat :: [DPat] -> DPat+mkUnboxedTupleDPat [pat] = pat+mkUnboxedTupleDPat pats = DConP (unboxedTupleDataName (length pats)) [] pats+ -- | Is this pattern guaranteed to match? isUniversalPattern :: DsMonad q => DPat -> q Bool isUniversalPattern (DLitP {}) = return False@@ -1516,7 +1520,7 @@ data DTypeArg   = DTANormal DType   | DTyArg DKind-  deriving (Eq, Show, Typeable, Data, Generic)+  deriving (Eq, Show, Data, Generic)  -- | Desugar a 'TypeArg'. dsTypeArg :: DsMonad q => TypeArg -> q DTypeArg@@ -1543,19 +1547,6 @@ 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.)-#if __GLASGOW_HASKELL__ <= 710-strictToBang :: Strict -> Bang-strictToBang IsStrict  = Bang NoSourceUnpackedness SourceStrict-strictToBang NotStrict = Bang NoSourceUnpackedness NoSourceStrictness-strictToBang Unpacked  = Bang SourceUnpack SourceStrict-#else-strictToBang :: Bang -> Bang-strictToBang = id-#endif- -- 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 -> [DTyVarBndrUnit] -> DType@@ -1679,21 +1670,7 @@       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-      -- also appear in a kind on old GHCs.-      isKindBinderOnOldGHCs-#if __GLASGOW_HASKELL__ >= 800-        = const False-#else-        = (`elem` kindVars)-          where-            kindVars = foldMap fvDType $ M.elems varKindSigs-#endif-   in map ascribeWithKind $-     filter (not . isKindBinderOnOldGHCs) $      scopedSort freeVars  dtvbName :: DTyVarBndr flag -> Name@@ -1745,7 +1722,7 @@   | DFAAnon DType DFunArgs     -- ^ An anonymous argument followed by an arrow. For example, the @a@     --   in @a -> r@.-  deriving (Eq, Show, Typeable, Data, Generic)+  deriving (Eq, Show, Data, Generic)  -- | A /visible/ function argument type (i.e., one that must be supplied -- explicitly in the source code). This is in contrast to /invisible/@@ -1756,7 +1733,7 @@     -- ^ A visible @forall@ (e.g., @forall a -> a@).   | DVisFAAnon DType     -- ^ An anonymous argument followed by an arrow (e.g., @a -> r@).-  deriving (Eq, Show, Typeable, Data, Generic)+  deriving (Eq, Show, Data, Generic)  -- | Filter the visible function arguments from a list of 'DFunArgs'. filterDVisFunArgs :: DFunArgs -> [DVisFunArg]@@ -1866,4 +1843,138 @@ * For all other cases, just straightforwardly sweeten   `DForallT DForallInvis tvbs ty` to `ForallT tvbs [] ty` and   `DConstrainedT ctxt ty` to `ForallT [] ctxt ty`.++Note [Auxiliary tuples in pattern matching]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+th-desugar simplifies the overall treatment of pattern matching in two+notable ways:++1. Lambda expressions only bind variables and do not directly perform pattern+   matching. For example, this:++     \True False -> ()++   Roughly desugars to:++     \x y -> case (x, y) of+               (True, False) -> ()+               _             -> error "Non-exhaustive patterns"+2. th-desugar does not have guards, as guards are desugared into pattern+   matches. For example, this:++     f x y | True <- x+           , False <- y+           = ()++  Roughly desugars to:++    f x y = case (x, y) of+              (True, False) -> ()+              _             -> error "Non-exhaustive patterns"++In both of these examples, there are multiple expressions being matched on+simultaneously. When desugaring these examples to `case` expressions, we need a+construct that allows us to group these patterns together. Auxiliary tuples are+one way to accomplish this.++While this use of tuples works well when the arguments have lifted types, such+as Bool, it doesn't work when the arguments have unlifted types, such as Int#.+Imagine desugaring this lambda expression, for instance:++  \27# 42# -> ()++The approach above would desugar this to:++  \x y -> case (x, y) of+            (27#, 42#) -> ()+            _          -> error "Non-exhaustive patterns"++This will not typecheck, however, as we are using _lifted_ tuples, which+require their arguments to have lifted types. If we want to support unlifted+types, we need a different approach.++One idea that seems tempting at first is to create an auxiliary `let`+expression, e.g.,++  \x y ->+    let aux 27# 42# = ()+     in aux x y++This avoids having to use lifted tuples, but it creates a new problem: type+inference. In the general case, auxiliary `let` expressions aren't enough to+handle GADT pattern matches, such as in this example:++  data T a where+    MkT :: Int -> T Int++  g :: T a -> T a -> a+  g = \(MkT x1) (MkT x2) -> x1 + x2++If you desugar `g` to use an auxiliary `let` expression:++  g :: T a -> T a -> a+  g = \t1 t2 ->+        let aux (MkT x1) (MkT x2) = x1 + x2+        in aux t1 t2++Then it will not typecheck. To make this work, you'd need to give `aux` a type+signature. Doing this in general is tantamount to performing type inference,+however, which is very challenging in a Template Haskell setting.++Another approach, which is what th-desugar currently uses, is to use auxiliary+_unboxed_ tuples. This is identical to the previous tuple approach, but with+slightly different syntax:++  \x y -> case (# x, y #) of+            (# 27#, 42# #) -> ()+            _              -> error "Non-exhaustive patterns"++Unboxed tuples can handle lifted and unlifted arguments alike, so it is capable+of handling all the examples above.++You might worry that this approach would require clients of th-desugar to+enable the UnboxedTuples extension in non-obvious places, but fortunately, this+is not the case. For one thing, all unboxed tuples produced by th-desugar would+be TH-generated, so we would bypass the need to enable UnboxedTuples to lex+unboxed tuple syntax. GHC's typechecker also imposes a requirement that+UnboxedTuples be enabled if a variable has an unboxed tuple type, but this+never happens in th-desugar by construction. It's possible that a future+version of GHC might be stricter about this, but it seems unlikely.++There are a couple of exceptions to the general rule that auxiliary binders+should be unboxed:++1. ParallelListComp is desugared using the `mzip` function, which returns a+   lifted pair. As a result, the variables bound in a parallel list+   comprehension must be lifted. This is a restriction which is inherited from+   GHC itself—https://gitlab.haskell.org/ghc/ghc/-/merge_requests/7270.++2. Match flattening desugars lazy patterns that bind multiple variables to code+   that extracts fields from tuples. For instance, this:++     data Pair a b = MkPair a b++     f :: Pair a b -> Pair b a+     f ~(MkPair x y) = MkPair y x++   Desugars to this (roughly) when match-flattened:++     f :: Pair a b -> Pair b a+     f p =+       let tuple = case p of+                     MkPair x y -> (x, y)++           x = case tuple of+                 (x, _) -> x++           y = case tuple of+                 (_, y) -> x++        in MkPair y x++   One could imagine using an unboxed tuple here instead, but since the+   intermediate `tuple` value would have an unboxed tuple this, this would+   require users of match flattening to enable UnboxedTuples. Fortunately,+   using unboxed tuples here isn't necessary, as GHC doesn't support binding+   variables with unlifted types in lazy patterns anyway. -}

@@ -4,7 +4,7 @@ rae@cs.brynmawr.edu -} -{-# LANGUAGE CPP, NoMonomorphismRestriction, ScopedTypeVariables #-}+{-# LANGUAGE NoMonomorphismRestriction, ScopedTypeVariables #-}  ----------------------------------------------------------------------------- -- |@@ -30,10 +30,6 @@   ) where  import qualified Data.Map as M-import Control.Monad-#if __GLASGOW_HASKELL__ < 709-import Control.Applicative-#endif import Language.Haskell.TH hiding (cxt) import Language.Haskell.TH.Syntax ( Quasi(..) ) import Data.Data@@ -122,7 +118,6 @@     go :: Info -> q DType     go info = do       dinfo <- dsInfo info-      args_ok <- allM no_tyvars_tyfams normal_args       case dinfo of         DTyConI (DTySynD _n tvbs rhs) _           |  length normal_args >= length tvbs   -- this should always be true!@@ -134,9 +129,6 @@          DTyConI (DOpenTypeFamilyD (DTypeFamilyHead _n tvbs _frs _ann)) _           |  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 normal_args             -- We need to get the correct instance. If we fail to reify anything@@ -159,7 +151,6 @@          DTyConI (DClosedTypeFamilyD (DTypeFamilyHead _n tvbs _frs _ann) eqns) _           |  length normal_args >= length tvbs-          ,  args_ok           -> do             let (syn_args, rest_args) = splitAtList tvbs normal_args             rhss <- mapMaybeM (check_eqn syn_args) eqns@@ -185,45 +176,6 @@     -- arguments.     give_up :: q DType     give_up = return $ applyDType (DConT n) args--    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--        -- Recursive cases-        go_ty (DForallT tele ty)      = liftM2 (&&) (go_tele tele) (go_ty ty)-        go_ty (DConstrainedT ctxt ty) = liftM2 (&&) (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_tele :: DForallTelescope -> q Bool-        go_tele (DForallVis   tvbs) = allM go_tvb tvbs-        go_tele (DForallInvis tvbs) = allM go_tvb tvbs--        go_tvb :: DTyVarBndr flag -> 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  {- Note [Don't expand synonyms for *]

@@ -11,9 +11,6 @@   , extractBoundNamesDPat   ) where -#if __GLASGOW_HASKELL__ < 710-import Data.Foldable (foldMap)-#endif #if __GLASGOW_HASKELL__ < 804 import Data.Monoid ((<>)) #endif

@@ -15,7 +15,7 @@ ----------------------------------------------------------------------------  {-# LANGUAGE CPP, TemplateHaskell #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wno-orphans #-}  module Language.Haskell.TH.Desugar.Lift () where @@ -28,10 +28,6 @@                  , ''DConFields, ''DForeign, ''DPragma, ''DRuleBndr, ''DTySynEqn                  , ''DPatSynDir , ''NewOrData, ''DDerivStrategy                  , ''DTypeFamilyHead,  ''DFamilyResultSig-#if __GLASGOW_HASKELL__ <= 710-                 , ''InjectivityAnn, ''Bang, ''SourceUnpackedness-                 , ''SourceStrictness, ''Overlap-#endif #if __GLASGOW_HASKELL__ < 801                  , ''PatSynArgs #endif

@@ -9,15 +9,12 @@ This code is directly based on the analogous operation as written in GHC. -} -{-# LANGUAGE CPP, TemplateHaskell #-}+{-# LANGUAGE CPP, TemplateHaskellQuotes #-}  module Language.Haskell.TH.Desugar.Match (scExp, scLetDec) where  import Prelude hiding ( fail, exp ) -#if __GLASGOW_HASKELL__ < 709-import Control.Applicative-#endif import Control.Monad hiding ( fail ) import qualified Control.Monad as Monad import Data.Data@@ -29,7 +26,7 @@ import Language.Haskell.TH.Syntax  import Language.Haskell.TH.Desugar.AST-import Language.Haskell.TH.Desugar.Core+import Language.Haskell.TH.Desugar.Core (dsReify, maybeDLetE, mkTupleDExp) import Language.Haskell.TH.Desugar.FV import qualified Language.Haskell.TH.Desugar.OSet as OS import Language.Haskell.TH.Desugar.Util

@@ -7,7 +7,8 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -Wno-orphans #-}  ----------------------------------------------------------------------------- -- |@@ -52,25 +53,15 @@ 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)+  deriving (Data, Foldable, Functor, Eq, Ord, Read, Show, Traversable)  instance Ord k => Semigroup (OMap k v) where   (<>) = union@@ -81,7 +72,7 @@ #endif  empty :: forall k v. OMap k v-empty = coerce (OM.empty :: OM.OMap k v)+empty = coerce (OM.empty @k @v)  singleton :: k -> v -> OMap k v singleton k v = coerce (OM.singleton (k, v))@@ -97,55 +88,55 @@ 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)+union = coerce ((OM.|<>) @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)+delete = coerce (OM.delete @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)+(\\) = coerce ((OM.\\) @k @v @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)+intersection = coerce ((OM.|/\) @k @v @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)+null = coerce (OM.null @k @v)  size :: forall k v. OMap k v -> Int-size = coerce (OM.size :: OM.OMap k v -> Int)+size = coerce (OM.size @k @v)  member :: forall k v. Ord k => k -> OMap k v -> Bool-member = coerce (OM.member :: k -> OM.OMap k v -> Bool)+member = coerce (OM.member @k @v)  notMember :: forall k v. Ord k => k -> OMap k v -> Bool-notMember = coerce (OM.notMember :: k -> OM.OMap k v -> Bool)+notMember = coerce (OM.notMember @k @v)  lookup :: forall k v. Ord k => k -> OMap k v -> Maybe v-lookup = coerce (OM.lookup :: k -> OM.OMap k v -> Maybe v)+lookup = coerce (OM.lookup @k @v)  lookupIndex :: forall k v. Ord k => k -> OMap k v -> Maybe Index-lookupIndex = coerce (OM.findIndex :: k -> OM.OMap k v -> Maybe Index)+lookupIndex = coerce (OM.findIndex @k @v)  lookupAt :: forall k v. Index -> OMap k v -> Maybe (k, v)-lookupAt i m = coerce (OM.elemAt (coerce m) i :: Maybe (k, v))+lookupAt i m = OM.elemAt @k @v (coerce m) i  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)])+assocs = coerce (OM.assocs @k @v)  toAscList :: forall k v. OMap k v -> [(k, v)]-toAscList = coerce (OM.toAscList :: OM.OMap k v -> [(k, v)])+toAscList = coerce (OM.toAscList @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)+toMap = coerce (OM.toMap @k @v)

@@ -1,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}  ----------------------------------------------------------------------------- -- |@@ -44,7 +45,7 @@ import Prelude hiding (filter, lookup, null)  empty :: forall k v. OMap k v-empty = coerce (OM.empty :: OM.OMap k v)+empty = coerce (OM.empty @k @v)  singleton :: k -> v -> OMap k v singleton k v = coerce (OM.singleton (k, v))@@ -60,55 +61,55 @@ 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)+union = coerce ((OM.|<>) @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)+delete = coerce (OM.delete @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)+(\\) = coerce ((OM.\\) @k @v @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)+intersection = coerce ((OM.|/\) @k @v @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)+null = coerce (OM.null @k @v)  size :: forall k v. OMap k v -> Int-size = coerce (OM.size :: OM.OMap k v -> Int)+size = coerce (OM.size @k @v)  member :: forall k v. Ord k => k -> OMap k v -> Bool-member = coerce (OM.member :: k -> OM.OMap k v -> Bool)+member = coerce (OM.member @k @v)  notMember :: forall k v. Ord k => k -> OMap k v -> Bool-notMember = coerce (OM.notMember :: k -> OM.OMap k v -> Bool)+notMember = coerce (OM.notMember @k @v)  lookup :: forall k v. Ord k => k -> OMap k v -> Maybe v-lookup = coerce (OM.lookup :: k -> OM.OMap k v -> Maybe v)+lookup = coerce (OM.lookup @k @v)  lookupIndex :: forall k v. Ord k => k -> OMap k v -> Maybe Index-lookupIndex = coerce (OM.findIndex :: k -> OM.OMap k v -> Maybe Index)+lookupIndex = coerce (OM.findIndex @k @v)  lookupAt :: forall k v. Index -> OMap k v -> Maybe (k, v)-lookupAt i m = coerce (OM.elemAt (coerce m) i :: Maybe (k, v))+lookupAt i m = OM.elemAt @k @v (coerce m) i  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)])+assocs = coerce (OM.assocs @k @v)  toAscList :: forall k v. OMap k v -> [(k, v)]-toAscList = coerce (OM.toAscList :: OM.OMap k v -> [(k, v)])+toAscList = coerce (OM.toAscList @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)+toMap = coerce (OM.toMap @k @v)

@@ -3,6 +3,7 @@ {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}  ----------------------------------------------------------------------------- -- |@@ -46,11 +47,6 @@ 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@@ -59,13 +55,13 @@ -- 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)+  deriving (Data, Foldable, Eq, Monoid, Ord, Read, Show)  instance Ord a => Semigroup (OSet a) where   (<>) = union  empty :: forall a. OSet a-empty = coerce (OS.empty :: OS.OSet a)+empty = coerce (OS.empty @a)  singleton :: a -> OSet a singleton a = coerce (OS.singleton a)@@ -81,13 +77,13 @@ 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)+union = coerce ((OS.|<>) @a)  null :: forall a. OSet a -> Bool-null = coerce (OS.null :: OS.OSet a -> Bool)+null = coerce (OS.null @a)  size :: forall a. OSet a -> Int-size = coerce (OS.size :: OS.OSet a -> Int)+size = coerce (OS.size @a)  member, notMember :: Ord a => a -> OSet a -> Bool member    a = coerce (OS.member a)@@ -100,22 +96,22 @@ 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)+(\\) = coerce ((OS.\\) @a)  intersection :: forall a. Ord a => OSet a -> OSet a -> OSet a-intersection = coerce ((OS.|/\) :: OS.OSet a -> OS.OSet a -> OS.OSet a)+intersection = coerce ((OS.|/\) @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)+lookupAt i s = OS.elemAt @a (coerce s) i  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])+toAscList = coerce (OS.toAscList @a)  toSet :: forall a. OSet a -> S.Set a-toSet = coerce (OS.toSet :: OS.OSet a -> S.Set a)+toSet = coerce (OS.toSet @a)

@@ -40,9 +40,6 @@ import Control.Monad.RWS import Control.Monad.Trans.Instances () import qualified Data.Foldable as F-#if __GLASGOW_HASKELL__ < 710-import Data.Foldable (foldMap)-#endif import Data.Function (on) import qualified Data.List as List import qualified Data.Map as Map@@ -107,13 +104,8 @@            TyConI dec -> return dec            _ -> badDeclaration   case dec of-#if __GLASGOW_HASKELL__ > 710     DataD _cxt _name tvbs mk cons _derivings -> go tvbs mk cons     NewtypeD _cxt _name tvbs mk con _derivings -> go tvbs mk [con]-#else-    DataD _cxt _name tvbs cons _derivings -> go tvbs Nothing cons-    NewtypeD _cxt _name tvbs con _derivings -> go tvbs Nothing [con]-#endif     _ -> badDeclaration   where     go tvbs mk cons = do@@ -157,11 +149,7 @@ dataConNameToDataName con_name = do   info <- reifyWithLocals con_name   case info of-#if __GLASGOW_HASKELL__ > 710     DataConI _name _type parent_name -> return parent_name-#else-    DataConI _name _type parent_name _fixity -> return parent_name-#endif     _ -> fail $ "The name " ++ show con_name ++ " does not appear to be " ++                 "a data constructor." @@ -182,10 +170,8 @@     get_con_name (RecC name _)        = [name]     get_con_name (InfixC _ name _)    = [name]     get_con_name (ForallC _ _ con)    = get_con_name con-#if __GLASGOW_HASKELL__ > 710     get_con_name (GadtC names _ _)    = names     get_con_name (RecGadtC names _ _) = names-#endif  -------------------------------------------------- -- DsMonad@@ -258,75 +244,42 @@ reifyInDec n decs (ValD pat _ _)   | Just n' <- List.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)-#else-reifyInDec n _    dec@(DataD    _ n' _ _ _) | n `nameMatches` n' = Just (n', TyConI dec)-reifyInDec n _    dec@(NewtypeD _ n' _ _ _) | n `nameMatches` n' = Just (n', TyConI dec)-#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 (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 _    (ForeignD (ImportF _ _ _ n' ty)) | n `nameMatches` n'+  = Just (n', mkVarITy n ty)+reifyInDec n _    (ForeignD (ExportF _ _ n' ty)) | n `nameMatches` n'+  = Just (n', mkVarITy n ty) reifyInDec n decs dec@(OpenTypeFamilyD (TypeFamilyHead n' _ _ _)) | n `nameMatches` n'   = Just (n', FamilyI dec (findInstances n decs)) reifyInDec n decs dec@(DataFamilyD n' _ _) | n `nameMatches` n'   = 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 dec (findInstances n decs))-reifyInDec n _    dec@(ClosedTypeFamilyD n' _ _ _) | n `nameMatches` n'-  = Just (n', FamilyI dec [])-#endif #if __GLASGOW_HASKELL__ >= 801 reifyInDec n decs (PatSynD n' _ _ _) | n `nameMatches` n'   = Just (n', mkPatSynI n decs) #endif -#if __GLASGOW_HASKELL__ > 710 reifyInDec n decs (DataD _ ty_name tvbs _mk 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 tvbToTANormalWithSig tvbs) [con]   = Just info-#else-reifyInDec n decs (DataD _ ty_name 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 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 (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 (quantifyClassMethodType ty_name tvbs True ty)-                       ty_name (fromMaybe defaultFixity $-                                reifyFixityInDecs n $ sub_decs ++ decs))-#endif reifyInDec n decs (ClassD _ _ _ _ sub_decs)   | Just info <- firstMatch (reifyInDec n decs) sub_decs                  -- Important: don't pass (sub_decs ++ decs) to reifyInDec                  -- above, or else type family defaults can be confused for                  -- actual instances. See #134.   = Just info-#if __GLASGOW_HASKELL__ >= 711 reifyInDec n decs (InstanceD _ _ _ sub_decs)-#else-reifyInDec n decs (InstanceD _ _ sub_decs)-#endif   | Just info <- firstMatch reify_in_instance sub_decs   = Just info   where@@ -342,20 +295,13 @@   | (ConT ty_name, tys) <- unfoldType lhs   , Just info <- maybeReifyCon n decs ty_name tys [con]   = Just info-#elif __GLASGOW_HASKELL__ > 710+#else reifyInDec n decs (DataInstD _ 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 (map TANormal tys) [con]   = Just info-#else-reifyInDec n decs (DataInstD _ 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 (map TANormal tys) [con]-  = Just info #endif  reifyInDec _ _ _ = Nothing@@ -365,22 +311,14 @@   | Just (n', con) <- findCon n cons     -- See Note [Use unSigType in maybeReifyCon]   , let full_con_ty = unSigType $ con_to_type h98_tvbs h98_res_ty con-  = Just ( n', DataConI n full_con_ty ty_name-#if __GLASGOW_HASKELL__ < 800-                        fixity-#endif-         )+  = Just (n', DataConI n full_con_ty ty_name)    | Just (n', rec_sel_info) <- findRecSelector n cons   , let (tvbs, sel_ty, con_res_ty) = extract_rec_sel_info rec_sel_info         -- See Note [Use unSigType in maybeReifyCon]         full_sel_ty = unSigType $ maybeForallT tvbs [] $ mkArrows [con_res_ty] sel_ty       -- we don't try to ferret out naughty record selectors.-  = Just ( n', VarI n full_sel_ty Nothing-#if __GLASGOW_HASKELL__ < 800-                    fixity-#endif-         )+  = Just (n', VarI n full_sel_ty Nothing)   where     extract_rec_sel_info :: RecSelInfo -> ([TyVarBndrUnit], Type, Type)       -- Returns ( Selector type variable binders@@ -396,9 +334,6 @@     h98_tvbs   = freeVariablesWellScoped $ map probablyWrongUnTypeArg ty_args     h98_res_ty = applyType (ConT ty_name) ty_args -#if __GLASGOW_HASKELL__ < 800-    fixity = fromMaybe defaultFixity $ reifyFixityInDecs n _decs-#endif maybeReifyCon _ _ _ _ _ = Nothing  {-@@ -435,21 +370,14 @@     go (RecC _ vstys)         = (False, mkArrows (map thdOf3 vstys) h98_result_ty)     go (InfixC t1 _ t2)       = (False, mkArrows (map snd [t1, t2]) h98_result_ty)     go (ForallC bndrs cxt c)  = liftSnd (ForallT bndrs cxt) (go c)-#if __GLASGOW_HASKELL__ > 710     go (GadtC _ stys rty)     = (True, mkArrows (map snd    stys)  rty)     go (RecGadtC _ vstys rty) = (True, mkArrows (map thdOf3 vstys) rty)-#endif  mkVarI :: Name -> [Dec] -> Info-mkVarI n decs = mkVarITy n decs (maybe (no_type n) snd $ findType n decs)+mkVarI n decs = mkVarITy n (maybe (no_type n) snd $ findType n decs) -mkVarITy :: Name -> [Dec] -> Type -> Info-#if __GLASGOW_HASKELL__ > 710-mkVarITy n _decs ty = VarI n ty Nothing-#else-mkVarITy n decs ty = VarI n ty Nothing (fromMaybe defaultFixity $-                                        reifyFixityInDecs n decs)-#endif+mkVarITy :: Name -> Type -> Info+mkVarITy n ty = VarI n ty Nothing  findType :: Name -> [Dec] -> Maybe (Named Type) findType n = firstMatch match_type@@ -475,12 +403,7 @@ findInstances :: Name -> [Dec] -> [Dec] findInstances n = map stripInstanceDec . concatMap match_instance   where-#if __GLASGOW_HASKELL__ >= 711-    match_instance d@(InstanceD _ _ ty _)-#else-    match_instance d@(InstanceD _ ty _)-#endif-                                               | ConT n' <- ty_head ty+    match_instance d@(InstanceD _ _ ty _)      | ConT n' <- ty_head ty                                                , n `nameMatches` n' = [d] #if __GLASGOW_HASKELL__ >= 807     match_instance (DataInstD ctxt _ lhs mk cons derivs)@@ -495,12 +418,9 @@       where         mtvbs = rejig_data_inst_tvbs ctxt lhs mk         d = NewtypeInstD ctxt mtvbs lhs mk con derivs-#elif __GLASGOW_HASKELL__ > 710+#else     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__ >= 807     match_instance (TySynInstD (TySynEqn _ lhs rhs))@@ -513,11 +433,7 @@     match_instance d@(TySynInstD n' _)         | n `nameMatches` n' = [d] #endif -#if __GLASGOW_HASKELL__ >= 711     match_instance (InstanceD _ _ _ decs)-#else-    match_instance (InstanceD _ _ decs)-#endif                                         = concatMap match_instance decs     match_instance _                    = [] @@ -607,10 +523,8 @@       Just $ SigD n            $ quantifyClassMethodType cls_name cls_tvbs prepend_cls ty     go d@(TySynInstD {})      = Just d-#if __GLASGOW_HASKELL__ > 710     go d@(OpenTypeFamilyD {}) = Just d     go d@(DataFamilyD {})     = Just d-#endif     go _           = Nothing      -- See (2) in the comments for quantifyClassDecMethods.@@ -655,11 +569,7 @@       | otherwise = id      cls_cxt :: Cxt-#if __GLASGOW_HASKELL__ < 709-    cls_cxt = [ClassP cls_name (map tvbToType cls_tvbs)]-#else     cls_cxt = [foldl AppT (ConT cls_name) (map tvbToType cls_tvbs)]-#endif      quantified_meth_ty :: Type     quantified_meth_ty@@ -680,11 +590,7 @@     all_cls_tvbs = freeVariablesWellScoped $ map tvbToTypeWithSig cls_tvbs  stripInstanceDec :: Dec -> Dec-#if __GLASGOW_HASKELL__ >= 711 stripInstanceDec (InstanceD over cxt ty _) = InstanceD over cxt ty []-#else-stripInstanceDec (InstanceD cxt ty _)      = InstanceD cxt ty []-#endif stripInstanceDec dec                       = dec  mkArrows :: [Type] -> Type -> Type@@ -711,18 +617,14 @@         ForallC _ _ c -> case match_con c of                            Just (n', _) -> Just (n', con)                            Nothing      -> Nothing-#if __GLASGOW_HASKELL__ > 710         GadtC nms _ _    -> gadt_case con nms         RecGadtC nms _ _ -> gadt_case con nms-#endif         _                -> Nothing -#if __GLASGOW_HASKELL__ > 710     gadt_case :: Con -> [Name] -> Maybe (Named Con)     gadt_case con nms = case List.find (n `nameMatches`) nms of                           Just n' -> Just (n', con)                           Nothing -> Nothing-#endif  data RecSelInfo   = RecSelH98  Type -- The record field's type@@ -735,10 +637,8 @@     match_con :: Con -> Maybe (Named RecSelInfo)     match_con (RecC _ vstys)            = fmap (liftSnd RecSelH98) $                                           firstMatch match_rec_sel vstys-#if __GLASGOW_HASKELL__ >= 800     match_con (RecGadtC _ vstys ret_ty) = fmap (liftSnd (`RecSelGADT` ret_ty)) $                                           firstMatch match_rec_sel vstys-#endif     match_con (ForallC _ _ c)           = match_con c     match_con _                         = Nothing @@ -749,29 +649,7 @@ --------------------------------- -- Reifying fixities --------------------------------------- This section allows GHC 7.x to call reifyFixity -#if __GLASGOW_HASKELL__ < 711-qReifyFixity :: Quasi m => Name -> m (Maybe Fixity)-qReifyFixity name = do-  info <- qReify name-  return $ case info of-    ClassOpI _ _ _ fixity -> Just fixity-    DataConI _ _ _ fixity -> Just fixity-    VarI _ _ _ fixity     -> Just fixity-    _                     -> Nothing--{- | @reifyFixity nm@ attempts to find a fixity declaration for @nm@. For-example, if the function @foo@ has the fixity declaration @infixr 7 foo@, then-@reifyFixity 'foo@ would return @'Just' ('Fixity' 7 'InfixR')@. If the function-@bar@ does not have a fixity declaration, then @reifyFixity 'bar@ returns-'Nothing', so you may assume @bar@ has 'defaultFixity'.--}-reifyFixity :: Name -> Q (Maybe Fixity)-reifyFixity = qReifyFixity-#endif- -- | Like 'reifyWithLocals_maybe', but for fixities. Note that a return value -- of @Nothing@ might mean that the name is not in scope, or it might mean -- that the name has no assigned fixity. (Use 'reifyWithLocals_maybe' if@@ -847,21 +725,9 @@ infoType :: Info -> Maybe Type infoType info =   case info of-    ClassOpI _ t _-#if __GLASGOW_HASKELL__ < 800-             _-#endif-                   -> Just t-    DataConI _ t _-#if __GLASGOW_HASKELL__ < 800-             _-#endif-                   -> Just t-    VarI _ t _-#if __GLASGOW_HASKELL__ < 800-         _-#endif-                   -> Just t+    ClassOpI _ t _ -> Just t+    DataConI _ t _ -> Just t+    VarI _ t _     -> Just t     TyVarI _ t     -> Just t #if __GLASGOW_HASKELL__ >= 802     PatSynI _ t    -> Just t@@ -907,7 +773,6 @@ -- This is only done when -XCUSKs is enabled, or on older GHCs where -- CUSKs were the only means of specifying this information. match_cusk :: Name -> Dec -> Maybe Kind-#if __GLASGOW_HASKELL__ >= 800 match_cusk n (DataD _ n' tvbs m_ki _ _)   | n `nameMatches` n'   = datatype_kind tvbs m_ki@@ -923,20 +788,6 @@ match_cusk n (ClosedTypeFamilyD (TypeFamilyHead n' tvbs res_sig _) _)   | n `nameMatches` n'   = closed_ty_fam_kind tvbs (res_sig_to_kind res_sig)-#else-match_cusk n (DataD _ n' tvbs _ _)-  | n `nameMatches` n'-  = datatype_kind tvbs Nothing-match_cusk n (NewtypeD _ n' tvbs _ _)-  | n `nameMatches` n'-  = datatype_kind tvbs Nothing-match_cusk n (FamilyD _ n' tvbs m_ki)-  | n `nameMatches` n'-  = open_ty_fam_kind tvbs m_ki-match_cusk n (ClosedTypeFamilyD n' tvbs m_ki _)-  | n `nameMatches` n'-  = closed_ty_fam_kind tvbs m_ki-#endif match_cusk n (TySynD n' tvbs rhs)   | n `nameMatches` n'   = ty_syn_kind tvbs rhs@@ -961,7 +812,6 @@ find_assoc_type_kind :: Name -> Map Name Kind -> Dec -> Maybe Kind find_assoc_type_kind n cls_tvb_kind_map sub_dec =   case sub_dec of-#if __GLASGOW_HASKELL__ >= 800     DataFamilyD n' tf_tvbs m_ki       |  n `nameMatches` n'       -> build_kind (map ascribe_tf_tvb_kind tf_tvbs) (default_res_ki m_ki)@@ -969,11 +819,6 @@       |  n `nameMatches` n'       -> build_kind (map ascribe_tf_tvb_kind tf_tvbs)                     (default_res_ki $ res_sig_to_kind res_sig)-#else-    FamilyD _ n' tf_tvbs m_ki-      |  n `nameMatches` n'-      -> build_kind (map ascribe_tf_tvb_kind tf_tvbs) (default_res_ki m_ki)-#endif     _ -> Nothing   where     ascribe_tf_tvb_kind :: TyVarBndrUnit -> TyVarBndrUnit@@ -1092,12 +937,10 @@ default_res_ki :: Maybe Kind -> Kind default_res_ki = fromMaybe StarT -#if __GLASGOW_HASKELL__ >= 800 res_sig_to_kind :: FamilyResultSig -> Maybe Kind res_sig_to_kind NoSig          = Nothing res_sig_to_kind (KindSig k)    = Just k res_sig_to_kind (TyVarSig tvb) = tvb_kind_maybe tvb-#endif  whenAlt :: Alternative f => Bool -> f a -> f a whenAlt b fa = if b then fa else empty

@@ -32,10 +32,6 @@ import Language.Haskell.TH.Syntax import Language.Haskell.TH.Desugar.Util -#if __GLASGOW_HASKELL__ < 710-import Control.Applicative-#endif- -- | A substitution is just a map from names to types type DSubst = M.Map Name DType 

@@ -7,7 +7,7 @@ -}  {-# LANGUAGE CPP #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TemplateHaskellQuotes #-}  ----------------------------------------------------------------------------- -- |@@ -55,11 +55,7 @@ expToTH (DCaseE exp matches) = CaseE (expToTH exp) (map matchToTH matches) expToTH (DLetE decs exp)     = LetE (map letDecToTH decs) (expToTH exp) expToTH (DSigE exp ty)       = SigE (expToTH exp) (typeToTH ty)-#if __GLASGOW_HASKELL__ < 709-expToTH (DStaticE _)         = error "Static expressions supported only in GHC 7.10+"-#else expToTH (DStaticE exp)       = StaticE (expToTH exp)-#endif #if __GLASGOW_HASKELL__ >= 801 expToTH (DAppTypeE exp ty)   = AppTypeE (expToTH exp) (typeToTH ty) #else@@ -92,21 +88,11 @@ decToTH :: DDec -> Dec decToTH (DLetDec d) = letDecToTH d decToTH (DDataD Data cxt n tvbs _mk cons derivings) =-#if __GLASGOW_HASKELL__ > 710   DataD (cxtToTH cxt) n (map tvbToTH tvbs) (fmap typeToTH _mk) (map conToTH cons)         (concatMap derivClauseToTH derivings)-#else-  DataD (cxtToTH cxt) n (map tvbToTH tvbs) (map conToTH cons)-        (map derivingToTH derivings)-#endif decToTH (DDataD Newtype cxt n tvbs _mk [con] derivings) =-#if __GLASGOW_HASKELL__ > 710   NewtypeD (cxtToTH cxt) n (map tvbToTH tvbs) (fmap typeToTH _mk) (conToTH con)            (concatMap derivClauseToTH derivings)-#else-  NewtypeD (cxtToTH cxt) n (map tvbToTH tvbs) (conToTH con)-           (map derivingToTH derivings)-#endif decToTH (DDataD Newtype _cxt _n _tvbs _mk _cons _derivings) =   error "Newtype declaration without exactly 1 constructor." decToTH (DTySynD n tvbs ty) = TySynD n (map tvbToTH tvbs) (typeToTH ty)@@ -116,19 +102,10 @@   -- We deliberately avoid sweetening _mtvbs. See #151.   instanceDToTH over cxt ty decs decToTH (DForeignD f) = ForeignD (foreignToTH f)-#if __GLASGOW_HASKELL__ > 710 decToTH (DOpenTypeFamilyD (DTypeFamilyHead n tvbs frs ann)) =   OpenTypeFamilyD (TypeFamilyHead n (map tvbToTH tvbs) (frsToTH frs) ann)-#else-decToTH (DOpenTypeFamilyD (DTypeFamilyHead n tvbs frs _ann)) =-  FamilyD TypeFam n (map tvbToTH tvbs) (frsToTH frs)-#endif decToTH (DDataFamilyD n tvbs mk) =-#if __GLASGOW_HASKELL__ > 710   DataFamilyD n (map tvbToTH tvbs) (fmap typeToTH mk)-#else-  FamilyD DataFam n (map tvbToTH tvbs) (fmap typeToTH mk)-#endif decToTH (DDataInstD nd cxt mtvbs lhs mk cons derivings) =   let ndc = case (nd, cons) of               (Newtype, [con]) -> DNewtypeCon con@@ -142,24 +119,14 @@   let (n, eqn') = tySynEqnToTH eqn in   TySynInstD n eqn' #endif-#if __GLASGOW_HASKELL__ > 710 decToTH (DClosedTypeFamilyD (DTypeFamilyHead n tvbs frs ann) eqns) =   ClosedTypeFamilyD (TypeFamilyHead n (map tvbToTH tvbs) (frsToTH frs) ann)                     (map (snd . tySynEqnToTH) eqns)-#else-decToTH (DClosedTypeFamilyD (DTypeFamilyHead n tvbs frs _ann) 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) =   -- We deliberately avoid sweetening _mtvbs. See #151.   standaloneDerivDToTH mds cxt ty-#if __GLASGOW_HASKELL__ < 709-decToTH (DDefaultSigD {})      =-  error "Default method signatures supported only in GHC 7.10+"-#else decToTH (DDefaultSigD n ty)        = DefaultSigD n (typeToTH ty)-#endif #if __GLASGOW_HASKELL__ >= 801 decToTH (DPatSynD n args dir pat) = PatSynD n args (patSynDirToTH dir) (patToTH pat) decToTH (DPatSynSigD n ty)        = PatSynSigD n (typeToTH ty)@@ -173,6 +140,12 @@ decToTH (DKiSigD {})   =   error "Standalone kind signatures supported only in GHC 8.10+" #endif+#if __GLASGOW_HASKELL__ >= 903+decToTH (DDefaultD tys) = DefaultD (map typeToTH tys)+#else+decToTH (DDefaultD{})   =+  error "Default declarations supported only in GHC 9.4+"+#endif  #if __GLASGOW_HASKELL__ < 801 patSynErr :: a@@ -195,12 +168,9 @@       NewtypeInstD (cxtToTH cxt) (fmap (fmap tvbToTH) _mtvbs) (typeToTH lhs)                    (fmap typeToTH _mk) (conToTH con)                    (concatMap derivClauseToTH derivings)-#elif __GLASGOW_HASKELL__ > 710+#else       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 ->@@ -208,12 +178,9 @@       DataInstD (cxtToTH cxt) (fmap (fmap tvbToTH) _mtvbs) (typeToTH lhs)                 (fmap typeToTH _mk) (map conToTH cons)                 (concatMap derivClauseToTH derivings)-#elif __GLASGOW_HASKELL__ > 710+#else       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@@ -222,26 +189,11 @@         (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 frsToTH (DKindSig k)    = KindSig (typeToTH k) frsToTH (DTyVarSig tvb) = TyVarSig (tvbToTH tvb)-#else-frsToTH :: DFamilyResultSig -> Maybe Kind-frsToTH DNoSig                        = Nothing-frsToTH (DKindSig k)                  = Just (typeToTH k)-frsToTH (DTyVarSig (DPlainTV _ _))    = Nothing-frsToTH (DTyVarSig (DKindedTV _ _ k)) = Just (typeToTH k)-#endif -#if __GLASGOW_HASKELL__ <= 710-derivingToTH :: DDerivClause -> Name-derivingToTH (DDerivClause _ [DConT nm]) = nm-derivingToTH p =-  error ("Template Haskell in GHC < 8.0 only allows simple derivings: " ++ show p)-#endif- -- | Sweeten a 'DLetDec'. letDecToTH :: DLetDec -> Dec letDecToTH (DFunD name clauses) = FunD name (map clauseToTH clauses)@@ -251,93 +203,27 @@ letDecToTH (DPragmaD prag)      = PragmaD (pragmaToTH prag)  conToTH :: DCon -> Con-#if __GLASGOW_HASKELL__ > 710 conToTH (DCon [] [] n (DNormalC _ stys) rty) =   GadtC [n] (map (second typeToTH) stys) (typeToTH rty) conToTH (DCon [] [] n (DRecC vstys) rty) =   RecGadtC [n] (map (thirdOf3 typeToTH) vstys) (typeToTH rty)-#else-conToTH (DCon [] [] n (DNormalC True [sty1, sty2]) _) =-  InfixC ((bangToStrict *** typeToTH) sty1) n ((bangToStrict *** typeToTH) sty2)--- Note: it's possible that someone could pass in a DNormalC value that--- erroneously claims that it's declared infix (e.g., if has more than two--- fields), but we will fall back on NormalC in such a scenario.-conToTH (DCon [] [] n (DNormalC _ stys) _) =-  NormalC n (map (bangToStrict *** typeToTH) stys)-conToTH (DCon [] [] n (DRecC vstys) _) =-  RecC n (map (\(v,b,t) -> (v,bangToStrict b,typeToTH t)) vstys)-#endif-#if __GLASGOW_HASKELL__ > 710 -- On GHC 8.0 or later, we sweeten every constructor to GADT syntax, so it is -- perfectly OK to put all of the quantified type variables -- (both universal and existential) in a ForallC. conToTH (DCon tvbs cxt n fields rty) =   ForallC (map tvbToTH tvbs) (cxtToTH cxt) (conToTH $ DCon [] [] n fields rty)-#else--- On GHCs earlier than 8.0, we must be careful, since the only time ForallC is--- used is when there are either:------ 1. Any existentially quantified type variables--- 2. A constructor context------ If neither of these conditions hold, then we needn't put a ForallC at the--- front, since it would be completely pointless (you'd end up with things like--- @data Foo = forall. MkFoo@!).-conToTH (DCon tvbs cxt n fields rty)-  | null ex_tvbs && null cxt-  = con'-  | otherwise-  = ForallC ex_tvbs (cxtToTH cxt) con'-  where-    -- Fortunately, on old GHCs, it's especially easy to distinguish between-    -- universally and existentially quantified type variables. When desugaring-    -- a ForallC, we just stick all of the universals (from the datatype-    -- definition) at the front of the @forall@. Therefore, it suffices to-    -- count the number of type variables in the return type and drop that many-    -- variables from the @forall@ in the ForallC, leaving only the-    -- existentials.-    ex_tvbs :: [TyVarBndr]-    ex_tvbs = map tvbToTH $ drop num_univ_tvs tvbs -    num_univ_tvs :: Int-    num_univ_tvs = go rty-      where-        go :: DType -> Int-        go (DAppT t1 t2) = go t1 + go t2-        go (DSigT t _)   = go t-        go (DVarT {})    = 1-        go (DConT {})    = 0-        go DArrowT       = 0-        go (DLitT {})    = 0-        -- These won't show up on pre-8.0 GHCs-        go (DForallT {})      = error "`forall` type used in GADT return type"-        go (DConstrainedT {}) = error "Constrained 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)+instanceDToTH over cxt ty decs =+  InstanceD over (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) =@@ -358,16 +244,17 @@   RuleP str (map ruleBndrToTH rbs) (expToTH lhs) (expToTH rhs) phases #endif pragmaToTH (DAnnP target exp) = AnnP target (expToTH exp)-#if __GLASGOW_HASKELL__ < 709-pragmaToTH (DLineP {}) = error "LINE pragmas only supported in GHC 7.10+"-#else pragmaToTH (DLineP n str) = LineP n str-#endif #if __GLASGOW_HASKELL__ < 801 pragmaToTH (DCompleteP {}) = error "COMPLETE pragmas only supported in GHC 8.2+" #else pragmaToTH (DCompleteP cls mty) = CompleteP cls mty #endif+#if __GLASGOW_HASKELL__ >= 903+pragmaToTH (DOpaqueP n) = OpaqueP n+#else+pragmaToTH (DOpaqueP {}) = error "OPAQUE pragmas only supported in GHC 9.4+"+#endif  ruleBndrToTH :: DRuleBndr -> RuleBndr ruleBndrToTH (DRuleVar n) = RuleVar n@@ -418,11 +305,7 @@ typeToTH (DConT n)              = tyconToTH n typeToTH DArrowT                = ArrowT typeToTH (DLitT lit)            = LitT lit-#if __GLASGOW_HASKELL__ > 710 typeToTH DWildCardT = WildCardT-#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@@ -467,44 +350,13 @@ #endif  predToTH :: DPred -> Pred-#if __GLASGOW_HASKELL__ < 709-predToTH = go []-  where-    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 _   (DVarT _)-      = error "Template Haskell in GHC <= 7.8 does not support variable constraints."-    go _ DWildCardT-      = error "Wildcards supported only in GHC 8.0+"-    go _ (DForallT {})-      = error "Quantified constraints supported only in GHC 8.6+"-    go _ (DConstrainedT {})-      = 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 (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 DWildCardT  = WildCardT-#else-predToTH DWildCardT  = error "Wildcards supported only in GHC 8.0+"-#endif #if __GLASGOW_HASKELL__ >= 805 -- We need a special case for DForallT ForallInvis followed by DConstrainedT -- so that we may collapse them into a single ForallT when sweetening.@@ -527,15 +379,12 @@ -- kind applications, we will simply drop the applied kind. predToTH (DAppKindT p _) = predToTH p #endif-#endif  tyconToTH :: Name -> Type tyconToTH n   | n == ''(->)                 = ArrowT -- Work around Trac #14888   | n == ''[]                   = ListT-#if __GLASGOW_HASKELL__ >= 709   | n == ''(~)                  = EqualityT-#endif   | n == '[]                    = PromotedNilT   | n == '(:)                   = PromotedConsT   | Just deg <- tupleNameDegree_maybe n@@ -555,11 +404,3 @@ 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'-bangToStrict :: Bang -> Strict-bangToStrict (Bang SourceUnpack _) = Unpacked-bangToStrict (Bang _ SourceStrict) = IsStrict-bangToStrict (Bang _ _)            = NotStrict-#endif

@@ -6,13 +6,9 @@ Utility functions for th-desugar package. -} -{-# LANGUAGE CPP, DeriveDataTypeable, RankNTypes, ScopedTypeVariables, TupleSections #-}--#if __GLASGOW_HASKELL__ >= 800-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE TemplateHaskellQuotes #-}-{-# LANGUAGE TypeApplications #-}-#endif+{-# LANGUAGE CPP, DeriveDataTypeable, RankNTypes, ScopedTypeVariables,+             TupleSections, AllowAmbiguousTypes, TemplateHaskellQuotes,+             TypeApplications #-}  module Language.Haskell.TH.Desugar.Util (   newUniqueName,@@ -32,10 +28,8 @@   isTypeKindName, typeKindName,   unSigType, unfoldType, ForallTelescope(..), FunArgs(..), VisFunArg(..),   filterVisFunArgs, ravelType, unravelType,-  TypeArg(..), applyType, filterTANormals, probablyWrongUnTypeArg-#if __GLASGOW_HASKELL__ >= 800-  , bindIP-#endif+  TypeArg(..), applyType, filterTANormals, probablyWrongUnTypeArg,+  bindIP   ) where  import Prelude hiding (mapM, foldl, concatMap, any)@@ -48,19 +42,12 @@  import qualified Control.Monad.Fail as Fail import Data.Foldable+import qualified Data.Kind as Kind import Data.Generics hiding ( Fixity ) import Data.Traversable import Data.Maybe--#if __GLASGOW_HASKELL__ < 710-import Data.Monoid-#endif--#if __GLASGOW_HASKELL__ >= 800-import qualified Data.Kind as Kind import GHC.Classes ( IP ) import Unsafe.Coerce ( unsafeCoerce )-#endif  ---------------------------------------- -- TH manipulations@@ -214,7 +201,7 @@   | ForallInvis [TyVarBndrSpec]     -- ^ An invisible @forall@ (e.g., @forall a {b} c -> {...}@),     --   where each binder has a 'Specificity'.-  deriving (Eq, Show, Typeable, Data)+  deriving (Eq, Show, Data)  -- | The list of arguments in a function 'Type'. data FunArgs@@ -230,7 +217,7 @@   | FAAnon Type FunArgs     -- ^ An anonymous argument followed by an arrow. For example, the @a@     --   in @a -> r@.-  deriving (Eq, Show, Typeable, Data)+  deriving (Eq, Show, Data)  -- | A /visible/ function argument type (i.e., one that must be supplied -- explicitly in the source code). This is in contrast to /invisible/@@ -241,7 +228,7 @@     -- ^ A visible @forall@ (e.g., @forall a -> a@).   | VisFAAnon Type     -- ^ An anonymous argument followed by an arrow (e.g., @a -> r@).-  deriving (Eq, Show, Typeable, Data)+  deriving (Eq, Show, Data)  -- | Filter the visible function arguments from a list of 'FunArgs'. filterVisFunArgs :: FunArgs -> [VisFunArg]@@ -297,11 +284,9 @@ 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)@@ -310,12 +295,7 @@  -- | 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: --@@ -335,9 +315,7 @@     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@@ -351,7 +329,7 @@ data TypeArg   = TANormal Type   | TyArg Kind-  deriving (Eq, Show, Typeable, Data)+  deriving (Eq, Show, Data)  -- | Apply one 'Type' to a list of arguments. applyType :: Type -> [TypeArg] -> Type@@ -445,7 +423,6 @@ -- General utility ---------------------------------------- -#if __GLASGOW_HASKELL__ >= 800 -- dirty implementation of explicit-to-implicit conversion newtype MagicIP name a r = MagicIP (IP name a => r) @@ -455,7 +432,6 @@ -- 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])@@ -542,34 +518,17 @@                 || n == uniStarKindName #endif --- | The 'Name' of:------ 1. The kind 'Kind.Type', on GHC 8.0 or later.+-- | The 'Name' of the kind 'Kind.Type'. -- 2. The kind @*@ on older GHCs. typeKindName :: Name-#if __GLASGOW_HASKELL__ >= 800 typeKindName = ''Kind.Type-#else-typeKindName = starKindName-#endif  #if __GLASGOW_HASKELL__ < 805 -- | The 'Name' of the kind @*@. starKindName :: Name-#if __GLASGOW_HASKELL__ >= 800 starKindName = ''(Kind.*)-#else-starKindName = mkNameG_tc "ghc-prim" "GHC.Prim" "*"-#endif --- | The 'Name' of:------ 1. The kind 'Kind.★', on GHC 8.0 or later.--- 2. The kind @*@ on older GHCs.+-- | The 'Name' of the kind 'Kind.★'. uniStarKindName :: Name-#if __GLASGOW_HASKELL__ >= 800 uniStarKindName = ''(Kind.★)-#else-uniStarKindName = starKindName-#endif #endif

@@ -23,6 +23,10 @@ possible.  I will try to keep this package up-to-date with respect to changes in GHC.+The minimum supported version of GHC is 8.0, which was chosen to avoid various+Template Haskell bugs in older GHC versions that affect how this library+desugars code. If this choice negatively impacts you, please submit a bug+report.  Known limitations -----------------

@@ -8,16 +8,10 @@              MultiParamTypeClasses, FunctionalDependencies,              FlexibleInstances, DataKinds, CPP, RankNTypes,              StandaloneDeriving, DefaultSignatures,-             ConstraintKinds, RoleAnnotations #-}-#if __GLASGOW_HASKELL__ >= 710-{-# LANGUAGE DeriveAnyClass #-}-#endif--{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-name-shadowing #-}+             ConstraintKinds, RoleAnnotations, DeriveAnyClass #-} -#if __GLASGOW_HASKELL__ >= 711-{-# OPTIONS_GHC -Wno-redundant-constraints #-}-#endif+{-# OPTIONS_GHC -Wno-orphans -Wno-name-shadowing+                -Wno-redundant-constraints #-}  module Dec where @@ -34,21 +28,15 @@ $(S.dectest8) $(S.dectest9) $(S.dectest10)-#if __GLASGOW_HASKELL__ >= 709 $(S.dectest11)-#endif $(S.dectest12) $(S.dectest13) $(S.dectest14) -#if __GLASGOW_HASKELL__ >= 710 $(S.dectest15)-#endif -#if __GLASGOW_HASKELL__ < 800 || __GLASGOW_HASKELL__ >= 802-$(S.dectest16)-#endif #if __GLASGOW_HASKELL__ >= 802+$(S.dectest16) $(S.dectest17) #endif 

@@ -8,20 +8,13 @@              MultiParamTypeClasses, FunctionalDependencies,              FlexibleInstances, DataKinds, CPP, RankNTypes,              StandaloneDeriving, DefaultSignatures,-             ConstraintKinds, RoleAnnotations #-}-#if __GLASGOW_HASKELL__ >= 710-{-# LANGUAGE DeriveAnyClass #-}-#endif+             ConstraintKinds, RoleAnnotations, DeriveAnyClass #-} #if __GLASGOW_HASKELL__ >= 801 {-# LANGUAGE DerivingStrategies #-} #endif -{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-incomplete-patterns-                -fno-warn-name-shadowing #-}--#if __GLASGOW_HASKELL__ >= 711-{-# OPTIONS_GHC -Wno-redundant-constraints #-}-#endif+{-# OPTIONS_GHC -Wno-orphans -Wno-incomplete-patterns+                -Wno-name-shadowing -Wno-redundant-constraints #-}  module DsDec where @@ -52,10 +45,8 @@  $(dsDecSplice S.dectest10) -#if __GLASGOW_HASKELL__ >= 709 $(dsDecSplice S.dectest11) $(dsDecSplice S.standalone_deriving_test)-#endif  #if __GLASGOW_HASKELL__ >= 801 $(dsDecSplice S.deriv_strat_test)@@ -65,14 +56,10 @@ $(dsDecSplice S.dectest13) $(dsDecSplice S.dectest14) -#if __GLASGOW_HASKELL__ >= 710 $(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_dectest16]) $(return $ decsToTH [S.ds_dectest17]) #endif 

@@ -3,12 +3,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-}-#if __GLASGOW_HASKELL__ >= 800 {-# LANGUAGE TypeInType #-}-#endif-#if __GLASGOW_HASKELL__ >= 806-{-# LANGUAGE StarIsType #-}-#endif #if __GLASGOW_HASKELL__ >= 809 {-# LANGUAGE CUSKs #-} #endif@@ -16,57 +11,48 @@ -- the -XCUSKs language extension. module ReifyTypeCUSKs where -#if __GLASGOW_HASKELL__ >= 800 && __GLASGOW_HASKELL__ < 806-import Data.Kind (type (*))-#endif-#if __GLASGOW_HASKELL__ < 710-import Data.Traversable (traverse)-#endif+import Data.Kind (Type) import GHC.Exts (Constraint) import Language.Haskell.TH.Desugar-import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Syntax hiding (Type) import Splices (eqTH)  test_reify_type_cusks, test_reify_type_no_cusks :: [Bool] (test_reify_type_cusks, test_reify_type_no_cusks) =   $(do cusk_decls <--         [d| data A1 (a :: *)-             type A2 (a :: *) = (a :: *)+         [d| data A1 (a :: Type)+             type A2 (a :: Type) = (a :: Type)              type family A3 a              data family A4 a-             type family A5 (a :: *) :: * where+             type family A5 (a :: Type) :: Type where                A5 a = a-             class A6 (a :: *) where+             class A6 (a :: Type) where                type A7 a b -#if __GLASGOW_HASKELL__ >= 800-             data A8 (a :: k) :: k -> *-#endif+             data A8 (a :: k) :: k -> Type #if __GLASGOW_HASKELL__ >= 804-             data A9 (a :: j) :: forall k. k -> *+             data A9 (a :: j) :: forall k. k -> Type #endif #if __GLASGOW_HASKELL__ >= 809              data A10 (k :: Type) (a :: k)-             data A11 :: forall k -> k -> *+             data A11 :: forall k -> k -> Type #endif            |]         no_cusk_decls <-          [d| data B1 a-             type B2 (a :: *) = a-             type B3 a = (a :: *)-             type family B4 (a :: *) where+             type B2 (a :: Type) = a+             type B3 a = (a :: Type)+             type family B4 (a :: Type) where                B4 a = a-             type family B5 a :: * where+             type family B5 a :: Type where                B5 a = a              class B6 a where-               type B7 (a :: *) (b :: *) :: *+               type B7 (a :: Type) (b :: Type) :: Type -#if __GLASGOW_HASKELL__ >= 800-             data B8 :: k -> *-#endif+             data B8 :: k -> Type #if __GLASGOW_HASKELL__ >= 804-             data B9 :: forall j. j -> k -> *+             data B9 :: forall j. j -> k -> Type #endif            |] @@ -93,14 +79,12 @@            , (6, DArrowT `DAppT` typeKind `DAppT` DConT ''Constraint)            , (7, DArrowT `DAppT` typeKind `DAppT` type_to_type)            ]-#if __GLASGOW_HASKELL__ >= 800            ++            [ (8, let k = mkName "k" in                  DForallT (DForallInvis [DPlainTV k SpecifiedSpec]) $                  DArrowT `DAppT` DVarT k `DAppT`                    (DArrowT `DAppT` DVarT k `DAppT` typeKind))            ]-#endif #if __GLASGOW_HASKELL__ >= 804            ++            [ (9, let j = mkName "j"@@ -127,9 +111,7 @@          traverse (test_reify_kind "B") $            map (, Nothing) $                 [1..7]-#if __GLASGOW_HASKELL__ >= 800              ++ [8]-#endif #if __GLASGOW_HASKELL__ >= 804              ++ [9] #endif

@@ -11,9 +11,6 @@ import Data.Kind import Data.Proxy #endif-#if __GLASGOW_HASKELL__ < 710-import Data.Traversable (traverse)-#endif import Language.Haskell.TH.Desugar import Language.Haskell.TH.Syntax hiding (Type) import Splices (eqTH)

@@ -9,18 +9,13 @@              DataKinds, ConstraintKinds, PolyKinds, MultiParamTypeClasses,              FlexibleInstances, ExistentialQuantification,              ScopedTypeVariables, GADTs, ViewPatterns, TupleSections,-             TypeOperators #-}-{-# 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-            -fno-warn-missing-fields -fno-warn-incomplete-record-updates #-}--#if __GLASGOW_HASKELL__ >= 711-{-# LANGUAGE PartialTypeSignatures #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE TypeApplications #-}-{-# OPTIONS_GHC -Wno-partial-type-signatures -Wno-redundant-constraints #-}-#endif+             TypeOperators, PartialTypeSignatures, PatternSynonyms,+             TypeApplications #-}+{-# OPTIONS -Wno-incomplete-patterns -Wno-overlapping-patterns+            -Wno-unused-matches -Wno-type-defaults+            -Wno-missing-signatures -Wno-unused-do-bind+            -Wno-missing-fields -Wno-incomplete-record-updates+            -Wno-partial-type-signatures -Wno-redundant-constraints #-}  #if __GLASGOW_HASKELL__ >= 805 {-# LANGUAGE DerivingVia #-}@@ -45,16 +40,15 @@ import Dec ( RecordSel ) import ReifyTypeCUSKs import ReifyTypeSigs+import T159Decs ( t159A, t159B ) import Language.Haskell.TH.Desugar import qualified Language.Haskell.TH.Desugar.OSet as OS import Language.Haskell.TH.Desugar.Expand  ( expandUnsoundly ) import Language.Haskell.TH import qualified Language.Haskell.TH.Syntax as Syn ( lift ) +import Control.Exception ( ErrorCall ) import Control.Monad-#if __GLASGOW_HASKELL__ < 709-import Control.Applicative-#endif  import qualified Data.Map as M import Data.Proxy@@ -118,14 +112,10 @@              , "tylit"    ~: $test32_tylit    @=? $(dsSplice test32_tylit)              , "tvbs"     ~: $test33_tvbs     @=? $(dsSplice test33_tvbs)              , "let_as"   ~: $test34_let_as   @=? $(dsSplice test34_let_as)-#if __GLASGOW_HASKELL__ >= 709              , "pred"     ~: $test37_pred     @=? $(dsSplice test37_pred)              , "pred2"    ~: $test38_pred2    @=? $(dsSplice test38_pred2)              , "eq"       ~: $test39_eq       @=? $(dsSplice test39_eq)-#endif-#if __GLASGOW_HASKELL__ >= 711              , "wildcard" ~: $test40_wildcards@=? $(dsSplice test40_wildcards)-#endif #if __GLASGOW_HASKELL__ >= 801              , "typeapps"   ~: $test41_typeapps   @=? $(dsSplice test41_typeapps)              , "scoped_tvs" ~: $test42_scoped_tvs @=? $(dsSplice test42_scoped_tvs)@@ -157,6 +147,10 @@ #if __GLASGOW_HASKELL__ >= 902              , "overloaded_record_dot" ~: $test54_overloaded_record_dot @=? $(dsSplice test54_overloaded_record_dot) #endif+#if __GLASGOW_HASKELL__ >= 903+             , "opaque_pragma" ~: $test55_opaque_pragma @=? $(dsSplice test55_opaque_pragma)+             , "lambda_cases" ~: $test56_lambda_cases @=? $(dsSplice test56_lambda_cases)+#endif              ]  test35a = $test35_expand@@ -180,10 +174,10 @@   -- closed type families. #endif test_e8b = $(test_expand8 >>= dsExp >>= expandUnsoundly >>= return . expToTH)-#if __GLASGOW_HASKELL__ >= 709 test_e9a = $test_expand9  -- requires GHC #9262 test_e9b = $(test_expand9 >>= dsExp >>= expand >>= return . expToTH)-#endif+test_e10a = $test_expand10+test_e10b = $(test_expand10 >>= dsExp >>= expand >>= return . expToTH)  hasSameType :: a -> a -> Bool hasSameType _ _ = True@@ -201,9 +195,8 @@                   , hasSameType test_e8a test_e8a #endif                   , hasSameType test_e8b test_e8b-#if __GLASGOW_HASKELL__ >= 709                   , hasSameType test_e9a test_e9b-#endif+                  , hasSameType test_e10a test_e10b                   ]  test_dec :: [Bool]@@ -229,11 +222,7 @@                     let isTypeKind (DConT n) = isTypeKindName n                         isTypeKind _         = False                     case (isTypeKind resK, lhs) of-#if __GLASGOW_HASKELL__ < 709-                      (True, _ `DAppT` DVarT _) -> [| True |]-#else                       (True, _ `DAppT` DSigT (DVarT _) (DVarT _)) -> [| True |]-#endif                       _                                     -> do                         runIO $ do                           putStrLn "Failed bug8884 test:"@@ -253,11 +242,7 @@                          return $ ListE bools)  test_standalone_deriving :: Bool-#if __GLASGOW_HASKELL__ >= 709 test_standalone_deriving = (MkBlarggie 5 'x') == (MkBlarggie 5 'x')-#else-test_standalone_deriving = True-#endif  test_deriving_strategies :: Bool #if __GLASGOW_HASKELL__ >= 801@@ -335,7 +320,6 @@  test_getDataD_kind_sig :: Bool test_getDataD_kind_sig =-#if __GLASGOW_HASKELL__ >= 800   3 == $(do data_name <- newName "TestData"             a         <- newName "a"             let type_kind     = DConT typeKindName@@ -346,13 +330,9 @@                                             (Just data_kind_sig) [] [])]                            (getDataD "th-desugar: Impossible" data_name)             [| $(Syn.lift (length tvbs)) |])-#else-  True -- DataD didn't have the ability to store kind signatures prior to GHC 8.0-#endif  test_t100 :: Bool test_t100 =-#if __GLASGOW_HASKELL__ >= 800   $(do decs <- [d| data T b where                      MkT :: forall a. { unT :: a } -> T a |]        info <- withLocalDeclarations decs (dsReify (mkName "unT"))@@ -363,13 +343,6 @@        case info of          Just (DVarI _ actual_ty _) -> exp_ty `eqTHSplice` actual_ty          _                          -> [| False |])-#else-  True -- RecGadtC didn't exist prior to GHC 8.0, so the quote above will-       -- normalize to `data T b = MkT { unT :: b }`. This defeats the point of-       -- this test, and to make things worse, this will cause `dsReify` to-       -- return a different type for unT (forall b. T b -> b). Let's just not-       -- bother testing this on pre-8.0 GHCs.-#endif  test_t102 :: [Bool] test_t102 =@@ -389,7 +362,6 @@  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@@ -400,9 +372,6 @@            -> [| True |]            |  otherwise            -> [| False |])-#else-  True -- No explicit kind variable binders prior to GHC 8.0-#endif  test_t112 :: [Bool] test_t112 =@@ -447,7 +416,6 @@  test_t154 :: Bool test_t154 =-#if __GLASGOW_HASKELL__ >= 800   $(do decs  <- [d| data T where                      (:$$:) :: Int -> Int -> T                   |]@@ -457,12 +425,17 @@                              -> Just is_infix                            _ -> Nothing        mb_is_infix `eqTHSplice` Just False)-#else-  True -- GadtC didn't exist prior to GHC 8.0, so the quote above will-       -- normalize to `data T = (:$$:) Int Int`. This defeats the point of-       -- this test, so let's just not bother testing this on pre-8.0 GHCs.-#endif +-- Regression test for #159 which ensures that non-exhaustive functions throw+-- a runtime error before forcing their arguments.+test_t159 :: Expectation+test_t159 = do+  -- NB: Catch ErrorCall here, not PatternMatchFail. This is because we desugar+  -- non-exhaustive patterns into a custom `error` expression.+  let testOne f = f (let x = x in x) `shouldThrow` \(_ :: ErrorCall) -> True+  testOne t159A+  testOne t159B+ -- Unit tests for functions that compute free variables (e.g., fvDType) test_fvs :: [Bool] test_fvs =@@ -671,6 +644,8 @@       test_fvs [1..]      it "desugars non-infix GADT constructors with symbolic names correctly" $ test_t154++    it "desugars non-exhaustive expressions into code that errors at runtime" $ test_t159      -- Remove map pprints here after switch to th-orphans     zipWithM (\t t' -> it ("can do Type->DType->Type of " ++ t) $ t == t')

@@ -10,11 +10,8 @@              DataKinds, PolyKinds, GADTs, MultiParamTypeClasses,              FunctionalDependencies, FlexibleInstances, StandaloneDeriving,              DefaultSignatures, ConstraintKinds, GADTs, ViewPatterns,-             TupleSections, NoMonomorphismRestriction, TypeOperators #-}--#if __GLASGOW_HASKELL__ >= 711-{-# LANGUAGE TypeApplications #-}-#endif+             TupleSections, NoMonomorphismRestriction, TypeOperators,+             TypeApplications #-}  #if __GLASGOW_HASKELL__ >= 801 {-# LANGUAGE DerivingStrategies #-}@@ -48,13 +45,14 @@ {-# LANGUAGE OverloadedRecordDot #-} #endif -{-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-type-defaults-                -fno-warn-name-shadowing #-}+{-# OPTIONS_GHC -Wno-missing-signatures -Wno-type-defaults+                -Wno-name-shadowing #-}  module Splices where  import qualified Data.List as L import Data.Char+import qualified Data.Kind as Kind (Type) import GHC.Exts import GHC.TypeLits @@ -84,21 +82,14 @@   infoReg <- reify regName   rolesDs  <- reifyRoles dsName   rolesReg <- reifyRoles regName-#if __GLASGOW_HASKELL__ < 711-  eqTHSplice (infoDs, rolesDs) (infoReg, rolesReg)-#else   fixityDs  <- reifyFixity dsName   fixityReg <- reifyFixity regName   eqTHSplice (infoDs, rolesDs, fixityDs) (infoReg, rolesReg, fixityReg)-#endif  unqualify :: Data a => a -> a unqualify = everywhere (mkT (mkName . nameBase))  assumeStarT :: Data a => a -> a-#if __GLASGOW_HASKELL__ < 709-assumeStarT = id-#else assumeStarT = everywhere (mkT assume_spec . mkT assume_unit)   where     assume_spec :: TyVarBndrSpec -> TyVarBndrSpec@@ -112,7 +103,6 @@     assume_unit :: TyVarBndrUnit -> TyVarBndrUnit     assume_unit = elimTV (\n   -> kindedTV n StarT)                          (\n k -> kindedTV n (assumeStarT k))-#endif  dropTrailing0s :: Data a => a -> a dropTrailing0s = everywhere (mkT (mkName . frob . nameBase))@@ -213,13 +203,13 @@ test30_promoted = [| let f :: Proxy '() -> Proxy '[Int, Bool] -> ()                          f _ _ = () in                      f Proxy Proxy |]-test31_constraint = [| let f :: Proxy (c :: * -> Constraint) -> ()+test31_constraint = [| let f :: Proxy (c :: Kind.Type -> Constraint) -> ()                            f _ = () in                        [f (Proxy :: Proxy Eq), f (Proxy :: Proxy Show)] |] test32_tylit = [| let f :: Proxy (a :: Symbol) -> Proxy (b :: Nat) -> ()                       f _ _ = () in                   f (Proxy :: Proxy "Hi there!") (Proxy :: Proxy 10) |]-test33_tvbs = [| let f :: forall a (b :: * -> *). Monad b => a -> b a+test33_tvbs = [| let f :: forall a (b :: Kind.Type -> Kind.Type). Monad b => a -> b a                      f = return in                  [f 1, f 2] :: [Maybe Int] |] @@ -236,11 +226,9 @@                        f = snd in                    f |] -#if __GLASGOW_HASKELL__ >= 711 test40_wildcards = [| let f :: (Show a, _) => a -> a -> _                           f x y = if x == y then show x else "bad" in                       f True False :: String |]-#endif  #if __GLASGOW_HASKELL__ >= 801 test41_typeapps = [| let f :: forall a. (a -> Bool) -> Bool@@ -351,6 +339,18 @@      in (ord2.unORD2.unORD1, (.unORD2.unORD1) ord2) |] #endif +#if __GLASGOW_HASKELL__ >= 903+test55_opaque_pragma =+  [| let f :: String -> String+         f x = x+         {-# OPAQUE f #-}+     in f "Hello, World!" |]++test56_lambda_cases =+  [| (\cases (Just x) (Just y) -> x ++ y+             _        _        -> "") (Just "Hello") (Just "World") |]+#endif+ type family TFExpand x type instance TFExpand Int = Bool type instance TFExpand (Maybe a) = [a]@@ -373,10 +373,10 @@                   f |]  #if __GLASGOW_HASKELL__ >= 809-type PolyTF :: forall k. k -> *+type PolyTF :: forall k. k -> Kind.Type #endif-type family PolyTF (x :: k) :: * where-  PolyTF (x :: *) = Bool+type family PolyTF (x :: k) :: Kind.Type where+  PolyTF (x :: Kind.Type) = Bool  test_expand7 = [| let f :: PolyTF Int -> ()                       f True = () in@@ -386,13 +386,17 @@                   f |]  -#if __GLASGOW_HASKELL__ >= 709 test_expand9 = [| let f :: TFExpand (Maybe (IO a)) -> IO ()                       f actions = sequence_ actions in                   f |]-#endif -#if __GLASGOW_HASKELL__ >= 709+type family TFExpandClosed a where+  TFExpandClosed (Maybe a) = [a]++test_expand10 = [| let f :: TFExpandClosed (Maybe (IO a)) -> IO ()+                       f actions = sequence_ actions in+                   f |]+ test37_pred = [| let f :: (Read a, (Show a, Num a)) => a -> a                      f x = read (show x) + x in                  (f 3, f 4.5) |]@@ -404,13 +408,8 @@ test39_eq = [| let f :: (a ~ b) => a -> b                    f x = x in                (f ()) |]-#endif -#if __GLASGOW_HASKELL__ < 709-dec_test_nums = [1..10] :: [Int]-#else dec_test_nums = [1..11] :: [Int]-#endif  dectest1 = [d| data Dec1 where                  Foo :: Dec1@@ -424,25 +423,23 @@ dectest4 = [d| newtype Dec4 a where                  MkDec4 :: (a, Int) -> Dec4 a |] dectest5 = [d| type Dec5 a b = (a b, Maybe b) |]-dectest6 = [d| class (Monad m1, Monad m2) => Dec6 (m1 :: * -> *) m2 | m1 -> m2  where+dectest6 = [d| class (Monad m1, Monad m2) => Dec6 (m1 :: Kind.Type -> Kind.Type) m2 | m1 -> m2  where                  lift :: forall a. m1 a -> m2 a-                 type M2 m1 :: * -> * |]-dectest7 = [d| type family Dec7 a (b :: *) (c :: Bool) :: * -> * |]+                 type M2 m1 :: Kind.Type -> Kind.Type |]+dectest7 = [d| type family Dec7 a (b :: Kind.Type) (c :: Bool) :: Kind.Type -> Kind.Type |] dectest8 = [d| type family Dec8 a |]-dectest9 = [d| data family Dec9 a (b :: * -> *) :: * -> * |]-dectest10 = [d| type family Dec10 a :: * -> * where+dectest9 = [d| data family Dec9 a (b :: Kind.Type -> Kind.Type) :: Kind.Type -> Kind.Type |]+dectest10 = [d| type family Dec10 a :: Kind.Type -> Kind.Type where                   Dec10 Int = Maybe                   Dec10 Bool = [] |]  data Blarggie a = MkBlarggie Int a-#if __GLASGOW_HASKELL__ >= 709 dectest11 = [d| class Dec11 a where                   meth13 :: a -> a -> Bool                   default meth13 :: Eq a => a -> a -> Bool                   meth13 = (==)               |] standalone_deriving_test = [d| deriving instance Eq a => Eq (Blarggie a) |]-#endif #if __GLASGOW_HASKELL__ >= 801 deriv_strat_test = [d| deriving stock instance Ord a => Ord (Blarggie a) |] #endif@@ -453,7 +450,7 @@                |] -dectest13 = [d| data Dec13 :: (* -> Constraint) -> * where+dectest13 = [d| data Dec13 :: (Kind.Type -> Constraint) -> Kind.Type where                   MkDec13 :: c a => a -> Dec13 c               |] @@ -484,15 +481,12 @@                   (DConT ''ExData1 `DAppT` DVarT (mkName "a"))) [] dectest16 :: Q [Dec] dectest16 = return [ InstanceD-#if __GLASGOW_HASKELL__ >= 800                        Nothing-#endif                        [] (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@@ -500,10 +494,9 @@ #endif                        [] (ConT ''ExCls `AppT`                             (ConT ''ExData2 `AppT` VarT (mkName "a"))) ]-#endif  #if __GLASGOW_HASKELL__ >= 809-dectest18 = [d| data Dec18 :: forall k -> k -> * where+dectest18 = [d| data Dec18 :: forall k -> k -> Kind.Type where                   MkDec18 :: forall k (a :: k). Dec18 k a |] #endif @@ -516,26 +509,18 @@                        lift (Just x) = Right x                        type M2 Maybe = Either () |] -data family Dec9 a (b :: * -> *) :: * -> *-#if __GLASGOW_HASKELL__ >= 800+data family Dec9 a (b :: Kind.Type -> Kind.Type) :: Kind.Type -> Kind.Type imp_inst_test2 = [d| data instance Dec9 Int Maybe a where                        MkIMB  ::             [a] -> Dec9 Int Maybe a                        MkIMB2 :: forall a b. b a -> Dec9 Int Maybe a |] imp_inst_test3 = [d| newtype instance Dec9 Bool m x where                        MkBMX :: m x -> Dec9 Bool m x |]-#else--- TH-quoted data family instances with GADT syntax are horribly broken on GHC 7.10--- and older, so we opt to use non-GADT syntax on older GHCs so we can at least--- test *something*.-imp_inst_test2 = [d| data instance Dec9 Int Maybe a = MkIMB [a] | forall b. MkIMB2 (b a) |]-imp_inst_test3 = [d| newtype instance Dec9 Bool m x = MkBMX (m x) |]-#endif  type family Dec8 a imp_inst_test4 = [d| type instance Dec8 Int = Bool |]  -- used for bug8884 test-type family Poly (a :: k) :: *+type family Poly (a :: k) :: Kind.Type type instance Poly x = Int  flatten_dvald_test = [| let (a,b,c) = ("foo", 4, False) in@@ -551,13 +536,8 @@  testRecSelTypes :: Int -> Q Exp testRecSelTypes n = do-#if __GLASGOW_HASKELL__ > 710   VarI _ ty1 _ <- reify (mkName ("DsDec.recsel" ++ show n))   VarI _ ty2 _ <- reify (mkName ("Dec.recsel"   ++ show n))-#else-  VarI _ ty1 _ _ <- reify (mkName ("DsDec.recsel" ++ show n))-  VarI _ ty2 _ _ <- reify (mkName ("Dec.recsel"   ++ show n))-#endif   let ty1' = return $ unqualify ty1       ty2' = return $ unqualify ty2   [| let x :: $ty1'@@ -582,13 +562,11 @@    class R2 a b where     r3 :: a -> b -> c -> a-    type R4 b a :: *-#if __GLASGOW_HASKELL__ >= 800+    type R4 b a :: Kind.Type     -- Only define this on GHC 8.0 or later, since TH had trouble quoting     -- associated type family defaults before then.     type R4 b a = Either a b-#endif-    data R5 a :: *+    data R5 a :: Kind.Type    data R6 a = R7 { r8 :: a -> a, r9 :: Bool } @@ -597,9 +575,9 @@     type R4 a (R6 a) = a     data R5 (R6 a) = forall b. Show b => R10 { r11 :: a, naughty :: b } -  type family R12 a b :: *+  type family R12 a b :: Kind.Type -  data family R13 a :: *+  data family R13 a :: Kind.Type    data instance R13 Int = R14 { r15 :: Bool } @@ -669,19 +647,17 @@     deriving Eq via (Id [a]) #endif -#if __GLASGOW_HASKELL__ >= 800-  class R25 (f :: k -> *) where+  class R25 (f :: k -> Kind.Type) where     r26 :: forall (a :: k). f a    data R27 (a :: k) = R28 { r29 :: Proxy a }-#endif    class R30 a where     r31 :: a -> b -> a  #if __GLASGOW_HASKELL__ >= 809-  type R32 :: forall k -> k -> *-  type family R32 :: forall k -> k -> * where+  type R32 :: forall k -> k -> Kind.Type+  type family R32 :: forall k -> k -> Kind.Type where #endif    data R33 a where@@ -691,16 +667,11 @@ reifyDecsNames :: [Name] reifyDecsNames = map mkName   [ "r1"-#if __GLASGOW_HASKELL__ < 711-  , "R2", "r3"      -- these fail due to GHC#11797-#endif   , "R4", "R5", "R6", "R7", "r8", "r9", "R10", "r11"   , "R12", "R13", "R14", "r15", "r16", "r17", "R18", "R19", "R20"   , "R21"   , "r22"-#if __GLASGOW_HASKELL__ >= 800   , "R25", "r26", "R28", "r29"-#endif   , "R30", "r31" #if __GLASGOW_HASKELL__ >= 809   , "R32"@@ -767,11 +738,9 @@              , test32_tylit              , test33_tvbs              , test34_let_as-#if __GLASGOW_HASKELL__ >= 709              , test37_pred              , test38_pred2              , test39_eq-#endif #if __GLASGOW_HASKELL__ >= 801              , test41_typeapps              , test42_scoped_tvs@@ -801,5 +770,9 @@ #endif #if __GLASGOW_HASKELL__ >= 902              , test54_overloaded_record_dot+#endif+#if __GLASGOW_HASKELL__ >= 903+             , test55_opaque_pragma+             , test56_lambda_cases #endif              ]

@@ -0,0 +1,14 @@+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE TemplateHaskell #-}++-- | A regression test for #158 which ensures that lambda expressions+-- containing patterns with unlifted types desugar as expected. We define this+-- test in its own module, without UnboxedTuples enabled, to ensure that users+-- do not have to enable the extension themselves.+module T158Exp where++import Language.Haskell.TH.Desugar++t158 :: ()+t158 =+  $([| (\27# 42# -> ()) 27# 42# |] >>= dsExp >>= return . expToTH)

@@ -0,0 +1,20 @@+{-# OPTIONS_GHC -Wno-incomplete-patterns #-}+{-# OPTIONS_GHC -Wno-unused-matches #-}++-- | Defines two non-exhaustive functions that roundtrip through desugaring+-- and sweetening. Both of these functions should desugar to definitions that+-- throw a runtime exception before forcing their argument.+--+-- Because these functions are non-exhaustive (and therefore emit warnings), we+-- put them in their own module so that we can disable the appropriate warnings+-- without needing to disable the warnings globally.+module T159Decs+  ( t159A, t159B+  ) where++import Splices ( dsDecSplice )++$(dsDecSplice [d| t159A, t159B :: () -> IO ()+                  t159A x | False = return ()+                  t159B x = case x of y | False -> return ()+                |])

@@ -1,5 +1,5 @@ name:           th-desugar-version:        1.13.1+version:        1.14 cabal-version:  >= 1.10 synopsis:       Functions to desugar Template Haskell homepage:       https://github.com/goldfirere/th-desugar@@ -12,9 +12,7 @@ license:        BSD3 license-file:   LICENSE build-type:     Simple-tested-with:    GHC == 7.8.4-              , GHC == 7.10.3-              , GHC == 8.0.2+tested-with:    GHC == 8.0.2               , GHC == 8.2.2               , GHC == 8.4.4               , GHC == 8.6.5@@ -45,9 +43,9 @@  library   build-depends:-      base >= 4.7 && < 5,+      base >= 4.9 && < 5,       ghc-prim,-      template-haskell >= 2.9 && < 2.19,+      template-haskell >= 2.11 && < 2.20,       containers >= 0.5,       mtl >= 2.1 && < 2.4,       ordered-containers >= 0.2.2,@@ -56,9 +54,6 @@       th-lift >= 0.6.1,       th-orphans >= 0.13.7,       transformers-compat >= 0.6.3-  if !impl(ghc >= 8.0)-      build-depends: fail == 4.9.*,-                     semigroups >= 0.16   default-extensions: TemplateHaskell   exposed-modules:    Language.Haskell.TH.Desugar                       Language.Haskell.TH.Desugar.Expand@@ -81,8 +76,6 @@ test-suite spec   type:               exitcode-stdio-1.0   ghc-options:        -Wall-  if impl(ghc >= 8.6)-    ghc-options:      -Wno-star-is-type   default-language:   Haskell2010   default-extensions: TemplateHaskell   hs-source-dirs:     Test@@ -92,6 +85,8 @@                       ReifyTypeCUSKs                       ReifyTypeSigs                       Splices+                      T158Exp+                      T159Decs    build-depends:       base >= 4 && < 5,