th-desugar 1.6 → 1.7

raw patch · 14 files changed

+606/−155 lines, 14 filesdep ~template-haskellPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: template-haskell

API changes (from Hackage documentation)

Files

• CHANGES.md +16/−0
• Language/Haskell/TH/Desugar.hs +113/−32
• Language/Haskell/TH/Desugar/Core.hs +124/−23
• Language/Haskell/TH/Desugar/Expand.hs +6/−3
• Language/Haskell/TH/Desugar/Lift.hs +6/−3
• Language/Haskell/TH/Desugar/Match.hs +35/−13
• Language/Haskell/TH/Desugar/Reify.hs +21/−5
• Language/Haskell/TH/Desugar/Sweeten.hs +72/−26
• Language/Haskell/TH/Desugar/Util.hs +55/−27
• Test/Dec.hs +1/−1
• Test/DsDec.hs +11/−3
• Test/Run.hs +36/−7
• Test/Splices.hs +104/−6
• th-desugar.cabal +6/−6

@@ -1,6 +1,22 @@ `th-desugar` release notes ========================== +Version 1.7+-----------+* Support for TH's support for `TypeApplications`, thanks to @RyanGlScott.++* Support for unboxed sums, thanks to @RyanGlScott.++* Support for `COMPLETE` pragmas.++* `getRecordSelectors` now requires a list of `DCon`s as an argument. This+  makes it easier to return correct record selector bindings in the event that+  a record selector appears in multiple constructors. (See+  [goldfirere/singletons#180](https://github.com/goldfirere/singletons/issues/180)+  for an example of where the old behavior of `getRecordSelectors` went wrong.)++* Better type family expansion (expanding an open type family with variables works now).+ Version 1.6 ----------- * Work with GHC 8, with thanks to @christiaanb for getting this change going.

@@ -1,18 +1,18 @@ {- Language/Haskell/TH/Desugar.hs  (c) Richard Eisenberg 2013-eir@cis.upenn.edu+rae@cs.brynmawr.edu -}  {-# LANGUAGE CPP, MultiParamTypeClasses, FunctionalDependencies,-             TypeSynonymInstances, FlexibleInstances #-}+             TypeSynonymInstances, FlexibleInstances, LambdaCase #-}  ----------------------------------------------------------------------------- -- | -- Module      :  Language.Haskell.TH.Desugar -- Copyright   :  (C) 2014 Richard Eisenberg -- License     :  BSD-style (see LICENSE)--- Maintainer  :  Richard Eisenberg (eir@cis.upenn.edu)+-- Maintainer  :  Richard Eisenberg (rae@cs.brynmawr.edu) -- Stability   :  experimental -- Portability :  non-portable --@@ -25,7 +25,8 @@   -- * Desugared data types   DExp(..), DLetDec(..), DPat(..), DType(..), DKind, DCxt, DPred(..),   DTyVarBndr(..), DMatch(..), DClause(..), DDec(..),-  Overlap(..), NewOrData(..),+  DDerivClause(..), DerivStrategy(..), DPatSynDir(..), DPatSynType,+  Overlap(..), PatSynArgs(..), NewOrData(..),   DTypeFamilyHead(..), DFamilyResultSig(..), InjectivityAnn(..),   DCon(..), DConFields(..), DBangType, DVarBangType,   Bang(..), SourceUnpackedness(..), SourceStrictness(..),@@ -43,12 +44,15 @@   dsCon, dsForeign, dsPragma, dsRuleBndr,    -- ** Secondary desugaring functions-  PatM, dsPred, dsPat, dsDec, dsLetDec,+  PatM, dsPred, dsPat, dsDec, dsDerivClause, dsLetDec,   dsMatches, dsBody, dsGuards, dsDoStmts, dsComp, dsClauses,   dsBangType, dsVarBangType, #if __GLASGOW_HASKELL__ > 710   dsTypeFamilyHead, dsFamilyResultSig, #endif+#if __GLASGOW_HASKELL__ >= 801+  dsPatSynDir,+#endif    -- * Converting desugared AST back to TH AST   module Language.Haskell.TH.Desugar.Sweeten,@@ -76,6 +80,7 @@   mkTupleDExp, mkTupleDPat, maybeDLetE, maybeDCaseE,   substTy,   tupleDegree_maybe, tupleNameDegree_maybe,+  unboxedSumDegree_maybe, unboxedSumNameDegree_maybe,   unboxedTupleDegree_maybe, unboxedTupleNameDegree_maybe,   strictToBang, @@ -91,6 +96,7 @@ import Language.Haskell.TH.Desugar.Expand import Language.Haskell.TH.Desugar.Match +import qualified Data.Map as M import qualified Data.Set as S #if __GLASGOW_HASKELL__ < 709 import Data.Foldable ( foldMap )@@ -160,18 +166,11 @@         DConPa con ps -> DConPa con (map (wildify name y) ps)         DTildePa pa -> DTildePa (wildify name y pa)         DBangPa pa -> DBangPa (wildify name y pa)+        DSigPa pa ty -> DSigPa (wildify name y pa) ty         DWildPa -> DWildPa  flattenDValD other_dec = return [other_dec] -extractBoundNamesDPat :: DPat -> S.Set Name-extractBoundNamesDPat (DLitPa _)      = S.empty-extractBoundNamesDPat (DVarPa n)      = S.singleton n-extractBoundNamesDPat (DConPa _ pats) = foldMap extractBoundNamesDPat pats-extractBoundNamesDPat (DTildePa pat)  = extractBoundNamesDPat pat-extractBoundNamesDPat (DBangPa pat)   = extractBoundNamesDPat pat-extractBoundNamesDPat DWildPa         = S.empty- fvDType :: DType -> S.Set Name fvDType = go   where@@ -190,30 +189,112 @@ dtvbName (DKindedTV n _) = S.singleton n  -- | Produces 'DLetDec's representing the record selector functions from--- the provided 'DCon'.+-- the provided 'DCon's.+--+-- Note that if the same record selector appears in multiple constructors,+-- 'getRecordSelectors' will return only one binding for that selector.+-- For example, if you had:+--+-- @+-- data X = X1 {y :: Symbol} | X2 {y :: Symbol}+-- @+--+-- Then calling 'getRecordSelectors' on @[X1, X2]@ will return:+--+-- @+-- [ DSigD y (DAppT (DAppT DArrowT (DConT X)) (DConT Symbol))+-- , DFunD y [ DClause [DConPa X1 [DVarPa field]] (DVarE field)+--           , DClause [DConPa X2 [DVarPa field]] (DVarE field) ] ]+-- @+--+-- instead of returning one binding for @X1@ and another binding for @X2@.++-- See https://github.com/goldfirere/singletons/issues/180 for an example where+-- the latter behavior can bite you. getRecordSelectors :: Quasi q                    => DType        -- ^ the type of the argument-                   -> DCon+                   -> [DCon]                    -> q [DLetDec]-getRecordSelectors arg_ty (DCon _ _ con_name con _) = case con of-    DRecC fields -> go fields-    _ -> return []+getRecordSelectors arg_ty cons = merge_let_decs `fmap` concatMapM get_record_sels cons   where-    go fields = do-      varName <- qNewName "field"-      let tvbs = fvDType arg_ty-          maybe_forall-            | S.null tvbs = id-            | otherwise   = DForallT (map DPlainTV $ S.toList tvbs) []-          num_pats = length fields-      return $ concat-        [ [ DSigD name (maybe_forall $ DArrowT `DAppT` arg_ty `DAppT` res_ty)-          , DFunD name [DClause [DConPa con_name (mk_field_pats n num_pats varName)]-                                (DVarE varName)] ]-        | ((name, _strict, res_ty), n) <- zip fields [0..]-        , fvDType res_ty `S.isSubsetOf` tvbs   -- exclude "naughty" selectors-        ]+    get_record_sels (DCon _ _ con_name con _) = case con of+      DRecC fields -> go fields+      _ -> return []+      where+        go fields = do+          varName <- qNewName "field"+          let tvbs     = fvDType arg_ty+              forall'  = DForallT (map DPlainTV $ S.toList tvbs) []+              num_pats = length fields+          return $ concat+            [ [ DSigD name (forall' $ DArrowT `DAppT` arg_ty `DAppT` res_ty)+              , DFunD name [DClause [DConPa con_name (mk_field_pats n num_pats varName)]+                                    (DVarE varName)] ]+            | ((name, _strict, res_ty), n) <- zip fields [0..]+            , fvDType res_ty `S.isSubsetOf` tvbs   -- exclude "naughty" selectors+            ]      mk_field_pats :: Int -> Int -> Name -> [DPat]     mk_field_pats 0 total name = DVarPa name : (replicate (total-1) DWildPa)     mk_field_pats n total name = DWildPa : mk_field_pats (n-1) (total-1) name++    merge_let_decs :: [DLetDec] -> [DLetDec]+    merge_let_decs decs =+      let (name_clause_map, decs') = gather_decs M.empty S.empty decs+       in augment_clauses name_clause_map decs'+        -- First, for each record selector-related declarations, do the following:+        --+        -- 1. If it's a DFunD...+        --   a. If we haven't encountered it before, add a mapping from its Name+        --      to its associated DClauses, and continue.+        --   b. If we have encountered it before, augment the existing Name's+        --      mapping with the new clauses. Then remove the DFunD from the list+        --      and continue.+        -- 2. If it's a DSigD...+        --   a. If we haven't encountered it before, remember its Name and continue.+        --   b. If we have encountered it before, remove the DSigD from the list+        --      and continue.+        -- 3. Otherwise, continue.+        --+        -- After this, scan over the resulting list once more with the mapping+        -- that we accumulated. For every DFunD, replace its DClauses with the+        -- ones corresponding to its Name in the mapping.+        --+        -- Note that this algorithm combines all of the DClauses for each unique+        -- Name, while preserving the order in which the DFunDs were originally+        -- found. Moreover, it removes duplicate DSigD entries. Using Maps and+        -- Sets avoid quadratic blowup for data types with many record selectors.+      where+        gather_decs :: M.Map Name [DClause] -> S.Set Name -> [DLetDec]+                    -> (M.Map Name [DClause], [DLetDec])+        gather_decs name_clause_map _ [] = (name_clause_map, [])+        gather_decs name_clause_map type_sig_names (x:xs)+          -- 1.+          | DFunD n clauses <- x+          = let name_clause_map' = M.insertWith (\new old -> old ++ new)+                                                n clauses name_clause_map+             in if n `M.member` name_clause_map+                then gather_decs name_clause_map' type_sig_names xs+                else let (map', decs') = gather_decs name_clause_map'+                                           type_sig_names xs+                      in (map', x:decs')++          -- 2.+          | DSigD n _ <- x+          = if n `S.member` type_sig_names+            then gather_decs name_clause_map type_sig_names xs+            else let (map', decs') = gather_decs name_clause_map+                                       (n `S.insert` type_sig_names) xs+                  in (map', x:decs')++          -- 3.+          | otherwise =+              let (map', decs') = gather_decs name_clause_map type_sig_names xs+               in (map', x:decs')++        augment_clauses :: M.Map Name [DClause] -> [DLetDec] -> [DLetDec]+        augment_clauses _ [] = []+        augment_clauses name_clause_map (x:xs)+          | DFunD n _ <- x, Just merged_clauses <- n `M.lookup` name_clause_map+          = DFunD n merged_clauses:augment_clauses name_clause_map xs+          | otherwise = x:augment_clauses name_clause_map xs

@@ -1,7 +1,7 @@ {- Language/Haskell/TH/Desugar/Core.hs  (c) Richard Eisenberg 2013-eir@cis.upenn.edu+rae@cs.brynmawr.edu  Desugars full Template Haskell syntax into a smaller core syntax for further processing. The desugared types and constructors are prefixed with a D.@@ -40,6 +40,7 @@           | DConE Name           | DLitE Lit           | DAppE DExp DExp+          | DAppTypeE DExp DType           | DLamE [Name] DExp           | DCaseE DExp [DMatch]           | DLetE [DLetDec] DExp@@ -54,6 +55,7 @@           | DConPa Name [DPat]           | DTildePa DPat           | DBangPa DPat+          | DSigPa DPat DType           | DWildPa           deriving (Show, Typeable, Data, Generic) @@ -102,6 +104,7 @@              | DValD DPat DExp              | DSigD Name DType              | DInfixD Fixity Name+             | DPragmaD DPragma              deriving (Show, Typeable, Data, Generic)  -- | Is it a @newtype@ or a @data@ type?@@ -111,20 +114,21 @@  -- | Corresponds to TH's @Dec@ type. data DDec = DLetDec DLetDec-          | DDataD NewOrData DCxt Name [DTyVarBndr] [DCon] [DPred]+          | DDataD NewOrData DCxt Name [DTyVarBndr] [DCon] [DDerivClause]           | DTySynD Name [DTyVarBndr] DType           | DClassD DCxt Name [DTyVarBndr] [FunDep] [DDec]           | DInstanceD (Maybe Overlap) DCxt DType [DDec]           | DForeignD DForeign-          | DPragmaD DPragma           | DOpenTypeFamilyD DTypeFamilyHead           | DClosedTypeFamilyD DTypeFamilyHead [DTySynEqn]           | DDataFamilyD Name [DTyVarBndr]-          | DDataInstD NewOrData DCxt Name [DType] [DCon] [DPred]+          | DDataInstD NewOrData DCxt Name [DType] [DCon] [DDerivClause]           | DTySynInstD Name DTySynEqn           | DRoleAnnotD Name [Role]-          | DStandaloneDerivD DCxt DType+          | DStandaloneDerivD (Maybe DerivStrategy) DCxt DType           | DDefaultSigD Name DType+          | DPatSynD Name PatSynArgs DPatSynDir DPat+          | DPatSynSigD Name DPatSynType           deriving (Show, Typeable, Data, Generic)  #if __GLASGOW_HASKELL__ < 711@@ -132,6 +136,24 @@   deriving (Eq, Ord, Show, Typeable, Data, Generic) #endif +-- | Corresponds to TH's 'PatSynDir' type+data DPatSynDir = DUnidir              -- ^ @pattern P x {<-} p@+                | DImplBidir           -- ^ @pattern P x {=} p@+                | DExplBidir [DClause] -- ^ @pattern P x {<-} p where P x = e@+                deriving (Show, Typeable, Data, Generic)++-- | Corresponds to TH's 'PatSynType' type+type DPatSynType = DType++#if __GLASGOW_HASKELL__ < 801+-- | Same as @PatSynArgs@ from TH; defined here for backwards compatibility.+data PatSynArgs+  = PrefixPatSyn [Name]        -- ^ @pattern P {x y z} = p@+  | InfixPatSyn Name Name      -- ^ @pattern {x P y} = p@+  | RecordPatSyn [Name]        -- ^ @pattern P { {x,y,z} } = p@+  deriving (Show, Typeable, Data, Generic)+#endif+ -- | Corresponds to TH's 'TypeFamilyHead' type data DTypeFamilyHead = DTypeFamilyHead Name [DTyVarBndr] DFamilyResultSig                                        (Maybe InjectivityAnn)@@ -195,6 +217,7 @@              | DRuleP String [DRuleBndr] DExp DExp Phases              | DAnnP AnnTarget DExp              | DLineP Int String+             | DCompleteP [Name] (Maybe Name)              deriving (Show, Typeable, Data, Generic)  -- | Corresponds to TH's @RuleBndr@ type.@@ -228,10 +251,23 @@            | DPrimTyConI Name Int Bool                -- ^ The @Int@ is the arity; the @Bool@ is whether this tycon                -- is unlifted.+           | DPatSynI Name DPatSynType            deriving (Show, Typeable, Data, Generic)  type DInstanceDec = DDec -- ^ Guaranteed to be an instance declaration +-- | Corresponds to TH's @DerivClause@ type.+data DDerivClause = DDerivClause (Maybe DerivStrategy) DCxt+                  deriving (Show, Typeable, Data, Generic)++#if __GLASGOW_HASKELL__ < 801+-- | Same as @DerivStrategy@ from TH; defined here for backwards compatibility.+data DerivStrategy = StockStrategy    -- ^ A \"standard\" derived instance+                   | AnyclassStrategy -- ^ @-XDeriveAnyClass@+                   | NewtypeStrategy  -- ^ @-XGeneralizedNewtypeDeriving@+                   deriving (Show, Typeable, Data, Generic)+#endif+ -- | Desugar an expression dsExp :: DsMonad q => Exp -> q DExp dsExp (VarE n) = return $ DVarE n@@ -365,6 +401,11 @@ #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) =+  DAppE (DConE $ unboxedSumDataName alt arity) <$> dsExp exp+#endif  -- | Desugar a lambda expression, where the body has already been desugared dsLam :: DsMonad q => [Pat] -> DExp -> q DExp@@ -581,10 +622,11 @@           h' <- dsPat h           t' <- go t           return $ DConPa '(:) [h', t']-dsPat (SigP _ _) =-  lift $ impossible-             ("At last check (Aug 2013), type patterns in signatures are not\n" ++-              "supported in GHC. They are not supported in th-desugar either.")+dsPat (SigP pat ty) = DSigPa <$> dsPat pat <*> dsType ty+#if __GLASGOW_HASKELL__ >= 801+dsPat (UnboxedSumP pat alt arity) =+  DConPa (unboxedSumDataName alt arity) <$> ((:[]) <$> dsPat pat)+#endif dsPat (ViewP _ _) =   fail "View patterns are not supported in th-desugar. Use pattern guards instead." @@ -595,6 +637,7 @@ dPatToDExp (DConPa name pats) = foldl DAppE (DConE name) (map dPatToDExp pats) dPatToDExp (DTildePa pat) = dPatToDExp pat dPatToDExp (DBangPa pat) = dPatToDExp pat+dPatToDExp (DSigPa pat ty) = DSigE (dPatToDExp pat) ty dPatToDExp DWildPa = error "Internal error in th-desugar: wildcard in rhs of as-pattern"  -- | Remove all wildcards from a pattern, replacing any wildcard with a fresh@@ -605,8 +648,18 @@ removeWilds (DConPa con_name pats) = DConPa con_name <$> mapM removeWilds pats removeWilds (DTildePa pat) = DTildePa <$> removeWilds pat removeWilds (DBangPa pat) = DBangPa <$> removeWilds pat+removeWilds (DSigPa pat ty) = DSigPa <$> removeWilds pat <*> pure ty removeWilds DWildPa = DVarPa <$> newUniqueName "wild" +extractBoundNamesDPat :: DPat -> S.Set Name+extractBoundNamesDPat (DLitPa _)      = S.empty+extractBoundNamesDPat (DVarPa n)      = S.singleton n+extractBoundNamesDPat (DConPa _ pats) = S.unions (map extractBoundNamesDPat pats)+extractBoundNamesDPat (DTildePa p)    = extractBoundNamesDPat p+extractBoundNamesDPat (DBangPa p)     = extractBoundNamesDPat p+extractBoundNamesDPat (DSigPa p _)    = extractBoundNamesDPat p+extractBoundNamesDPat DWildPa         = S.empty+ -- | Desugar @Info@ dsInfo :: DsMonad q => Info -> q DInfo dsInfo (ClassI dec instances) = do@@ -646,6 +699,9 @@   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+#endif  fixBug8884ForFamilies :: DsMonad q => DDec -> q (DDec, Int) #if __GLASGOW_HASKELL__ < 708@@ -707,21 +763,22 @@   (:[]) <$> (DDataD Data <$> dsCxt cxt <*> pure n                          <*> ((++ extra_tvbs) <$> mapM dsTvb tvbs)                          <*> concatMapM dsCon cons-                         <*> dsCxt derivings)+                         <*> mapM dsDerivClause derivings) dsDec (NewtypeD cxt n tvbs mk con derivings) = do   extra_tvbs <- mkExtraTvbs tvbs mk   (:[]) <$> (DDataD Newtype <$> dsCxt cxt <*> pure n                             <*> ((++ extra_tvbs) <$> mapM dsTvb tvbs)-                            <*> dsCon con <*> dsCxt derivings)+                            <*> dsCon con+                            <*> mapM dsDerivClause derivings) #else dsDec (DataD cxt n tvbs cons derivings) =   (:[]) <$> (DDataD Data <$> dsCxt cxt <*> pure n                          <*> mapM dsTvb tvbs <*> concatMapM dsCon cons-                         <*> pure (map DConPr derivings))+                         <*> mapM dsDerivClause derivings) dsDec (NewtypeD cxt n tvbs con derivings) =   (:[]) <$> (DDataD Newtype <$> dsCxt cxt <*> pure n                             <*> mapM dsTvb tvbs <*> dsCon con-                            <*> pure (map DConPr derivings))+                            <*> mapM dsDerivClause derivings) #endif dsDec (TySynD n tvbs ty) =   (:[]) <$> (DTySynD n <$> mapM dsTvb tvbs <*> dsType ty)@@ -738,7 +795,7 @@ dsDec d@(SigD {}) = (fmap . map) DLetDec $ dsLetDec d dsDec (ForeignD f) = (:[]) <$> (DForeignD <$> dsForeign f) dsDec d@(InfixD {}) = (fmap . map) DLetDec $ dsLetDec d-dsDec (PragmaD prag) = (:[]) <$> (DPragmaD <$> dsPragma prag)+dsDec d@(PragmaD {}) = (fmap . map) DLetDec $ dsLetDec d #if __GLASGOW_HASKELL__ > 710 dsDec (OpenTypeFamilyD tfHead) =   (:[]) <$> (DOpenTypeFamilyD <$> dsTypeFamilyHead tfHead)@@ -758,21 +815,21 @@   (:[]) <$> (DDataInstD Data <$> dsCxt cxt <*> pure n                              <*> ((++ extra_tvbs) <$> mapM dsType tys)                              <*> concatMapM dsCon cons-                             <*> dsCxt derivings)+                             <*> mapM dsDerivClause derivings) dsDec (NewtypeInstD cxt n tys mk con derivings) = do   extra_tvbs <- map dTyVarBndrToDType <$> mkExtraTvbs [] mk   (:[]) <$> (DDataInstD Newtype <$> dsCxt cxt <*> pure n                                 <*> ((++ extra_tvbs) <$> mapM dsType tys)                                 <*> dsCon con-                                <*> dsCxt derivings)+                                <*> mapM dsDerivClause derivings) #else dsDec (DataInstD cxt n tys cons derivings) = do   (:[]) <$> (DDataInstD Data <$> dsCxt cxt <*> pure n <*> mapM dsType tys                              <*> concatMapM dsCon cons-                             <*> pure (map DConPr derivings))+                             <*> mapM dsDerivClause derivings) dsDec (NewtypeInstD cxt n tys con derivings) = do   (:[]) <$> (DDataInstD Newtype <$> dsCxt cxt <*> pure n <*> mapM dsType tys-                                <*> dsCon con <*> pure (map DConPr derivings))+                                <*> dsCon con <*> mapM dsDerivClause derivings) #endif #if __GLASGOW_HASKELL__ < 707 dsDec (TySynInstD n lhs rhs) = (:[]) <$> (DTySynInstD n <$>@@ -792,8 +849,20 @@ dsDec (RoleAnnotD n roles) = return [DRoleAnnotD n roles] #endif #if __GLASGOW_HASKELL__ >= 709-dsDec (StandaloneDerivD cxt ty) = (:[]) <$> (DStandaloneDerivD <$> dsCxt cxt-                                                               <*> dsType ty)+#if __GLASGOW_HASKELL__ >= 801+dsDec (PatSynD n args dir pat) = do+  dir' <- dsPatSynDir n dir+  (pat', vars) <- dsPatX pat+  unless (null vars) $+    fail $ "Pattern synonym definition cannot contain as-patterns (@)."+  return [DPatSynD n args dir' pat']+dsDec (PatSynSigD n ty) = (:[]) <$> (DPatSynSigD n <$> dsType ty)+dsDec (StandaloneDerivD mds cxt ty) =+  (:[]) <$> (DStandaloneDerivD mds     <$> dsCxt cxt <*> dsType ty)+#else+dsDec (StandaloneDerivD cxt ty) =+  (:[]) <$> (DStandaloneDerivD Nothing <$> dsCxt cxt <*> dsType ty)+#endif dsDec (DefaultSigD n ty) = (:[]) <$> (DDefaultSigD n <$> dsType ty) #endif @@ -874,6 +943,7 @@   ty' <- dsType ty   return [DSigD name ty'] dsLetDec (InfixD fixity name) = return [DInfixD fixity name]+dsLetDec (PragmaD prag) = (:[]) <$> (DPragmaD <$> dsPragma prag) dsLetDec _dec = impossible "Illegal declaration in let expression."  -- | Desugar a single @Con@.@@ -946,6 +1016,9 @@ #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  -- | Desugar a @RuleBndr@. dsRuleBndr :: DsMonad q => RuleBndr -> q DRuleBndr@@ -1022,6 +1095,9 @@ dsType (ParensT t) = dsType t dsType WildCardT = return DWildCardT #endif+#if __GLASGOW_HASKELL__ >= 801+dsType (UnboxedSumT arity) = return $ DConT (unboxedSumTypeName arity)+#endif  -- | Desugar a @TyVarBndr@ dsTvb :: DsMonad q => TyVarBndr -> q DTyVarBndr@@ -1032,6 +1108,26 @@ dsCxt :: DsMonad q => Cxt -> q DCxt dsCxt = concatMapM dsPred +#if __GLASGOW_HASKELL__ >= 801+-- | Desugar a @DerivClause@.+dsDerivClause :: DsMonad q => DerivClause -> q DDerivClause+dsDerivClause (DerivClause mds cxt) = DDerivClause mds <$> dsCxt cxt+#elif __GLASGOW_HASKELL__ >= 711+dsDerivClause :: DsMonad q => Pred -> q DDerivClause+dsDerivClause p = DDerivClause Nothing <$> dsPred p+#else+dsDerivClause :: DsMonad q => Name -> q DDerivClause+dsDerivClause n = pure $ DDerivClause Nothing [DConPr n]+#endif++#if __GLASGOW_HASKELL__ >= 801+-- | Desugar a @PatSynDir@. (Available only with GHC 8.2+)+dsPatSynDir :: DsMonad q => Name -> PatSynDir -> q DPatSynDir+dsPatSynDir _ Unidir              = pure DUnidir+dsPatSynDir _ ImplBidir           = pure DImplBidir+dsPatSynDir n (ExplBidir clauses) = DExplBidir <$> dsClauses n clauses+#endif+ -- | Desugar a @Pred@, flattening any internal tuples dsPred :: DsMonad q => Pred -> q DCxt #if __GLASGOW_HASKELL__ < 709@@ -1081,7 +1177,11 @@ dsPred (ParensT t) = dsPred t dsPred WildCardT = return [DWildCardPr] #endif+#if __GLASGOW_HASKELL__ >= 801+dsPred t@(UnboxedSumT {}) =+  impossible $ "Unboxed sum seen as head of constraint: " ++ show t #endif+#endif  -- | Like 'reify', but safer and desugared. Uses local declarations where -- available.@@ -1142,9 +1242,10 @@   if length cons == 1   then fmap and $ mapM isUniversalPattern pats   else return False-isUniversalPattern (DTildePa {}) = return True-isUniversalPattern (DBangPa pat) = isUniversalPattern pat-isUniversalPattern DWildPa       = return True+isUniversalPattern (DTildePa {})  = return True+isUniversalPattern (DBangPa pat)  = isUniversalPattern pat+isUniversalPattern (DSigPa pat _) = isUniversalPattern pat+isUniversalPattern DWildPa        = return True  -- | Apply one 'DExp' to a list of arguments applyDExp :: DExp -> [DExp] -> DExp

@@ -1,7 +1,7 @@ {- Language/Haskell/TH/Desugar/Expand.hs  (c) Richard Eisenberg 2013-eir@cis.upenn.edu+rae@cs.brynmawr.edu -}  {-# LANGUAGE CPP, NoMonomorphismRestriction #-}@@ -11,7 +11,7 @@ -- Module      :  Language.Haskell.TH.Desugar.Expand -- Copyright   :  (C) 2014 Richard Eisenberg -- License     :  BSD-style (see LICENSE)--- Maintainer  :  Richard Eisenberg (eir@cis.upenn.edu)+-- Maintainer  :  Richard Eisenberg (rae@cs.brynmawr.edu) -- Stability   :  experimental -- Portability :  non-portable --@@ -54,7 +54,8 @@ data IgnoreKinds = YesIgnore | NoIgnore  -- | Expands all type synonyms in a desugared type. Also expands open type family--- applications, as long as the arguments have no free variables. Attempts to+-- applications. (In GHCs before 7.10, this part does not work if there are any+-- variables.) Attempts to -- expand closed type family applications, but aborts the moment it spots anything -- strange, like a nested type family application or type variable. expandType :: DsMonad q => DType -> q DType@@ -112,7 +113,9 @@      DTyConI (DOpenTypeFamilyD (DTypeFamilyHead _n tvbs _frs _ann)) _       |  length args >= length tvbs   -- this should always be true!+#if __GLASGOW_HASKELL__ < 709       ,  args_ok+#endif       -> do         let (syn_args, rest_args) = splitAtList tvbs args         -- need to get the correct instance

@@ -3,7 +3,7 @@ -- Module      :  Language.Haskell.TH.Desugar.Lift -- Copyright   :  (C) 2014 Richard Eisenberg -- License     :  BSD-style (see LICENSE)--- Maintainer  :  Richard Eisenberg (eir@cis.upenn.edu)+-- Maintainer  :  Richard Eisenberg (rae@cs.brynmawr.edu) -- Stability   :  experimental -- Portability :  non-portable --@@ -24,9 +24,9 @@ import Language.Haskell.TH.Lift  $(deriveLiftMany [ ''DExp, ''DPat, ''DType, ''DPred, ''DTyVarBndr-                 , ''DMatch, ''DClause, ''DLetDec, ''DDec, ''DCon+                 , ''DMatch, ''DClause, ''DLetDec, ''DDec, ''DDerivClause, ''DCon                  , ''DConFields, ''DForeign, ''DPragma, ''DRuleBndr, ''DTySynEqn-                 , ''NewOrData+                 , ''DPatSynDir , ''NewOrData #if __GLASGOW_HASKELL__ < 707                  , ''AnnTarget, ''Role #endif@@ -34,5 +34,8 @@ #if __GLASGOW_HASKELL__ <= 710                  , ''InjectivityAnn, ''Bang, ''SourceUnpackedness                  , ''SourceStrictness, ''Overlap+#endif+#if __GLASGOW_HASKELL__ < 801+                 , ''DerivStrategy, ''PatSynArgs #endif                  ])

@@ -1,7 +1,7 @@ {- Language/Haskell/TH/Desugar/Match.hs  (c) Richard Eisenberg 2013-eir@cis.upenn.edu+rae@cs.brynmawr.edu  Simplifies case statements in desugared TH. After this pass, there are no more nested patterns.@@ -24,6 +24,9 @@ import Control.Applicative #endif import Control.Monad hiding ( fail )+import qualified Control.Monad as Monad+import Data.Data+import Data.Generics import qualified Data.Set as S import qualified Data.Map as Map import Language.Haskell.TH.Instances ()@@ -53,7 +56,11 @@  scExp (DLetE decs body) = DLetE <$> mapM scLetDec decs <*> scExp body scExp (DSigE exp ty) = DSigE <$> scExp exp <*> pure ty-scExp e = return e+scExp (DAppTypeE exp ty) = DAppTypeE <$> scExp exp <*> pure ty+scExp e@(DVarE {}) = return e+scExp e@(DConE {}) = return e+scExp e@(DLitE {}) = return e+scExp e@(DStaticE {}) = return e  -- | Like 'scExp', but for a 'DLetDec'. scLetDec :: DsMonad q => DLetDec -> q DLetDec@@ -65,8 +72,14 @@   where     sc_clause_rhs (DClause pats exp) = DClause pats <$> scExp exp scLetDec (DValD pat exp) = DValD pat <$> scExp exp-scLetDec dec = return dec+scLetDec (DPragmaD prag) = DPragmaD <$> scLetPragma prag+scLetDec dec@(DSigD {}) = return dec+scLetDec dec@(DInfixD {}) = return dec+scLetDec dec@(DFunD _ []) = return dec +scLetPragma :: DsMonad q => DPragma -> q DPragma+scLetPragma = topEverywhereM scExp -- Only topEverywhereM because scExp already recurses on its own+ type MatchResult = DExp -> DExp  matchResultToDExp :: MatchResult -> DExp@@ -141,7 +154,23 @@     DConPa _ _ -> tidy1 v pat   -- already strict     DTildePa p -> tidy1 v (DBangPa p) -- discard ~ under !     DBangPa p  -> tidy1 v (DBangPa p) -- discard ! under !+    DSigPa p _ -> tidy1 v (DBangPa p) -- discard sig under !     DWildPa    -> return (id, DBangPa pat)  -- no change+tidy1 v (DSigPa pat ty)+  | no_tyvars_ty ty = tidy1 v pat+  -- The match-flattener doesn't know how to deal with patterns that mention+  -- type variables properly, so we give up if we encounter one.+  -- See https://github.com/goldfirere/th-desugar/pull/48#issuecomment-266778976+  -- for further discussion.+  | otherwise = Monad.fail+    "Match-flattening patterns that mention type variables is not supported."+  where+    no_tyvars_ty :: Data a => a -> Bool+    no_tyvars_ty = everything (&&) (mkQ True no_tyvar_ty)++    no_tyvar_ty :: DType -> Bool+    no_tyvar_ty (DVarT{}) = False+    no_tyvar_ty t         = gmapQl (&&) True no_tyvars_ty t tidy1 _ DWildPa = return (id, DWildPa)  wrapBind :: Name -> Name -> DExp -> DExp@@ -199,14 +228,6 @@       rhs_mr <- simplCase [scrut_var] [EquationInfo [pat] (\_ -> DVarE bndr_var)]       return (DValD (DVarPa bndr_var) (rhs_mr (DVarE err_var))) -extractBoundNamesDPat :: DPat -> S.Set Name-extractBoundNamesDPat (DLitPa _)      = S.empty-extractBoundNamesDPat (DVarPa n)      = S.singleton n-extractBoundNamesDPat (DConPa _ pats) = S.unions (map extractBoundNamesDPat pats)-extractBoundNamesDPat (DTildePa p)    = extractBoundNamesDPat p-extractBoundNamesDPat (DBangPa p)     = extractBoundNamesDPat p-extractBoundNamesDPat DWildPa         = S.empty- data PatGroup   = PgAny         -- immediate match (wilds, vars, lazies)   | PgCon Name@@ -223,10 +244,11 @@  patGroup :: DPat -> PatGroup patGroup (DLitPa l)     = PgLit l-patGroup (DVarPa {})    = error "Internal error in th-desugar (patGroup DVarP)"+patGroup (DVarPa {})    = error "Internal error in th-desugar (patGroup DVarPa)" patGroup (DConPa con _) = PgCon con-patGroup (DTildePa {})  = error "Internal error in th-desugar (patGroup DTildeP)"+patGroup (DTildePa {})  = error "Internal error in th-desugar (patGroup DTildePa)" patGroup (DBangPa {})   = PgBang+patGroup (DSigPa{})     = error "Internal error in th-desugar (patGroup DSigPa)" patGroup DWildPa        = PgAny  sameGroup :: PatGroup -> PatGroup -> Bool

@@ -1,7 +1,7 @@ {- Language/Haskell/TH/Desugar/Reify.hs  (c) Richard Eisenberg 2014-eir@cis.upenn.edu+rae@cs.brynmawr.edu  Allows for reification from a list of declarations, without looking a name up in the environment.@@ -240,6 +240,10 @@   = Just $ FamilyI dec [] #endif #endif+#if __GLASGOW_HASKELL__ >= 801+reifyInDec n decs (PatSynD n' _ _ _) | n `nameMatches` n'+  = Just $ mkPatSynI n decs+#endif  #if __GLASGOW_HASKELL__ > 710 reifyInDec n decs (DataD _ ty_name tvbs _mk cons _)@@ -336,10 +340,7 @@ maybeReifyCon _ _ _ _ _ = Nothing  mkVarI :: Name -> [Dec] -> Info-mkVarI n decs = mkVarITy n decs (fromMaybe no_type $ findType n decs)-  where-    no_type = error $ "No type information found in local declaration for "-                      ++ show n+mkVarI n decs = mkVarITy n decs (fromMaybe (no_type n) $ findType n decs)  mkVarITy :: Name -> [Dec] -> Type -> Info #if __GLASGOW_HASKELL__ > 710@@ -354,6 +355,21 @@   where     match_type (SigD n' ty) | n `nameMatches` n' = Just ty     match_type _                             = Nothing++#if __GLASGOW_HASKELL__ >= 801+mkPatSynI :: Name -> [Dec] -> Info+mkPatSynI n decs = PatSynI n (fromMaybe (no_type n) $ findPatSynType n decs)++findPatSynType :: Name -> [Dec] -> Maybe PatSynType+findPatSynType n = firstMatch match_pat_syn_type+  where+    match_pat_syn_type (PatSynSigD n' psty) | n `nameMatches` n' = Just psty+    match_pat_syn_type _                                         = Nothing+#endif++no_type :: Name -> Type+no_type n = error $ "No type information found in local declaration for "+                    ++ show n  findInstances :: Name -> [Dec] -> [Dec] findInstances n = map stripInstanceDec . concatMap match_instance

@@ -1,7 +1,7 @@ {- Language/Haskell/TH/Desugar/Sweeten.hs  (c) Richard Eisenberg 2013-eir@cis.upenn.edu+rae@cs.brynmawr.edu  Converts desugared TH back into real TH. -}@@ -14,7 +14,7 @@ -- Module      :  Language.Haskell.TH.Desugar.Sweeten -- Copyright   :  (C) 2014 Richard Eisenberg -- License     :  BSD-style (see LICENSE)--- Maintainer  :  Richard Eisenberg (eir@cis.upenn.edu)+-- Maintainer  :  Richard Eisenberg (rae@cs.brynmawr.edu) -- Stability   :  experimental -- Portability :  non-portable --@@ -28,7 +28,10 @@   letDecToTH, typeToTH,    conToTH, foreignToTH, pragmaToTH, ruleBndrToTH,-  clauseToTH, tvbToTH, cxtToTH, predToTH+  clauseToTH, tvbToTH, cxtToTH, predToTH, derivClauseToTH,+#if __GLASGOW_HASKELL__ >= 801+  patSynDirToTH+#endif   ) where  import Prelude hiding (exp)@@ -39,7 +42,7 @@ import Language.Haskell.TH.Desugar.Core import Language.Haskell.TH.Desugar.Util -import Data.Maybe ( maybeToList )+import Data.Maybe ( maybeToList, mapMaybe )  expToTH :: DExp -> Exp expToTH (DVarE n)            = VarE n@@ -48,13 +51,20 @@ expToTH (DAppE e1 e2)        = AppE (expToTH e1) (expToTH e2) expToTH (DLamE names exp)    = LamE (map VarP names) (expToTH exp) expToTH (DCaseE exp matches) = CaseE (expToTH exp) (map matchToTH matches)-expToTH (DLetE decs exp)     = LetE (map letDecToTH decs) (expToTH exp)+expToTH (DLetE decs exp)     = LetE (mapMaybe 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+-- In the event that we're on a version of Template Haskell without support for+-- type applications, we will simply drop the applied type.+expToTH (DAppTypeE exp _)    = expToTH exp+#endif  matchToTH :: DMatch -> Match matchToTH (DMatch pat exp) = Match (patToTH pat) (NormalB (expToTH exp)) []@@ -65,6 +75,7 @@ patToTH (DConPa n pats) = ConP n (map patToTH pats) patToTH (DTildePa pat)  = TildeP (patToTH pat) patToTH (DBangPa pat)   = BangP (patToTH pat)+patToTH (DSigPa pat ty) = SigP (patToTH pat) (typeToTH ty) patToTH DWildPa         = WildP  decsToTH :: [DDec] -> [Dec]@@ -73,11 +84,11 @@ -- | This returns a list of @Dec@s because GHC 7.6.3 does not have -- a one-to-one mapping between 'DDec' and @Dec@. decToTH :: DDec -> [Dec]-decToTH (DLetDec d) = [letDecToTH d]+decToTH (DLetDec d) = maybeToList (letDecToTH d) decToTH (DDataD Data cxt n tvbs cons derivings) = #if __GLASGOW_HASKELL__ > 710   [DataD (cxtToTH cxt) n (map tvbToTH tvbs) Nothing (map conToTH cons)-         (cxtToTH derivings)]+         (concatMap derivClauseToTH derivings)] #else   [DataD (cxtToTH cxt) n (map tvbToTH tvbs) (map conToTH cons)          (map derivingToTH derivings)]@@ -85,7 +96,7 @@ decToTH (DDataD Newtype cxt n tvbs [con] derivings) = #if __GLASGOW_HASKELL__ > 710   [NewtypeD (cxtToTH cxt) n (map tvbToTH tvbs) Nothing (conToTH con)-            (cxtToTH derivings)]+            (concatMap derivClauseToTH derivings)] #else   [NewtypeD (cxtToTH cxt) n (map tvbToTH tvbs) (conToTH con)             (map derivingToTH derivings)]@@ -101,7 +112,6 @@   [InstanceD (cxtToTH cxt) (typeToTH ty) (decsToTH decs)] #endif decToTH (DForeignD f) = [ForeignD (foreignToTH f)]-decToTH (DPragmaD prag) = maybeToList $ fmap PragmaD (pragmaToTH prag) #if __GLASGOW_HASKELL__ > 710 decToTH (DOpenTypeFamilyD (DTypeFamilyHead n tvbs frs ann)) =   [OpenTypeFamilyD (TypeFamilyHead n (map tvbToTH tvbs) (frsToTH frs) ann)]@@ -118,22 +128,18 @@ decToTH (DDataInstD Data cxt n tys cons derivings) = #if __GLASGOW_HASKELL__ > 710   [DataInstD (cxtToTH cxt) n (map typeToTH tys) Nothing (map conToTH cons)-             (cxtToTH derivings)-  ]+             (concatMap derivClauseToTH derivings)] #else   [DataInstD (cxtToTH cxt) n (map typeToTH tys) (map conToTH cons)-             (map derivingToTH derivings)-  ]+             (map derivingToTH derivings)] #endif decToTH (DDataInstD Newtype cxt n tys [con] derivings) = #if __GLASGOW_HASKELL__ > 710   [NewtypeInstD (cxtToTH cxt) n (map typeToTH tys) Nothing (conToTH con)-                (cxtToTH derivings)-  ]+                (concatMap derivClauseToTH derivings)] #else   [NewtypeInstD (cxtToTH cxt) n (map typeToTH tys) (conToTH con)-                (map derivingToTH derivings)-  ]+                (map derivingToTH derivings)] #endif #if __GLASGOW_HASKELL__ < 707 decToTH (DTySynInstD n eqn) = [tySynEqnToTHDec n eqn]@@ -160,10 +166,24 @@ decToTH (DDefaultSigD {})      =   error "Default method signatures supported only in GHC 7.10+" #else-decToTH (DStandaloneDerivD cxt ty) =-  [StandaloneDerivD (cxtToTH cxt) (typeToTH ty)]+decToTH (DStandaloneDerivD _mds cxt ty) =+  [StandaloneDerivD+#if __GLASGOW_HASKELL__ >= 801+    _mds+#endif+    (cxtToTH cxt) (typeToTH ty)] 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)]+#else+decToTH dec+  | DPatSynD{}    <- dec = patSynErr+  | DPatSynSigD{} <- dec = patSynErr+  where+    patSynErr = error "Pattern synonyms supported only in GHC 8.2+"+#endif decToTH _ = error "Newtype declaration without exactly 1 constructor."  #if __GLASGOW_HASKELL__ > 710@@ -180,17 +200,20 @@ #endif  #if __GLASGOW_HASKELL__ <= 710-derivingToTH :: DPred -> Name-derivingToTH (DConPr nm) = nm+derivingToTH :: DDerivClause -> Name+derivingToTH (DDerivClause _ [DConPr nm]) = nm derivingToTH p =   error ("Template Haskell in GHC < 8.0 only allows simple derivings: " ++ show p) #endif -letDecToTH :: DLetDec -> Dec-letDecToTH (DFunD name clauses) = FunD name (map clauseToTH clauses)-letDecToTH (DValD pat exp)      = ValD (patToTH pat) (NormalB (expToTH exp)) []-letDecToTH (DSigD name ty)      = SigD name (typeToTH ty)-letDecToTH (DInfixD f name)     = InfixD f name+-- | Note: This can currently only return a 'Nothing' if the 'DLetDec' is a pragma which+-- is not supported by the GHC version being used.+letDecToTH :: DLetDec -> Maybe Dec+letDecToTH (DFunD name clauses) = Just $ FunD name (map clauseToTH clauses)+letDecToTH (DValD pat exp)      = Just $ ValD (patToTH pat) (NormalB (expToTH exp)) []+letDecToTH (DSigD name ty)      = Just $ SigD name (typeToTH ty)+letDecToTH (DInfixD f name)     = Just $ InfixD f name+letDecToTH (DPragmaD prag)      = fmap PragmaD (pragmaToTH prag)  conToTH :: DCon -> Con #if __GLASGOW_HASKELL__ > 710@@ -236,6 +259,11 @@ #else pragmaToTH (DLineP n str) = Just $ LineP n str #endif+#if __GLASGOW_HASKELL__ < 801+pragmaToTH (DCompleteP {}) = Nothing+#else+pragmaToTH (DCompleteP cls mty) = Just $ CompleteP cls mty+#endif  ruleBndrToTH :: DRuleBndr -> RuleBndr ruleBndrToTH (DRuleVar n) = RuleVar n@@ -277,6 +305,21 @@ cxtToTH :: DCxt -> Cxt cxtToTH = map predToTH +#if __GLASGOW_HASKELL__ >= 801+derivClauseToTH :: DDerivClause -> [DerivClause]+derivClauseToTH (DDerivClause mds cxt) = [DerivClause mds (cxtToTH cxt)]+#else+derivClauseToTH :: DDerivClause -> Cxt+derivClauseToTH (DDerivClause _ cxt) = cxtToTH cxt+#endif++#if __GLASGOW_HASKELL__ >= 801+patSynDirToTH :: DPatSynDir -> PatSynDir+patSynDirToTH DUnidir              = Unidir+patSynDirToTH DImplBidir           = ImplBidir+patSynDirToTH (DExplBidir clauses) = ExplBidir (map clauseToTH clauses)+#endif+ predToTH :: DPred -> Pred #if __GLASGOW_HASKELL__ < 709 predToTH = go []@@ -317,6 +360,9 @@                                                  then PromotedTupleT deg                                                  else TupleT deg   | Just deg <- unboxedTupleNameDegree_maybe n = UnboxedTupleT deg+#if __GLASGOW_HASKELL__ >= 801+  | Just deg <- unboxedSumNameDegree_maybe n   = UnboxedSumT deg+#endif   | otherwise                   = ConT n  #if __GLASGOW_HASKELL__ <= 710

@@ -1,7 +1,7 @@ {- Language/Haskell/TH/Desugar/Util.hs  (c) Richard Eisenberg 2013-eir@cis.upenn.edu+rae@cs.brynmawr.edu  Utility functions for th-desugar package. -}@@ -18,8 +18,10 @@   thirdOf3, splitAtList, extractBoundNamesDec,   extractBoundNamesPat,   tvbName, tvbToType, nameMatches, freeNamesOfTypes, thdOf3, firstMatch,+  unboxedSumDegree_maybe, unboxedSumNameDegree_maybe,   tupleDegree_maybe, tupleNameDegree_maybe, unboxedTupleDegree_maybe,-  unboxedTupleNameDegree_maybe, splitTuple_maybe+  unboxedTupleNameDegree_maybe, splitTuple_maybe,+  topEverywhereM   ) where  import Prelude hiding (mapM, foldl, concatMap, any)@@ -85,7 +87,7 @@  -- | Report that a certain TH construct is impossible impossible :: Monad q => String -> q a-impossible err = fail (err ++ "\n    This should not happen in Haskell.\n    Please email eir@cis.upenn.edu with your code if you see this.")+impossible err = fail (err ++ "\n    This should not happen in Haskell.\n    Please email rae@cs.brynmawr.edu with your code if you see this.")  -- | Extract a 'Name' from a 'TyVarBndr' tvbName :: TyVarBndr -> Name@@ -127,17 +129,29 @@ tupleNameDegree_maybe :: Name -> Maybe Int tupleNameDegree_maybe = tupleDegree_maybe . nameBase +-- | Extract the degree of an unboxed sum+unboxedSumDegree_maybe :: String -> Maybe Int+unboxedSumDegree_maybe = unboxedSumTupleDegree_maybe '|'++-- | Extract the degree of an unboxed sum name+unboxedSumNameDegree_maybe :: Name -> Maybe Int+unboxedSumNameDegree_maybe = unboxedSumDegree_maybe . nameBase+ -- | Extract the degree of an unboxed tuple unboxedTupleDegree_maybe :: String -> Maybe Int-unboxedTupleDegree_maybe s = do+unboxedTupleDegree_maybe = unboxedSumTupleDegree_maybe ','++-- | Extract the degree of an unboxed sum or tuple+unboxedSumTupleDegree_maybe :: Char -> String -> Maybe Int+unboxedSumTupleDegree_maybe sep s = do   '(' : '#' : s1 <- return s-  (commas, "#)") <- return $ span (== ',') s1+  (seps, "#)") <- return $ span (== sep) s1   let degree-        | "" <- commas = 0-        | otherwise    = length commas + 1+        | "" <- seps = 0+        | otherwise  = length seps + 1   return degree --- | Extract the degree of a tuple name+-- | Extract the degree of an unboxed tuple name unboxedTupleNameDegree_maybe :: Name -> Maybe Int unboxedTupleNameDegree_maybe = unboxedTupleDegree_maybe . nameBase @@ -182,25 +196,28 @@  -- | Extract the names bound in a @Pat@ extractBoundNamesPat :: Pat -> S.Set Name-extractBoundNamesPat (LitP _)            = S.empty-extractBoundNamesPat (VarP name)         = S.singleton name-extractBoundNamesPat (TupP pats)         = foldMap extractBoundNamesPat pats-extractBoundNamesPat (UnboxedTupP pats)  = foldMap extractBoundNamesPat pats-extractBoundNamesPat (ConP _ pats)       = foldMap extractBoundNamesPat pats-extractBoundNamesPat (InfixP p1 _ p2)    = extractBoundNamesPat p1 `S.union`-                                           extractBoundNamesPat p2-extractBoundNamesPat (UInfixP p1 _ p2)   = extractBoundNamesPat p1 `S.union`-                                           extractBoundNamesPat p2-extractBoundNamesPat (ParensP pat)       = extractBoundNamesPat pat-extractBoundNamesPat (TildeP pat)        = extractBoundNamesPat pat-extractBoundNamesPat (BangP pat)         = extractBoundNamesPat pat-extractBoundNamesPat (AsP name pat)      = S.singleton name `S.union` extractBoundNamesPat pat-extractBoundNamesPat WildP               = S.empty-extractBoundNamesPat (RecP _ field_pats) = let (_, pats) = unzip field_pats in-                                           foldMap extractBoundNamesPat pats-extractBoundNamesPat (ListP pats)        = foldMap extractBoundNamesPat pats-extractBoundNamesPat (SigP pat _)        = extractBoundNamesPat pat-extractBoundNamesPat (ViewP _ pat)       = extractBoundNamesPat pat+extractBoundNamesPat (LitP _)              = S.empty+extractBoundNamesPat (VarP name)           = S.singleton name+extractBoundNamesPat (TupP pats)           = foldMap extractBoundNamesPat pats+extractBoundNamesPat (UnboxedTupP pats)    = foldMap extractBoundNamesPat pats+extractBoundNamesPat (ConP _ pats)         = foldMap extractBoundNamesPat pats+extractBoundNamesPat (InfixP p1 _ p2)      = extractBoundNamesPat p1 `S.union`+                                             extractBoundNamesPat p2+extractBoundNamesPat (UInfixP p1 _ p2)     = extractBoundNamesPat p1 `S.union`+                                             extractBoundNamesPat p2+extractBoundNamesPat (ParensP pat)         = extractBoundNamesPat pat+extractBoundNamesPat (TildeP pat)          = extractBoundNamesPat pat+extractBoundNamesPat (BangP pat)           = extractBoundNamesPat pat+extractBoundNamesPat (AsP name pat)        = S.singleton name `S.union` extractBoundNamesPat pat+extractBoundNamesPat WildP                 = S.empty+extractBoundNamesPat (RecP _ field_pats)   = let (_, pats) = unzip field_pats in+                                             foldMap extractBoundNamesPat pats+extractBoundNamesPat (ListP pats)          = foldMap extractBoundNamesPat pats+extractBoundNamesPat (SigP pat _)          = extractBoundNamesPat pat+extractBoundNamesPat (ViewP _ pat)         = extractBoundNamesPat pat+#if __GLASGOW_HASKELL__ >= 801+extractBoundNamesPat (UnboxedSumP pat _ _) = extractBoundNamesPat pat+#endif  freeNamesOfTypes :: [Type] -> S.Set Name freeNamesOfTypes = mconcat . map go@@ -262,3 +279,14 @@  firstMatch :: (a -> Maybe b) -> [a] -> Maybe b firstMatch f xs = listToMaybe $ mapMaybe f xs++-- | Semi-shallow version of 'everywhereM' - does not recurse into children of nodes of type @a@ (only applies the handler to them).+--+-- >>> topEverywhereM (pure . fmap (*10) :: [Integer] -> Identity [Integer]) ([1,2,3] :: [Integer], "foo" :: String)+-- Identity ([10,20,30],"foo")+--+-- >>> everywhereM (mkM (pure . fmap (*10) :: [Integer] -> Identity [Integer])) ([1,2,3] :: [Integer], "foo" :: String)+-- Identity ([10,200,3000],"foo")+topEverywhereM :: (Typeable a, Data b, Monad m) => (a -> m a) -> b -> m b+topEverywhereM handler =+  gmapM (topEverywhereM handler) `extM` handler

@@ -1,7 +1,7 @@ {- Tests for the th-desugar package  (c) Richard Eisenberg 2013-eir@cis.upenn.edu+rae@cs.brynmawr.edu -}  {-# LANGUAGE TemplateHaskell, GADTs, PolyKinds, TypeFamilies,

@@ -1,7 +1,7 @@ {- Tests for the th-desugar package  (c) Richard Eisenberg 2013-eir@cis.upenn.edu+rae@cs.brynmawr.edu -}  {-# LANGUAGE TemplateHaskell, GADTs, PolyKinds, TypeFamilies,@@ -12,6 +12,9 @@ #if __GLASGOW_HASKELL__ >= 707 {-# LANGUAGE RoleAnnotations #-} #endif+#if __GLASGOW_HASKELL__ >= 801+{-# LANGUAGE DerivingStrategies #-}+#endif  {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-incomplete-patterns                 -fno-warn-name-shadowing #-}@@ -29,6 +32,7 @@ import Language.Haskell.TH.Desugar  import Control.Monad+import Data.Maybe( mapMaybe )  $(dsDecSplice S.dectest1) $(dsDecSplice S.dectest2)@@ -58,13 +62,17 @@ $(dsDecSplice S.standalone_deriving_test) #endif +#if __GLASGOW_HASKELL__ >= 801+$(dsDecSplice S.deriv_strat_test)+#endif+ $(dsDecSplice S.dectest12) $(dsDecSplice S.dectest13)  $(do decs <- S.rec_sel_test      [DDataD nd [] name [DPlainTV tvbName] cons []] <- dsDecs decs      let arg_ty = (DConT name) `DAppT` (DVarT tvbName)-     recsels <- fmap concat $ mapM (getRecordSelectors arg_ty) cons+     recsels <- getRecordSelectors arg_ty cons      let num_sels = length recsels `div` 2 -- ignore type sigs      when (num_sels /= S.rec_sel_test_num_sels) $        reportError $ "Wrong number of record selectors extracted.\n"@@ -77,4 +85,4 @@            in            DCon tvbs cxt con_name (DNormalC fields') rty          plaindata = [DDataD nd [] name [DPlainTV tvbName] (map unrecord cons) []]-     return (decsToTH plaindata ++ map letDecToTH recsels))+     return (decsToTH plaindata ++ mapMaybe letDecToTH recsels))

@@ -1,23 +1,25 @@ {- Tests for the th-desugar package  (c) Richard Eisenberg 2013-eir@cis.upenn.edu+rae@cs.brynmawr.edu -}  {-# LANGUAGE TemplateHaskell, UnboxedTuples, ParallelListComp, CPP,              RankNTypes, ImpredicativeTypes, TypeFamilies,              DataKinds, ConstraintKinds, PolyKinds, MultiParamTypeClasses,-             FlexibleInstances, ExistentialQuantification #-}+             FlexibleInstances, ExistentialQuantification,+             ScopedTypeVariables, GADTs, ViewPatterns #-} {-# 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 #-}  #if __GLASGOW_HASKELL__ >= 711 {-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE PatternSynonyms #-} {-# OPTIONS_GHC -Wno-partial-type-signatures -Wno-redundant-constraints #-} #endif -module Run where+module Main where  import Prelude hiding ( exp ) @@ -88,8 +90,9 @@              , "asp"      ~: $test20_asp      @=? $(dsSplice test20_asp)              , "wildp"    ~: $test21_wildp    @=? $(dsSplice test21_wildp)              , "listp"    ~: $test22_listp    @=? $(dsSplice test22_listp)--- type signatures in patterns not yet handled by Template Haskell---           , "sigp"     ~: $test23_sigp     @=? $(dsSplice test23_sigp)+#if __GLASGOW_HASKELL__ >= 801+             , "sigp"     ~: $test23_sigp     @=? $(dsSplice test23_sigp)+#endif              , "fun"      ~: $test24_fun      @=? $(dsSplice test24_fun)              , "fun2"     ~: $test25_fun2     @=? $(dsSplice test25_fun2)              , "forall"   ~: $test26_forall   @=? $(dsSplice test26_forall)@@ -109,6 +112,11 @@ #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)+             , "ubx_sums"   ~: $test43_ubx_sums   @=? $(dsSplice test43_ubx_sums)+#endif              ]  test35a = $test35_expand@@ -127,11 +135,17 @@ test_e7a = $test_expand7 test_e7b = $(test_expand7 >>= dsExp >>= expand >>= return . expToTH) test_e7c = $(test_expand7 >>= dsExp >>= expandUnsoundly >>= return . expToTH)+#if __GLASGOW_HASKELL__ < 801 test_e8a = $(test_expand8 >>= dsExp >>= expand >>= return . expToTH)-  -- the line above should fail once GHC#8953 is fixed for closed type-  -- families+  -- This won't expand on recent GHCs now that GHC Trac #8953 is fixed for+  -- closed type families.+#endif test_e8b = $(test_expand8 >>= dsExp >>= expandUnsoundly >>= return . expToTH) #endif+#if __GLASGOW_HASKELL__ >= 709+test_e9a = $test_expand9  -- requires GHC #9262+test_e9b = $(test_expand9 >>= dsExp >>= expand >>= return . expToTH)+#endif  hasSameType :: a -> a -> Bool hasSameType _ _ = True@@ -146,8 +160,14 @@                   , hasSameType test_e6a test_e6b                   , hasSameType test_e7a test_e7b                   , hasSameType test_e7a test_e7c+#if __GLASGOW_HASKELL__ < 801                   , hasSameType test_e8a test_e8a #endif+                  , hasSameType test_e8b test_e8b+#endif+#if __GLASGOW_HASKELL__ >= 709+                  , hasSameType test_e9a test_e9b+#endif                   ]  test_dec :: [Bool]@@ -201,6 +221,13 @@ test_standalone_deriving = True #endif +test_deriving_strategies :: Bool+#if __GLASGOW_HASKELL__ >= 801+test_deriving_strategies = compare (MkBlarggie 5 'x') (MkBlarggie 5 'x') == EQ+#else+test_deriving_strategies = True+#endif+ local_reifications :: [String] local_reifications = $(do decs <- reifyDecs                           m_infos <- withLocalDeclarations decs $@@ -267,6 +294,8 @@     it "extracts record selectors" $ test_rec_sels      it "works with standalone deriving" $ test_standalone_deriving++    it "workds with deriving strategies" $ test_deriving_strategies      -- Remove map pprints here after switch to th-orphans     zipWithM (\t t' -> it ("can do Type->DType->Type of " ++ t) $ t == t')

@@ -1,7 +1,7 @@ {- Tests for the th-desugar package  (c) Richard Eisenberg 2013-eir@cis.upenn.edu+rae@cs.brynmawr.edu -}  {-# LANGUAGE TemplateHaskell, LambdaCase, MagicHash, UnboxedTuples,@@ -9,7 +9,18 @@              ScopedTypeVariables, RankNTypes, TypeFamilies, ImpredicativeTypes,              DataKinds, PolyKinds, GADTs, MultiParamTypeClasses,              FunctionalDependencies, FlexibleInstances, StandaloneDeriving,-             DefaultSignatures, ConstraintKinds #-}+             DefaultSignatures, ConstraintKinds, GADTs, ViewPatterns #-}++#if __GLASGOW_HASKELL__ >= 711+{-# LANGUAGE TypeApplications #-}+#endif++#if __GLASGOW_HASKELL__ >= 801+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE UnboxedSums #-}+#endif+ {-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-type-defaults                 -fno-warn-name-shadowing #-} @@ -149,8 +160,9 @@ test20_asp = [| map (\ a@(b :+: c) -> (if c then b + 1 else b - 1, a)) [5 :+: True, 10 :+: False] |] test21_wildp = [| zipWith (\_ _ -> 10) [1,2,3] ['a','b','c'] |] test22_listp = [| map (\ [a,b,c] -> a + b + c) [[1,2,3],[4,5,6]] |]--- type signatures in patterns not yet handled by Template Haskell--- test23_sigp = [| map (\ (a :: Int) -> a + a) [5, 10] |]+#if __GLASGOW_HASKELL__ >= 801+test23_sigp = [| map (\ (a :: Int) -> a + a) [5, 10] |]+#endif  -- See Note [Annotating list elements] test24_fun = [| let f :: Maybe (Maybe a) -> Maybe a@@ -211,6 +223,27 @@                       f True False :: String |] #endif +#if __GLASGOW_HASKELL__ >= 801+test41_typeapps = [| let f :: forall a. (a -> Bool) -> Bool+                         f g = g (undefined @_ @a) in+                     f (const True) |]++test42_scoped_tvs = [| let f :: (Read a, Show a) => a -> String -> String+                           f (_ :: b) (x :: String) = show (read x :: b)+                       in f True "True" |]++test43_ubx_sums = [| let f :: (# Bool | String #) -> Bool+                         f (# b |   #) = not b+                         f (#   | c #) = c == "c" in+                     f (# | "a" #) |]+#endif++test44_let_pragma = [| let x :: Int+                           x = 1+                           {-# INLINE x #-}+                       in x |]++ type family TFExpand x type instance TFExpand Int = Bool type instance TFExpand (Maybe a) = [a]@@ -246,6 +279,12 @@ #endif  #if __GLASGOW_HASKELL__ >= 709+test_expand9 = [| let f :: TFExpand (Maybe (IO a)) -> IO ()+                      f actions = sequence_ actions in+                  f |]+#endif++#if __GLASGOW_HASKELL__ >= 709 test37_pred = [| let f :: (Read a, (Show a, Num a)) => a -> a                      f x = read (show x) + x in                  (f 3, f 4.5) |]@@ -312,6 +351,9 @@               |] 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  dectest12 = [d| data Dec12 a where                   MkGInt :: Dec12 Int@@ -378,7 +420,11 @@  reifyDecs :: Q [Dec] reifyDecs = [d|-  r1 :: a -> a+  -- NB: Use a forall here! If you don't, when you splice r1 in and then reify+  -- it, GHC will add an explicit forall behind the scenes, which will cause an+  -- incongruity with the locally reified declaration (which would lack an+  -- explicit forall).+  r1 :: forall a. a -> a   r1 x = x    class R2 a b where@@ -406,12 +452,50 @@    type R20 = Bool #if __GLASGOW_HASKELL__ >= 707-  type family R21 (a :: k) (b :: k) :: k where R21 a b = b+  type family R21 (a :: k) (b :: k) :: k where+#if __GLASGOW_HASKELL__ >= 801+    R21 (a :: k) (b :: k) = b+#else+    -- Due to GHC Trac #12646, R21 will get reified without kind signatures on+    -- a and b on older GHCs, so we must reflect that here.+    R21 a b = b #endif+#endif   class XXX a where     r22 :: a -> a     r22 = id   -- test #32 +#if __GLASGOW_HASKELL__ >= 801+  pattern Point :: Int -> Int -> (Int, Int)+  pattern Point{x, y} = (x, y)++  data T a where+    MkT :: Eq b => a -> b -> T a++  foo :: Show a => a -> Bool+  foo x = show x == "foo"++  pattern P :: Show a => Eq b => b -> T a+  pattern P x <- MkT (foo -> True) x++  pattern HeadC :: a -> [a]+  pattern HeadC x <- x:_ where+    HeadC x = [x]++  class LL f where+    llMeth :: f a -> ()++  instance LL [] where+    llMeth _ = ()++  pattern LLMeth :: LL f => f a+  pattern LLMeth <- (llMeth -> ())++  {-# COMPLETE LLMeth :: [] #-}++  llEx :: [a] -> Int+  llEx LLMeth = 5+#endif   |]  reifyDecsNames :: [Name]@@ -436,6 +520,11 @@      |]   , [| let foo [] = True            foo _  = False in (foo [], foo "hi") |]+#if __GLASGOW_HASKELL__ >= 801+  , [| let foo ([] :: String) = True+           foo (_  :: String) = False+        in foo "hello" |]+#endif   ]  -- These foralls are needed because of bug trac9262, fixed in ghc-7.10.@@ -470,6 +559,9 @@              , test20_asp              , test21_wildp              , test22_listp+#if __GLASGOW_HASKELL__ >= 801+             , test23_sigp+#endif              , test24_fun              , test25_fun2              , test26_forall@@ -486,4 +578,10 @@              , test38_pred2              , test39_eq #endif+#if __GLASGOW_HASKELL__ >= 801+             , test41_typeapps+             , test42_scoped_tvs+             , test43_ubx_sums+#endif+             , test44_let_pragma              ]

@@ -1,11 +1,11 @@ name:           th-desugar-version:        1.6+version:        1.7 cabal-version:  >= 1.10 synopsis:       Functions to desugar Template Haskell-homepage:       http://www.cis.upenn.edu/~eir/packages/th-desugar+homepage:       https://github.com/goldfirere/th-desugar category:       Template Haskell-author:         Richard Eisenberg <eir@cis.upenn.edu>-maintainer:     Richard Eisenberg <eir@cis.upenn.edu>+author:         Richard Eisenberg <rae@cs.brynmawr.edu>+maintainer:     Richard Eisenberg <rae@cs.brynmawr.edu>, Ryan Scott <ryan.gl.scott@gmail.com> bug-reports:    https://github.com/goldfirere/th-desugar/issues stability:      experimental extra-source-files: README.md, CHANGES.md@@ -26,7 +26,7 @@ source-repository this   type:     git   location: https://github.com/goldfirere/th-desugar.git-  tag:      v1.6+  tag:      v1.7  library   build-depends:@@ -53,7 +53,7 @@  test-suite spec   type:               exitcode-stdio-1.0-  ghc-options:        -Wall -main-is Run+  ghc-options:        -Wall   default-language:   Haskell2010   default-extensions: TemplateHaskell   hs-source-dirs:     Test