th-desugar 1.4.2.1 → 1.5

raw patch · 14 files changed

+1373/−442 lines, 14 filesdep +th-liftdep ~basedep ~hspecdep ~template-haskellPVP ok

version bump matches the API change (PVP)

Dependencies added: th-lift

Dependency ranges changed: base, hspec, template-haskell

API changes (from Hackage documentation)

Files

• CHANGES.md +21/−3
• Language/Haskell/TH/Desugar.hs +28/−3
• Language/Haskell/TH/Desugar/Core.hs +78/−48
• Language/Haskell/TH/Desugar/Expand.hs +80/−28
• Language/Haskell/TH/Desugar/Lift.hs +16/−230
• Language/Haskell/TH/Desugar/Match.hs +393/−0
• Language/Haskell/TH/Desugar/Reify.hs +367/−0
• Language/Haskell/TH/Desugar/Sweeten.hs +28/−2
• Language/Haskell/TH/Desugar/Util.hs +149/−103
• Test/Dec.hs +5/−1
• Test/DsDec.hs +7/−2
• Test/Run.hs +86/−11
• Test/Splices.hs +104/−4
• th-desugar.cabal +11/−7

@@ -1,6 +1,24 @@-Version 1.4.2.1-----------------* Fix compilation error with updated HSpec.+Version 1.5+-----------+* There is now a facility to register a list of `Dec` that internal reification+  should use when necessary. This avoids the user needing to break up their+  definition across different top-level splices. See `withLocalDeclarations`.+  This has a side effect of changing the `Quasi` typeclass constraint on many+  functions to be the new `DsMonad` constraint. Happily, there are `DsMonad`+  instances for `Q` and `IO`, the two normal inhabitants of `Quasi`.++* "Match flattening" is implemented! The functions `scExp` and `scLetDec` remove+  any nested pattern matches.++* More is now exported from `Language.Haskell.TH.Desugar` for ease of use.++* `expand` can now expand closed type families! It still requires that the+  type to expand contain no type variables.++* Support for standalone-deriving and default signatures in GHC 7.10.+  This means that there are now two new constructors for `DDec`.++* Support for `static` expressions, which are new in GHC 7.10.  Version 1.4.2 -------------

@@ -42,14 +42,34 @@   PatM, dsPred, dsPat, dsDec, dsLetDec,   dsMatches, dsBody, dsGuards, dsDoStmts, dsComp, dsClauses,  +  -- * Converting desugared AST back to TH AST+  module Language.Haskell.TH.Desugar.Sweeten,+  +  -- * Expanding type synonyms+  expand, expandType,++  -- * Reification+  reifyWithWarning,++  -- | The following definitions allow you to register a list of+  -- @Dec@s to be used in reification queries.+  withLocalDeclarations, dsReify, reifyWithLocals_maybe, reifyWithLocals,+  DsMonad(..), DsM,++  -- * Nested pattern flattening+  scExp, scLetDec,+   -- * Utility functions   applyDExp, applyDType,-  dPatToDExp, removeWilds, reifyWithWarning,+  dPatToDExp, removeWilds,   getDataD, dataConNameToDataName, dataConNameToCon,   nameOccursIn, allNamesIn, flattenDValD, getRecordSelectors,   mkTypeName, mkDataName, newUniqueName,   mkTupleDExp, mkTupleDPat, maybeDLetE, maybeDCaseE,-+  substTy,+  tupleDegree_maybe, tupleNameDegree_maybe,+  unboxedTupleDegree_maybe, unboxedTupleNameDegree_maybe,+     -- ** Extracting bound names   extractBoundNamesStmt, extractBoundNamesDec, extractBoundNamesPat   ) where@@ -58,9 +78,14 @@ import Language.Haskell.TH.Desugar.Util import Language.Haskell.TH.Desugar.Sweeten import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Desugar.Reify+import Language.Haskell.TH.Desugar.Expand+import Language.Haskell.TH.Desugar.Match  import qualified Data.Set as S+#if __GLASGOW_HASKELL__ < 709 import Data.Foldable ( foldMap )+#endif import Prelude hiding ( exp )  -- | This class relates a TH type with its th-desugar type and allows@@ -68,7 +93,7 @@ -- way because `Type` and `Kind` are type synonyms, but they desugar -- to different types. class Desugar th ds | ds -> th where-  desugar :: Quasi q => th -> q ds+  desugar :: DsMonad q => th -> q ds   sweeten :: ds -> th  instance Desugar Exp DExp where

@@ -28,6 +28,7 @@ import GHC.Exts  import Language.Haskell.TH.Desugar.Util+import Language.Haskell.TH.Desugar.Reify  -- | Corresponds to TH's @Exp@ type. Note that @DLamE@ takes names, not patterns. data DExp = DVarE Name@@ -38,6 +39,7 @@           | DCaseE DExp [DMatch]           | DLetE [DLetDec] DExp           | DSigE DExp DType+          | DStaticE DExp           deriving (Show, Typeable, Data)  @@ -118,6 +120,8 @@           | DTySynInstD Name DTySynEqn           | DClosedTypeFamilyD Name [DTyVarBndr] (Maybe DKind) [DTySynEqn]           | DRoleAnnotD Name [Role]+          | DStandaloneDerivD DCxt DType+          | DDefaultSigD Name DType           deriving (Show, Typeable, Data)  -- | Corresponds to TH's @Con@ type.@@ -147,6 +151,7 @@              | DSpecialiseInstP DType              | DRuleP String [DRuleBndr] DExp DExp Phases              | DAnnP AnnTarget DExp+             | DLineP Int String              deriving (Show, Typeable, Data)  -- | Corresponds to TH's @RuleBndr@ type.@@ -185,7 +190,7 @@ type DInstanceDec = DDec -- ^ Guaranteed to be an instance declaration  -- | Desugar an expression-dsExp :: Quasi q => Exp -> q DExp+dsExp :: DsMonad q => Exp -> q DExp dsExp (VarE n) = return $ DVarE n dsExp (ConE n) = return $ DConE n dsExp (LitE lit) = return $ DLitE lit@@ -253,7 +258,7 @@   first_name <- case field_exps of                   ((name, _) : _) -> return name                   _ -> impossible "Record update with no fields listed."-  info <- reifyWithWarning first_name+  info <- reifyWithLocals first_name   applied_type <- case info of                     VarI _name ty _m_dec _fixity -> extract_first_arg ty                     _ -> impossible "Record update with an invalid field name."@@ -262,41 +267,52 @@   let filtered_cons = filter_cons_with_names cons (map fst field_exps)   exp' <- dsExp exp   matches <- mapM con_to_dmatch filtered_cons-  return $ DCaseE exp' (matches ++ [error_match])+  let all_matches+        | length filtered_cons == length cons = matches+        | otherwise                           = matches ++ [error_match]+  return $ DCaseE exp' all_matches   where-    extract_first_arg :: Quasi q => Type -> q Type+    extract_first_arg :: DsMonad q => Type -> q Type     extract_first_arg (AppT (AppT ArrowT arg) _) = return arg     extract_first_arg (ForallT _ _ t) = extract_first_arg t     extract_first_arg (SigT t _) = extract_first_arg t     extract_first_arg _ = impossible "Record selector not a function." -    extract_type_name :: Quasi q => Type -> q Name+    extract_type_name :: DsMonad q => Type -> q Name     extract_type_name (AppT t1 _) = extract_type_name t1     extract_type_name (SigT t _) = extract_type_name t     extract_type_name (ConT n) = return n     extract_type_name _ = impossible "Record selector domain not a datatype."          filter_cons_with_names cons field_names =-      filter (\case RecC _con_name args -> let con_field_names = map fst_of_3 args in-                                           all (`elem` con_field_names) field_names-                    _ -> False) cons+      filter has_names cons+      where+        has_names (RecC _con_name args) =+          let con_field_names = map fst_of_3 args in+          all (`elem` con_field_names) field_names+        has_names (ForallC _ _ c) = has_names c+        has_names _               = False -    con_to_dmatch :: Quasi q => Con -> q DMatch+    con_to_dmatch :: DsMonad q => Con -> q DMatch     con_to_dmatch (RecC con_name args) = do       let con_field_names = map fst_of_3 args       field_var_names <- mapM (newUniqueName . nameBase) con_field_names       DMatch (DConPa con_name (map DVarPa field_var_names)) <$>              (foldl DAppE (DConE con_name) <$>                     (reorderFields args field_exps (map DVarE field_var_names)))+    con_to_dmatch (ForallC _ _ c) = con_to_dmatch c     con_to_dmatch _ = impossible "Internal error within th-desugar."      error_match = DMatch DWildPa (DAppE (DVarE 'error)-                    (DLitE (StringL "Non-exhaustive patterns in record update")))+                   (DLitE (StringL "Non-exhaustive patterns in record update")))      fst_of_3 (x, _, _) = x+#if __GLASGOW_HASKELL__ >= 709+dsExp (StaticE exp) = DStaticE <$> dsExp exp+#endif  -- | Desugar a lambda expression, where the body has already been desugared-dsLam :: Quasi q => [Pat] -> DExp -> q DExp+dsLam :: DsMonad q => [Pat] -> DExp -> q DExp dsLam pats exp   | Just names <- mapM stripVarP_maybe pats   = return $ DLamE names exp@@ -308,13 +324,13 @@        return $ DLamE arg_names (DCaseE scrutinee [match])  -- | Desugar a list of matches for a @case@ statement-dsMatches :: Quasi q+dsMatches :: DsMonad q           => Name     -- ^ Name of the scrutinee, which must be a bare var           -> [Match]  -- ^ Matches of the @case@ statement           -> q [DMatch] dsMatches scr = go   where-    go :: Quasi q => [Match] -> q [DMatch]+    go :: DsMonad q => [Match] -> q [DMatch]     go [] = return []     go (Match pat body where_decs : rest) = do       rest' <- go rest@@ -327,7 +343,7 @@       else return (DMatch pat' exp'' : rest')  -- | Desugar a @Body@-dsBody :: Quasi q+dsBody :: DsMonad q        => Body      -- ^ body to desugar        -> [Dec]     -- ^ "where" declarations        -> DExp      -- ^ what to do if the guards don't match@@ -348,7 +364,7 @@ maybeDCaseE _   scrut matches = DCaseE scrut matches  -- | Desugar guarded expressions-dsGuards :: Quasi q+dsGuards :: DsMonad q          => [(Guard, Exp)]  -- ^ Guarded expressions          -> DExp            -- ^ What to do if none of the guards match          -> q DExp@@ -361,7 +377,7 @@   dsGuardStmts stmts success failure  -- | Desugar the @Stmt@s in a guard-dsGuardStmts :: Quasi q+dsGuardStmts :: DsMonad q              => [Stmt]  -- ^ The @Stmt@s to desugar              -> DExp    -- ^ What to do if the @Stmt@s yield success              -> DExp    -- ^ What to do if the @Stmt@s yield failure@@ -394,7 +410,7 @@ dsGuardStmts (ParS _ : _) _ _ = impossible "Parallel comprehension in a pattern guard."  -- | Desugar the @Stmt@s in a @do@ expression-dsDoStmts :: Quasi q => [Stmt] -> q DExp+dsDoStmts :: DsMonad q => [Stmt] -> q DExp dsDoStmts [] = impossible "do-expression ended with something other than bare statement." dsDoStmts [NoBindS exp] = dsExp exp dsDoStmts (BindS pat exp : rest) = do@@ -409,7 +425,7 @@ dsDoStmts (ParS _ : _) = impossible "Parallel comprehension in a do-statement."  -- | Desugar the @Stmt@s in a list or monad comprehension-dsComp :: Quasi q => [Stmt] -> q DExp+dsComp :: DsMonad q => [Stmt] -> q DExp dsComp [] = impossible "List/monad comprehension ended with something other than a bare statement." dsComp [NoBindS exp] = DAppE (DVarE 'return) <$> dsExp exp dsComp (BindS pat exp : rest) = do@@ -429,7 +445,7 @@ -- | Desugar the contents of a parallel comprehension. --   Returns a @Pat@ containing a tuple of all bound variables and an expression --   to produce the values for those variables-dsParComp :: Quasi q => [[Stmt]] -> q (Pat, DExp)+dsParComp :: DsMonad q => [[Stmt]] -> q (Pat, DExp) dsParComp [] = impossible "Empty list of parallel comprehension statements." dsParComp [r] = do   let rv = foldMap extractBoundNamesStmt r@@ -454,14 +470,14 @@  -- | Desugar a pattern, along with processing a (desugared) expression that -- is the entire scope of the variables bound in the pattern.-dsPatOverExp :: Quasi q => Pat -> DExp -> q (DPat, DExp)+dsPatOverExp :: DsMonad q => Pat -> DExp -> q (DPat, DExp) dsPatOverExp pat exp = do   (pat', vars) <- runWriterT $ dsPat pat   let name_decs = uncurry (zipWith (DValD . DVarPa)) $ unzip vars   return (pat', maybeDLetE name_decs exp)  -- | Desugar multiple patterns. Like 'dsPatOverExp'.-dsPatsOverExp :: Quasi q => [Pat] -> DExp -> q ([DPat], DExp)+dsPatsOverExp :: DsMonad q => [Pat] -> DExp -> q ([DPat], DExp) dsPatsOverExp pats exp = do   (pats', vars) <- runWriterT $ mapM dsPat pats   let name_decs = uncurry (zipWith (DValD . DVarPa)) $ unzip vars@@ -469,7 +485,7 @@  -- | Desugar a pattern, returning a list of (Name, DExp) pairs of extra -- variables that must be bound within the scope of the pattern-dsPatX :: Quasi q => Pat -> q (DPat, [(Name, DExp)])+dsPatX :: DsMonad q => Pat -> q (DPat, [(Name, DExp)]) dsPatX = runWriterT . dsPat  -- | Desugaring a pattern also returns the list of variables bound in as-patterns@@ -478,7 +494,7 @@ type PatM q = WriterT [(Name, DExp)] q  -- | Desugar a pattern.-dsPat :: Quasi q => Pat -> PatM q DPat+dsPat :: DsMonad q => Pat -> PatM q DPat dsPat (LitP lit) = return $ DLitPa lit dsPat (VarP n) = return $ DVarPa n dsPat (TupP pats) = DConPa (tupleDataName (length pats)) <$> mapM dsPat pats@@ -528,7 +544,7 @@  -- | Remove all wildcards from a pattern, replacing any wildcard with a fresh --   variable-removeWilds :: Quasi q => DPat -> q DPat+removeWilds :: DsMonad q => DPat -> q DPat removeWilds p@(DLitPa _) = return p removeWilds p@(DVarPa _) = return p removeWilds (DConPa con_name pats) = DConPa con_name <$> mapM removeWilds pats@@ -537,7 +553,7 @@ removeWilds DWildPa = DVarPa <$> newUniqueName "wild"  -- | Desugar @Info@-dsInfo :: Quasi q => Info -> q DInfo+dsInfo :: DsMonad q => Info -> q DInfo dsInfo (ClassI dec instances) = do   [ddec]     <- dsDec dec   dinstances <- dsDecs instances@@ -563,7 +579,7 @@   impossible $ "Declaration supplied with variable: " ++ show name dsInfo (TyVarI name ty) = DTyVarI name <$> dsKind ty -fixBug8884ForFamilies :: Quasi q => DDec -> q (DDec, Int)+fixBug8884ForFamilies :: DsMonad q => DDec -> q (DDec, Int) #if __GLASGOW_HASKELL__ < 708 fixBug8884ForFamilies (DFamilyD flav name tvbs m_kind) = do   let num_args = length tvbs@@ -577,7 +593,7 @@ fixBug8884ForFamilies dec =   impossible $ "Reifying yielded a FamilyI with a non-family Dec: " ++ show dec -remove_arrows :: Quasi q => Int -> DKind -> q DKind+remove_arrows :: DsMonad q => Int -> DKind -> q DKind remove_arrows 0 k = return k remove_arrows n (DArrowK _ k) = remove_arrows (n-1) k remove_arrows _ _ =@@ -602,11 +618,11 @@ #endif  -- | Desugar arbitrary @Dec@s-dsDecs :: Quasi q => [Dec] -> q [DDec]+dsDecs :: DsMonad q => [Dec] -> q [DDec] dsDecs = concatMapM dsDec  -- | Desugar a single @Dec@, perhaps producing multiple 'DDec's-dsDec :: Quasi q => Dec -> q [DDec]+dsDec :: DsMonad q => Dec -> q [DDec] dsDec d@(FunD {}) = (fmap . map) DLetDec $ dsLetDec d dsDec d@(ValD {}) = (fmap . map) DLetDec $ dsLetDec d dsDec (DataD cxt n tvbs cons derivings) =@@ -647,13 +663,19 @@                                   <*> mapM dsTySynEqn eqns) dsDec (RoleAnnotD n roles) = return [DRoleAnnotD n roles] #endif-             +#if __GLASGOW_HASKELL__ >= 709+dsDec (StandaloneDerivD cxt ty) = (:[]) <$> (DStandaloneDerivD <$> dsCxt cxt+                                                               <*> dsType ty)+dsDec (DefaultSigD n ty) = (:[]) <$> (DDefaultSigD n <$> dsType ty)+#endif++   -- | Desugar @Dec@s that can appear in a let expression-dsLetDecs :: Quasi q => [Dec] -> q [DLetDec]+dsLetDecs :: DsMonad q => [Dec] -> q [DLetDec] dsLetDecs = concatMapM dsLetDec  -- | Desugar a single @Dec@, perhaps producing multiple 'DLetDec's-dsLetDec :: Quasi q => Dec -> q [DLetDec]+dsLetDec :: DsMonad q => Dec -> q [DLetDec] dsLetDec (FunD name clauses) = do   clauses' <- dsClauses name clauses   return [DFunD name clauses']@@ -672,7 +694,7 @@ dsLetDec _dec = impossible "Illegal declaration in let expression."  -- | Desugar a single @Con@.-dsCon :: Quasi q => Con -> q DCon+dsCon :: DsMonad q => Con -> q DCon dsCon (NormalC n stys) = DCon [] [] n <$> (DNormalC <$> mapM (liftSndM dsType) stys) dsCon (RecC n vstys) = DCon [] [] n <$> (DRecC <$> mapM (liftThdOf3M dsType) vstys) dsCon (InfixC (s1, ty1) n (s2, ty2)) = do@@ -686,12 +708,12 @@   return $ DCon (dtvbs ++ dtvbs') (dcxt ++ dcxt') n fields  -- | Desugar a @Foreign@.-dsForeign :: Quasi q => Foreign -> q DForeign+dsForeign :: DsMonad q => Foreign -> q DForeign dsForeign (ImportF cc safety str n ty) = DImportF cc safety str n <$> dsType ty dsForeign (ExportF cc str n ty)        = DExportF cc str n <$> dsType ty  -- | Desugar a @Pragma@.-dsPragma :: Quasi q => Pragma -> q DPragma+dsPragma :: DsMonad q => Pragma -> q DPragma dsPragma (InlineP n inl rm phases)       = return $ DInlineP n inl rm phases dsPragma (SpecialiseP n ty m_inl phases) = DSpecialiseP n <$> dsType ty                                                           <*> pure m_inl@@ -704,20 +726,23 @@ #if __GLASGOW_HASKELL__ >= 707 dsPragma (AnnP target exp)               = DAnnP target <$> dsExp exp #endif+#if __GLASGOW_HASKELL__ >= 709+dsPragma (LineP n str)                   = return $ DLineP n str+#endif  -- | Desugar a @RuleBndr@.-dsRuleBndr :: Quasi q => RuleBndr -> q DRuleBndr+dsRuleBndr :: DsMonad q => RuleBndr -> q DRuleBndr dsRuleBndr (RuleVar n)         = return $ DRuleVar n dsRuleBndr (TypedRuleVar n ty) = DTypedRuleVar n <$> dsType ty  #if __GLASGOW_HASKELL__ >= 707 -- | Desugar a @TySynEqn@. (Available only with GHC 7.8+)-dsTySynEqn :: Quasi q => TySynEqn -> q DTySynEqn+dsTySynEqn :: DsMonad q => TySynEqn -> q DTySynEqn dsTySynEqn (TySynEqn lhs rhs) = DTySynEqn <$> mapM dsType lhs <*> dsType rhs #endif  -- | Desugar clauses to a function definition-dsClauses :: Quasi q+dsClauses :: DsMonad q           => Name         -- ^ Name of the function           -> [Clause]     -- ^ Clauses to desugar           -> q [DClause]@@ -737,7 +762,7 @@               (DCaseE scrutinee <$> foldrM (clause_to_dmatch scrutinee) [] clauses)   return [clause]   where-    clause_to_dmatch :: Quasi q => DExp -> Clause -> [DMatch] -> q [DMatch]+    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@@ -750,7 +775,7 @@       else return (match : failure_matches)  -- | Desugar a type-dsType :: Quasi q => Type -> q DType+dsType :: DsMonad q => Type -> q DType dsType (ForallT tvbs preds ty) = DForallT <$> mapM dsTvb tvbs <*> dsCxt preds <*> dsType ty dsType (AppT t1 t2) = DAppT <$> dsType t1 <*> dsType t2 dsType (SigT ty ki) = DSigT <$> dsType ty <*> dsKind ki@@ -776,16 +801,16 @@ #endif  -- | Desugar a @TyVarBndr@-dsTvb :: Quasi q => TyVarBndr -> q DTyVarBndr+dsTvb :: DsMonad q => TyVarBndr -> q DTyVarBndr dsTvb (PlainTV n) = return $ DPlainTV n dsTvb (KindedTV n k) = DKindedTV n <$> dsKind k  -- | Desugar a @Cxt@-dsCxt :: Quasi q => Cxt -> q DCxt+dsCxt :: DsMonad q => Cxt -> q DCxt dsCxt = concatMapM dsPred  -- | Desugar a @Pred@, flattening any internal tuples-dsPred :: Quasi q => Pred -> q DCxt+dsPred :: DsMonad q => Pred -> q DCxt #if __GLASGOW_HASKELL__ < 709 dsPred (ClassP n tys) = do   ts' <- mapM dsType tys@@ -830,7 +855,7 @@ #endif  -- | Desugar a kind-dsKind :: Quasi q => Kind -> q DKind+dsKind :: DsMonad q => Kind -> q DKind dsKind (ForallT tvbs cxt ki)   | [] <- cxt   , Just names <- mapM stripPlainTV_maybe tvbs@@ -863,15 +888,20 @@ #if __GLASGOW_HASKELL__ >= 709 dsKind EqualityT = impossible "(~) used in a kind." #endif-                       ++-- | Like 'reify', but safer and desugared. Uses local declarations where+-- available.+dsReify :: DsMonad q => Name -> q (Maybe DInfo)+dsReify = traverse dsInfo <=< reifyWithLocals_maybe+   -- create a list of expressions in the same order as the fields in the first argument -- but with the values as given in the second argument -- if a field is missing from the second argument, use the corresponding expression -- from the third argument-reorderFields :: Quasi q => [VarStrictType] -> [FieldExp] -> [DExp] -> q [DExp]+reorderFields :: DsMonad q => [VarStrictType] -> [FieldExp] -> [DExp] -> q [DExp] reorderFields = reorderFields' dsExp -reorderFieldsPat :: Quasi q => [VarStrictType] -> [FieldPat] -> PatM q [DPat]+reorderFieldsPat :: DsMonad q => [VarStrictType] -> [FieldPat] -> PatM q [DPat] reorderFieldsPat field_decs field_pats =   reorderFields' dsPat field_decs field_pats (repeat DWildPa) @@ -909,7 +939,7 @@ mkTuplePat pats = ConP (tupleDataName (length pats)) pats  -- | Is this pattern guaranteed to match?-isUniversalPattern :: Quasi q => DPat -> q Bool+isUniversalPattern :: DsMonad q => DPat -> q Bool isUniversalPattern (DLitPa {}) = return False isUniversalPattern (DVarPa {}) = return True isUniversalPattern (DConPa con_name pats) = do

@@ -26,21 +26,24 @@   ) where  import qualified Data.Map as M+import qualified Data.Set as S import Control.Monad import Control.Applicative import Language.Haskell.TH hiding (cxt) import Language.Haskell.TH.Syntax ( Quasi(..) ) import Data.Data import Data.Generics-import Data.Monoid+import Data.List+import qualified Data.Traversable as T  import Language.Haskell.TH.Desugar.Core import Language.Haskell.TH.Desugar.Util import Language.Haskell.TH.Desugar.Sweeten+import Language.Haskell.TH.Desugar.Reify  -- | Expands all type synonyms in a desugared type. Also expands open type family -- applications, as long as the arguments have no free variables.-expandType :: Quasi q => DType -> q DType+expandType :: DsMonad q => DType -> q DType expandType = go []   where     go [] (DForallT tvbs cxt ty) =@@ -57,7 +60,7 @@     go args ty = return $ foldl DAppT ty args  -- | Expands all type synonyms in a desugared predicate.-expandPred :: Quasi q => DPred -> q DPred+expandPred :: DsMonad q => DPred -> q DPred expandPred = go []   where     go args (DAppPr p t) = do@@ -72,13 +75,14 @@     go args p = return $ foldl DAppPr p args  -- | Expand a constructor with given arguments-expandCon :: Quasi q+expandCon :: DsMonad q           => Name     -- ^ Tycon name           -> [DType]  -- ^ Arguments           -> q DType  -- ^ Expanded type expandCon n args = do-  info <- reifyWithWarning n+  info <- reifyWithLocals n   dinfo <- dsInfo info+  args_ok <- allM no_tyvars_tyfams args   case dinfo of     DTyConI (DTySynD _n tvbs rhs) _       |  length args >= length tvbs   -- this should always be true!@@ -90,7 +94,7 @@      DTyConI (DFamilyD TypeFam _n tvbs _mkind) _       |  length args >= length tvbs   -- this should always be true!-      ,  all no_tyvars args+      ,  args_ok       -> do         let (syn_args, rest_args) = splitAtList tvbs args         -- need to get the correct instance@@ -98,42 +102,90 @@         dinsts <- dsDecs insts         case dinsts of           [DTySynInstD _n (DTySynEqn lhs rhs)] -> do-            let subst = mconcat $ zipWith build_subst lhs syn_args+            subst <-+              expectJustM "Impossible: reification returned a bogus instance" $+              merge_maps $ zipWith build_subst lhs syn_args             ty <- substTy subst rhs             ty' <- expandType ty             return $ foldl DAppT ty' rest_args           _ -> return $ foldl DAppT (DConT n) args-    ++    DTyConI (DClosedTypeFamilyD _n tvbs _resk eqns) _+      |  length args >= length tvbs+      ,  args_ok+      -> do+        let (syn_args, rest_args) = splitAtList tvbs args+        rhss <- mapMaybeM (check_eqn syn_args) eqns+        case rhss of+          (rhs : _) -> do+            rhs' <- expandType rhs+            return $ foldl DAppT rhs' rest_args+          [] -> return $ foldl DAppT (DConT n) args++      where+         -- returns the substed rhs+        check_eqn :: DsMonad q => [DType] -> DTySynEqn -> q (Maybe DType)+        check_eqn arg_tys (DTySynEqn lhs rhs) = do+          let m_subst = merge_maps $ zipWith build_subst lhs arg_tys+          T.mapM (flip substTy rhs) m_subst+               _ -> return $ foldl DAppT (DConT n) args    where-    no_tyvars :: Data a => a -> Bool-    no_tyvars = everything (&&) (mkQ True no_tyvar)+    no_tyvars_tyfams :: (DsMonad q, Data a) => a -> q Bool+    no_tyvars_tyfams = everything (liftM2 (&&)) (mkQ (return True) no_tyvar_tyfam) -    no_tyvar :: DType -> Bool-    no_tyvar (DVarT _) = False-    no_tyvar t         = gmapQl (&&) True no_tyvars t+    no_tyvar_tyfam :: DsMonad q => DType -> q Bool+    no_tyvar_tyfam (DVarT _) = return False+    no_tyvar_tyfam (DConT con_name) = do+      m_info <- dsReify con_name+      return $ case m_info of+        Nothing -> False   -- we don't know anything. False is safe.+        Just (DTyConI (DFamilyD {}) _)           -> False+        Just (DTyConI (DClosedTypeFamilyD {}) _) -> False+        _                                        -> True+    no_tyvar_tyfam t = gmapQl (liftM2 (&&)) (return True) no_tyvars_tyfams t -    build_subst :: DType -> DType -> M.Map Name DType-    build_subst (DVarT var_name) arg = M.singleton var_name arg-      -- ignore kind signatures; any kind constraints are already-      -- handled in reifyInstances+    build_subst :: DType -> DType -> Maybe (M.Map Name DType)+    build_subst (DVarT var_name) arg = Just $ M.singleton var_name arg+      -- if a pattern has a kind signature, it's really easy to get+      -- this wrong.+    build_subst (DSigT {}) _ = Nothing+      -- but we can safely ignore kind signatures on the target     build_subst pat (DSigT ty _ki) = build_subst pat ty-    build_subst (DSigT ty _ki) arg = build_subst ty arg     build_subst (DForallT {}) _ =       error "Impossible: forall-quantified pattern to type family"       -- reifyInstances should fail if an argument is forall-quantified.     build_subst _ (DForallT {}) =       error "Impossible: forall-quantified argument to type family"     build_subst (DAppT pat1 pat2) (DAppT arg1 arg2) =-      build_subst pat1 arg1 <> build_subst pat2 arg2-    build_subst (DConT _pat_con) (DConT _arg_con) = mempty-    build_subst DArrowT DArrowT = mempty-    build_subst (DLitT _pat_lit) (DLitT _arg_lit) = mempty-    build_subst pat arg = error $ "Impossible: reifyInstances succeeded but unification failed; pat=" ++ show pat ++ "; arg=" ++ show arg+      merge_maps [build_subst pat1 arg1, build_subst pat2 arg2]+    build_subst (DConT pat_con) (DConT arg_con)+      | pat_con == arg_con = Just M.empty+    build_subst DArrowT DArrowT = Just M.empty+    build_subst (DLitT pat_lit) (DLitT arg_lit)+      | pat_lit == arg_lit = Just M.empty+    build_subst _ _ = Nothing +    merge_maps :: [Maybe (M.Map Name DType)] -> Maybe (M.Map Name DType)+    merge_maps = foldl' merge_map1 (Just M.empty)++    merge_map1 :: Maybe (M.Map Name DType) -> Maybe (M.Map Name DType)+               -> Maybe (M.Map Name DType)+    merge_map1 ma mb = do+      a <- ma+      b <- mb+      let shared_key_set = M.keysSet a `S.intersection` M.keysSet b+          matches_up     = S.foldr (\name -> ((a M.! name) `geq` (b M.! name) &&))+                                   True shared_key_set+      if matches_up then return (a `M.union` b) else Nothing++    allM :: Monad m => (a -> m Bool) -> [a] -> m Bool+    allM f = foldM (\b x -> (b &&) `liftM` f x) True++ -- | Capture-avoiding substitution on types-substTy :: Quasi q => M.Map Name DType -> DType -> q DType+substTy :: DsMonad q => M.Map Name DType -> DType -> q DType substTy vars (DForallT tvbs cxt ty) =   substTyVarBndrs vars tvbs $ \vars' tvbs' -> do     cxt' <- mapM (substPred vars') cxt@@ -150,7 +202,7 @@   = return $ DVarT n substTy _ ty = return ty -substTyVarBndrs :: Quasi q => M.Map Name DType -> [DTyVarBndr]+substTyVarBndrs :: DsMonad q => M.Map Name DType -> [DTyVarBndr]                 -> (M.Map Name DType -> [DTyVarBndr] -> q DType)                 -> q DType substTyVarBndrs vars tvbs thing = do@@ -168,7 +220,7 @@ extractDTvbName (DPlainTV n) = n extractDTvbName (DKindedTV n _) = n -substPred :: Quasi q => M.Map Name DType -> DPred -> q DPred+substPred :: DsMonad q => M.Map Name DType -> DPred -> q DPred substPred vars (DAppPr p t) = DAppPr <$> substPred vars p <*> substTy vars t substPred vars (DSigPr p k) = DSigPr <$> substPred vars p <*> pure k substPred vars (DVarPr n)@@ -179,7 +231,7 @@ substPred _ p = return p  -- | Convert a 'DType' to a 'DPred'-dTypeToDPred :: Quasi q => DType -> q DPred+dTypeToDPred :: DsMonad q => DType -> q DPred dTypeToDPred (DForallT _ _ _) = impossible "Forall-type used as constraint" dTypeToDPred (DAppT t1 t2)   = DAppPr <$> dTypeToDPred t1 <*> pure t2 dTypeToDPred (DSigT ty ki)   = DSigPr <$> dTypeToDPred ty <*> pure ki@@ -192,5 +244,5 @@ -- | Expand all type synonyms and open type families in the desugared abstract -- syntax tree provided. Normally, the first parameter should have a type like -- 'DExp' or 'DLetDec'.-expand :: (Quasi q, Data a) => a -> q a+expand :: (DsMonad q, Data a) => a -> q a expand = everywhereM (mkM expandType >=> mkM expandPred)

@@ -14,243 +14,29 @@ -- ---------------------------------------------------------------------------- -{-# LANGUAGE TemplateHaskell, MagicHash, TypeSynonymInstances, FlexibleInstances #-}+{-# LANGUAGE CPP, TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans #-}  module Language.Haskell.TH.Desugar.Lift () where -import Prelude hiding ( mod, words ) import Language.Haskell.TH.Desugar-import Language.Haskell.TH.Syntax-import Control.Applicative-import GHC.Exts-import GHC.Word--foldApp :: Exp -> [Exp] -> Exp-foldApp = foldl AppE-           -instance Lift DExp where-  lift (DVarE n)      = foldApp (ConE 'DVarE)  <$> sequence [lift n]-  lift (DConE n)      = foldApp (ConE 'DConE)  <$> sequence [lift n]-  lift (DLitE l)      = foldApp (ConE 'DLitE)  <$> sequence [lift l]-  lift (DAppE e1 e2)  = foldApp (ConE 'DAppE)  <$> sequence [lift e1, lift e2]-  lift (DLamE ns e)   = foldApp (ConE 'DLamE)  <$> sequence [lift ns, lift e]-  lift (DCaseE e ms)  = foldApp (ConE 'DCaseE) <$> sequence [lift e, lift ms]-  lift (DLetE decs e) = foldApp (ConE 'DLetE)  <$> sequence [lift decs, lift e]-  lift (DSigE e t)    = foldApp (ConE 'DSigE)  <$> sequence [lift e, lift t]--instance Lift DPat where-  lift (DLitPa l)    = foldApp (ConE 'DLitPa)   <$> sequence [lift l]-  lift (DVarPa n)    = foldApp (ConE 'DVarPa)   <$> sequence [lift n]-  lift (DConPa n ps) = foldApp (ConE 'DConPa)   <$> sequence [lift n, lift ps]-  lift (DTildePa p)  = foldApp (ConE 'DTildePa) <$> sequence [lift p]-  lift (DBangPa p)   = foldApp (ConE 'DBangPa)  <$> sequence [lift p]-  lift DWildPa       = return $ ConE 'DWildPa--instance Lift DType where-  lift (DForallT tvbs cxt t) =-    foldApp (ConE 'DForallT) <$> sequence [lift tvbs, lift cxt, lift t]-  lift (DAppT t1 t2) = foldApp (ConE 'DAppT) <$> sequence [lift t1, lift t2]-  lift (DSigT t k)   = foldApp (ConE 'DSigT) <$> sequence [lift t, lift k]-  lift (DVarT n)     = foldApp (ConE 'DVarT) <$> sequence [lift n]-  lift (DConT n)     = foldApp (ConE 'DConT) <$> sequence [lift n]-  lift DArrowT       = return $ ConE 'DArrowT-  lift (DLitT l)     = foldApp (ConE 'DLitT) <$> sequence [lift l]--instance Lift DKind where-  lift (DForallK ns k) = foldApp (ConE 'DForallK) <$> sequence [lift ns, lift k]-  lift (DVarK n)       = foldApp (ConE 'DVarK)    <$> sequence [lift n]-  lift (DConK n ks)    = foldApp (ConE 'DConK)    <$> sequence [lift n, lift ks]-  lift (DArrowK k1 k2) = foldApp (ConE 'DArrowK)  <$> sequence [lift k1, lift k2]-  lift DStarK          = return $ ConE 'DStarK--instance Lift DPred where-  lift (DAppPr p t) = foldApp (ConE 'DAppPr) <$> sequence [lift p, lift t]-  lift (DSigPr p k) = foldApp (ConE 'DSigPr) <$> sequence [lift p, lift k]-  lift (DVarPr n)   = foldApp (ConE 'DVarPr) <$> sequence [lift n]-  lift (DConPr n)   = foldApp (ConE 'DConPr) <$> sequence [lift n]--instance Lift DTyVarBndr where-  lift (DPlainTV n)    = foldApp (ConE 'DPlainTV)  <$> sequence [lift n]-  lift (DKindedTV n k) = foldApp (ConE 'DKindedTV) <$> sequence [lift n, lift k]--instance Lift DMatch where-  lift (DMatch p e) = foldApp (ConE 'DMatch) <$> sequence [lift p, lift e]--instance Lift DClause where-  lift (DClause ps e) = foldApp (ConE 'DClause) <$> sequence [lift ps, lift e]--instance Lift DLetDec where-  lift (DFunD n cs)  = foldApp (ConE 'DFunD)   <$> sequence [lift n, lift cs]-  lift (DValD p e)   = foldApp (ConE 'DValD)   <$> sequence [lift p, lift e]-  lift (DSigD n t)   = foldApp (ConE 'DSigD)   <$> sequence [lift n, lift t]-  lift (DInfixD f n) = foldApp (ConE 'DInfixD) <$> sequence [lift f, lift n]--instance Lift NewOrData where-  lift Newtype = return $ ConE 'Newtype-  lift Data    = return $ ConE 'Data--instance Lift DDec where-  lift (DLetDec dec) = foldApp (ConE 'DLetDec) <$> sequence [lift dec]-  lift (DDataD nd cxt n tvbs cons derivs) =-    foldApp (ConE 'DDataD) <$> sequence [ lift nd, lift cxt, lift n-                                        , lift tvbs, lift cons, lift derivs ]-  lift (DTySynD n tvbs ty) =-    foldApp (ConE 'DTySynD) <$> sequence [lift n, lift tvbs, lift ty]-  lift (DClassD cxt n tvbs fds decs) =-    foldApp (ConE 'DClassD) <$> sequence [ lift cxt, lift n, lift tvbs-                                         , lift fds, lift decs ]-  lift (DInstanceD cxt ty decs) =-    foldApp (ConE 'DInstanceD) <$> sequence [lift cxt, lift ty, lift decs]-  lift (DForeignD for) = foldApp (ConE 'DForeignD) <$> sequence [lift for]-  lift (DPragmaD prag) = foldApp (ConE 'DPragmaD) <$> sequence [lift prag]-  lift (DFamilyD flav n tvbs res) =-    foldApp (ConE 'DFamilyD) <$> sequence [lift flav, lift n, lift tvbs, lift res]-  lift (DDataInstD nd cxt n tys cons derivs) =-    foldApp (ConE 'DDataInstD) <$> sequence [ lift nd, lift cxt, lift n-                                            , lift tys, lift cons, lift derivs ]-  lift (DTySynInstD n eqn) = foldApp (ConE 'DTySynInstD) <$> sequence [lift n, lift eqn]-  lift (DClosedTypeFamilyD n tvbs res eqns) =-    foldApp (ConE 'DClosedTypeFamilyD) <$> sequence [ lift n, lift tvbs-                                                    , lift res, lift eqns ]-  lift (DRoleAnnotD n rs) =-    foldApp (ConE 'DRoleAnnotD) <$> sequence [lift n, lift rs]--instance Lift DCon where-  lift (DCon tvbs cxt n fields) =-    foldApp (ConE 'DCon) <$> sequence [lift tvbs, lift cxt, lift n, lift fields]--instance Lift DConFields where-  lift (DNormalC stys) = foldApp (ConE 'DNormalC) <$> sequence [lift stys]-  lift (DRecC vstys)   = foldApp (ConE 'DRecC)    <$> sequence [lift vstys]--instance Lift DForeign where-  lift (DImportF cc safe str n ty) =-    foldApp (ConE 'DImportF) <$> sequence [ lift cc, lift safe, lift str-                                          , lift n, lift ty ]-  lift (DExportF cc str n ty) =-    foldApp (ConE 'DExportF) <$> sequence [lift cc, lift str, lift n, lift ty]--instance Lift DPragma where-  lift (DInlineP n i rm phases) =-    foldApp (ConE 'DInlineP) <$> sequence [lift n, lift i, lift rm, lift phases]-  lift (DSpecialiseP n ty m_i phases) =-    foldApp (ConE 'DSpecialiseP) <$> sequence [ lift n, lift ty-                                              , lift m_i, lift phases ]-  lift (DSpecialiseInstP ty) = foldApp (ConE 'DSpecialiseInstP) <$> sequence [lift ty]-  lift (DRuleP str bndrs e1 e2 phases) =-    foldApp (ConE 'DRuleP) <$> sequence [ lift str, lift bndrs, lift e1-                                        , lift e2, lift phases ]-  lift (DAnnP targ e) = foldApp (ConE 'DAnnP) <$> sequence [lift targ, lift e]--instance Lift DRuleBndr where-  lift (DRuleVar n) = foldApp (ConE 'DRuleVar) <$> sequence [lift n]-  lift (DTypedRuleVar n ty) =-    foldApp (ConE 'DTypedRuleVar) <$> sequence [lift n, lift ty]--instance Lift DTySynEqn where-  lift (DTySynEqn lhs rhs) = foldApp (ConE 'DTySynEqn) <$> sequence [lift lhs, lift rhs]-                                 --- Template Haskell liftings--instance Lift OccName where-  lift (OccName n) = foldApp (ConE 'OccName) <$> sequence [lift n]--instance Lift ModName where-  lift (ModName n) = foldApp (ConE 'ModName) <$> sequence [lift n]--instance Lift PkgName where-  lift (PkgName n) = foldApp (ConE 'PkgName) <$> sequence [lift n]--instance Lift NameSpace where-  lift VarName   = return $ ConE 'VarName-  lift DataName  = return $ ConE 'DataName-  lift TcClsName = return $ ConE 'TcClsName--instance Lift NameFlavour where-  lift NameS       = return $ ConE 'NameS-  lift (NameQ mod) = foldApp (ConE 'NameQ) <$> sequence [lift mod]-  lift (NameU n)   = return $ foldApp (ConE 'NameU) [LitE $ IntPrimL $ toInteger $ I# n]-  lift (NameL n)   = return $ foldApp (ConE 'NameL) [LitE $ IntPrimL $ toInteger $ I# n]-  lift (NameG ns pkg mod) =-    foldApp (ConE 'NameG) <$> sequence [lift ns, lift pkg, lift mod]--instance Lift Name where-  lift (Name occ flav) = foldApp (ConE 'Name) <$> sequence [lift occ, lift flav]-                                  -instance Lift Lit where-  lift (CharL ch)          = foldApp (ConE 'CharL)       <$> sequence [lift ch]-  lift (StringL str)       = foldApp (ConE 'StringL)     <$> sequence [lift str]-  lift (IntegerL i)        = foldApp (ConE 'IntegerL)    <$> sequence [lift i]-  lift (RationalL rat)     = foldApp (ConE 'RationalL)   <$> sequence [lift rat]-  lift (IntPrimL i)        = foldApp (ConE 'IntPrimL)    <$> sequence [lift i]-  lift (WordPrimL i)       = foldApp (ConE 'WordPrimL)   <$> sequence [lift i]-  lift (FloatPrimL rat)    = foldApp (ConE 'FloatPrimL)  <$> sequence [lift rat]-  lift (DoublePrimL rat)   = foldApp (ConE 'DoublePrimL) <$> sequence [lift rat]-  lift (StringPrimL words) = foldApp (ConE 'StringPrimL) <$> sequence [lift words]--instance Lift TyLit where-  lift (NumTyLit i) = foldApp (ConE 'NumTyLit) <$> sequence [lift i]-  lift (StrTyLit s) = foldApp (ConE 'StrTyLit) <$> sequence [lift s]--instance Lift Fixity where-  lift (Fixity i dir) = foldApp (ConE 'Fixity) <$> sequence [lift i, lift dir]--instance Lift FixityDirection where-  lift InfixL = return $ ConE 'InfixL-  lift InfixR = return $ ConE 'InfixR-  lift InfixN = return $ ConE 'InfixN--instance Lift Strict where-  lift IsStrict  = return $ ConE 'IsStrict-  lift NotStrict = return $ ConE 'NotStrict-  lift Unpacked  = return $ ConE 'Unpacked--instance Lift Callconv where-  lift CCall   = return $ ConE 'CCall-  lift StdCall = return $ ConE 'StdCall--instance Lift Safety where-  lift Unsafe = return $ ConE 'Unsafe-  lift Safe   = return $ ConE 'Safe-  lift Interruptible = return $ ConE 'Interruptible--instance Lift Inline where-  lift NoInline  = return $ ConE 'NoInline-  lift Inline    = return $ ConE 'Inline-  lift Inlinable = return $ ConE 'Inlinable--instance Lift RuleMatch where-  lift ConLike = return $ ConE 'ConLike-  lift FunLike = return $ ConE 'FunLike--instance Lift Phases where-  lift AllPhases       = return $ ConE 'AllPhases-  lift (FromPhase i)   = foldApp (ConE 'FromPhase)   <$> sequence [lift i]-  lift (BeforePhase i) = foldApp (ConE 'BeforePhase) <$> sequence [lift i]--instance Lift AnnTarget where-  lift ModuleAnnotation    = return $ ConE 'ModuleAnnotation-  lift (TypeAnnotation n)  = foldApp (ConE 'TypeAnnotation)  <$> sequence [lift n]-  lift (ValueAnnotation n) = foldApp (ConE 'ValueAnnotation) <$> sequence [lift n]--instance Lift FunDep where-  lift (FunDep lhs rhs) = foldApp (ConE 'FunDep) <$> sequence [lift lhs, lift rhs]--instance Lift FamFlavour where-  lift TypeFam = return $ ConE 'TypeFam-  lift DataFam = return $ ConE 'DataFam+import Language.Haskell.TH.Lift+import Language.Haskell.TH+#if __GLASGOW_HASKELL__ <= 708+import Data.Word+#endif -instance Lift Role where-  lift NominalR          = return $ ConE 'NominalR-  lift RepresentationalR = return $ ConE 'RepresentationalR-  lift PhantomR          = return $ ConE 'PhantomR-  lift InferR            = return $ ConE 'InferR+$(deriveLiftMany [ ''DExp, ''DPat, ''DType, ''DKind, ''DPred, ''DTyVarBndr+                 , ''DMatch, ''DClause, ''DLetDec, ''DDec, ''DCon+                 , ''DConFields, ''DForeign, ''DPragma, ''DRuleBndr, ''DTySynEqn+                 , ''NewOrData+                 , ''Lit, ''TyLit, ''Fixity, ''FixityDirection, ''Strict+                 , ''Callconv, ''Safety, ''Inline, ''RuleMatch, ''Phases+                 , ''AnnTarget, ''FunDep, ''FamFlavour, ''Role ]) +#if __GLASGOW_HASKELL__ <= 708 -- Other type liftings:                                       -instance Lift Rational where-  lift rat = return $ LitE $ RationalL rat- instance Lift Word8 where-  lift word = return $ foldApp (VarE 'fromInteger) [LitE $ IntegerL (toInteger word)]+  lift word = return $ (VarE 'fromInteger) `AppE` (LitE $ IntegerL (toInteger word))+#endif

@@ -0,0 +1,393 @@+{- Language/Haskell/TH/Desugar/Match.hs++(c) Richard Eisenberg 2013+eir@cis.upenn.edu++Simplifies case statements in desugared TH. After this pass, there are no+more nested patterns.++This code is directly based on the analogous operation as written in GHC.+-}++{-# LANGUAGE CPP, TemplateHaskell #-}++#if __GLASGOW_HASKELL__ <= 708+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}   -- we need Ord Lit. argh.+#endif++module Language.Haskell.TH.Desugar.Match (scExp, scLetDec) where++import Prelude hiding ( fail, exp )++import Control.Applicative+import Control.Monad hiding ( fail )+import qualified Data.Set as S+import qualified Data.Map as Map+import Language.Haskell.TH.Syntax++import Language.Haskell.TH.Desugar.Core+import Language.Haskell.TH.Desugar.Util+import Language.Haskell.TH.Desugar.Reify++-- | Remove all nested pattern-matches within this expression. This also+-- removes all 'DTildePa's and 'DBangPa's. After this is run, every pattern+-- is guaranteed to be either a 'DConPa' with bare variables as arguments,+-- a 'DLitPa', or a 'DWildPa'.+scExp :: DsMonad q => DExp -> q DExp+scExp (DAppE e1 e2) = DAppE <$> scExp e1 <*> scExp e2+scExp (DLamE names exp) = DLamE names <$> scExp exp+scExp (DCaseE scrut matches)+  | DVarE name <- scrut+  = simplCaseExp [name] clauses+  | otherwise+  = do scrut_name <- newUniqueName "scrut"+       case_exp <- simplCaseExp [scrut_name] clauses+       return $ DLetE [DValD (DVarPa scrut_name) scrut] case_exp+  where+    clauses = map match_to_clause matches+    match_to_clause (DMatch pat exp) = DClause [pat] exp++scExp (DLetE decs body) = DLetE <$> mapM scLetDec decs <*> scExp body+scExp (DSigE exp ty) = DSigE <$> scExp exp <*> pure ty+scExp e = return e++-- | Like 'scExp', but for a 'DLetDec'.+scLetDec :: DsMonad q => DLetDec -> q DLetDec+scLetDec (DFunD name clauses@(DClause pats1 _ : _)) = do+  arg_names <- mapM (const (newUniqueName "_arg")) pats1+  clauses' <- mapM sc_clause_rhs clauses+  case_exp <- simplCaseExp arg_names clauses'+  return $ DFunD name [DClause (map DVarPa arg_names) case_exp]+  where+    sc_clause_rhs (DClause pats exp) = DClause pats <$> scExp exp+scLetDec (DValD pat exp) = DValD pat <$> scExp exp+scLetDec dec = return dec++type MatchResult = DExp -> DExp++matchResultToDExp :: MatchResult -> DExp+matchResultToDExp mr = mr failed_pattern_match+  where+    failed_pattern_match = DAppE (DVarE 'error)+                                 (DLitE $ StringL "Pattern-match failure")++simplCaseExp :: DsMonad q+             => [Name]+             -> [DClause]+             -> q DExp+simplCaseExp vars clauses =+  do let eis = [ EquationInfo pats (\_ -> rhs) |+                 DClause pats rhs <- clauses ]+     matchResultToDExp `liftM` simplCase vars eis++data EquationInfo = EquationInfo [DPat] MatchResult  -- like DClause, but with a hole+                            +-- analogous to GHC's match (in deSugar/Match.lhs)+simplCase :: DsMonad q+          => [Name]         -- the names of the scrutinees+          -> [EquationInfo] -- the matches (where the # of pats == length (1st arg))+          -> q MatchResult+simplCase [] clauses = return (foldr1 (.) match_results)+  where+    match_results = [ mr | EquationInfo _ mr <- clauses ]+simplCase vars@(v:_) clauses = do+  (aux_binds, tidy_clauses) <- mapAndUnzipM (tidyClause v) clauses+  let grouped = groupClauses tidy_clauses+  match_results <- match_groups grouped+  return (adjustMatchResult (foldr (.) id aux_binds) $+          foldr1 (.) match_results)+  where+    match_groups :: DsMonad q => [[(PatGroup, EquationInfo)]] -> q [MatchResult]+    match_groups [] = matchEmpty v+    match_groups gs = mapM match_group gs++    match_group :: DsMonad q => [(PatGroup, EquationInfo)] -> q MatchResult+    match_group [] = error "Internal error in th-desugar (match_group)"+    match_group eqns@((group,_) : _) =+      case group of+        PgCon _ -> matchConFamily vars (subGroup [(c,e) | (PgCon c, e) <- eqns])+        PgLit _ -> matchLiterals  vars (subGroup [(l,e) | (PgLit l, e) <- eqns])+        PgBang  -> matchBangs     vars (drop_group eqns)+        PgAny   -> matchVariables vars (drop_group eqns)++    drop_group = map snd++#if __GLASGOW_HASKELL__ <= 708+deriving instance Ord Lit   -- ew. necessary for `subGroup`+#endif++-- analogous to GHC's tidyEqnInfo+tidyClause :: DsMonad q => Name -> EquationInfo -> q (DExp -> DExp, EquationInfo)+tidyClause _ (EquationInfo [] _) =+  error "Internal error in th-desugar: no patterns in tidyClause."+tidyClause v (EquationInfo (pat : pats) body) = do+  (wrap, pat') <- tidy1 v pat+  return (wrap, EquationInfo (pat' : pats) body)++tidy1 :: DsMonad q+      => Name   -- the name of the variable that ...+      -> DPat   -- ... this pattern is matching against+      -> q (DExp -> DExp, DPat)   -- a wrapper and tidied pattern+tidy1 _ p@(DLitPa {}) = return (id, p)+tidy1 v (DVarPa var) = return (wrapBind var v, DWildPa)+tidy1 _ p@(DConPa {}) = return (id, p)+tidy1 v (DTildePa pat) = do+  sel_decs <- mkSelectorDecs pat v+  return (maybeDLetE sel_decs, DWildPa)+tidy1 v (DBangPa pat) =+  case pat of+    DLitPa _   -> tidy1 v pat   -- already strict+    DVarPa _   -> return (id, DBangPa pat)  -- no change+    DConPa _ _ -> tidy1 v pat   -- already strict+    DTildePa p -> tidy1 v (DBangPa p) -- discard ~ under !+    DBangPa p  -> tidy1 v (DBangPa p) -- discard ! under !+    DWildPa    -> return (id, DBangPa pat)  -- no change+tidy1 _ DWildPa = return (id, DWildPa)+    +wrapBind :: Name -> Name -> DExp -> DExp+wrapBind new old+  | new == old = id+  | otherwise  = DLetE [DValD (DVarPa new) (DVarE old)]++-- like GHC's mkSelectorBinds+mkSelectorDecs :: DsMonad q+               => DPat      -- pattern to deconstruct+               -> Name      -- variable being matched against+               -> q [DLetDec]+mkSelectorDecs (DVarPa v) name = return [DValD (DVarPa v) (DVarE name)]+mkSelectorDecs pat name+  | S.null binders+  = return []++  | S.size binders == 1+  = do val_var <- newUniqueName "var"+       err_var <- newUniqueName "err"+       bind    <- mk_bind val_var err_var (head $ S.elems binders)+       return [DValD (DVarPa val_var) (DVarE name),+               DValD (DVarPa err_var) (DVarE 'error `DAppE`+                                       (DLitE $ StringL "Irrefutable match failed")),+               bind]++  | otherwise+  = do tuple_expr <- simplCaseExp [name] [DClause [pat] local_tuple]+       tuple_var <- newUniqueName "tuple"+       projections <- mapM (mk_projection tuple_var) [0 .. tuple_size-1]+       return (DValD (DVarPa tuple_var) tuple_expr :+               zipWith DValD (map DVarPa binders_list) projections)++  where+    binders = extractBoundNamesDPat pat+    binders_list = S.toAscList binders+    tuple_size = length binders_list+    local_tuple = mkTupleDExp (map DVarE binders_list)++    mk_projection :: DsMonad q+                  => Name   -- of the tuple+                  -> Int    -- which element to get (0-indexed)+                  -> q DExp+    mk_projection tup_name i = do+      var_name <- newUniqueName "proj"+      return $ DCaseE (DVarE tup_name) [DMatch (DConPa (tupleDataName tuple_size) (mk_tuple_pats var_name i))+                                               (DVarE var_name)]++    mk_tuple_pats :: Name   -- of the projected element+                  -> Int    -- which element to get (0-indexed)+                  -> [DPat]+    mk_tuple_pats elt_name i = replicate i DWildPa ++ DVarPa elt_name : replicate (tuple_size - i - 1) DWildPa++    mk_bind scrut_var err_var bndr_var = do+      rhs_mr <- simplCase [scrut_var] [EquationInfo [pat] (\_ -> DVarE bndr_var)]+      return (DValD (DVarPa bndr_var) (rhs_mr (DVarE err_var)))++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 +  | PgLit Lit  +  | PgBang     ++-- like GHC's groupEquations+groupClauses :: [EquationInfo] -> [[(PatGroup, EquationInfo)]]+groupClauses clauses+  = runs same_gp [(patGroup (firstPat clause), clause) | clause <- clauses]+  where+    same_gp :: (PatGroup, EquationInfo) -> (PatGroup, EquationInfo) -> Bool+    (pg1,_) `same_gp` (pg2,_) = pg1 `sameGroup` pg2++patGroup :: DPat -> PatGroup+patGroup (DLitPa l)     = PgLit l+patGroup (DVarPa {})    = error "Internal error in th-desugar (patGroup DVarP)"+patGroup (DConPa con _) = PgCon con+patGroup (DTildePa {})  = error "Internal error in th-desugar (patGroup DTildeP)"+patGroup (DBangPa {})   = PgBang+patGroup DWildPa        = PgAny++sameGroup :: PatGroup -> PatGroup -> Bool+sameGroup PgAny     PgAny     = True+sameGroup PgBang    PgBang    = True+sameGroup (PgCon _) (PgCon _) = True+sameGroup (PgLit _) (PgLit _) = True+sameGroup _         _         = False++subGroup :: Ord a => [(a, EquationInfo)] -> [[EquationInfo]]+subGroup group+  = map reverse $ Map.elems $ foldl accumulate Map.empty group+  where+    accumulate pg_map (pg, eqn)+      = case Map.lookup pg pg_map of+          Just eqns -> Map.insert pg (eqn:eqns) pg_map+          Nothing   -> Map.insert pg [eqn]      pg_map++firstPat :: EquationInfo -> DPat+firstPat (EquationInfo (pat : _) _) = pat+firstPat _ = error "Clause encountered with no patterns -- should never happen"++data CaseAlt = CaseAlt { alt_con  :: Name         -- con name+                       , _alt_args :: [Name]       -- bound var names+                       , _alt_rhs  :: MatchResult  -- RHS+                       }++-- from GHC's MatchCon.lhs+matchConFamily :: DsMonad q => [Name] -> [[EquationInfo]] -> q MatchResult+matchConFamily (var:vars) groups+  = do alts <- mapM (matchOneCon vars) groups+       mkDataConCase var alts+matchConFamily [] _ = error "Internal error in th-desugar (matchConFamily)"++-- like matchOneConLike from MatchCon+matchOneCon :: DsMonad q => [Name] -> [EquationInfo] -> q CaseAlt+matchOneCon vars eqns@(eqn1 : _)+  = do arg_vars <- selectMatchVars (pat_args pat1)+       match_result <- match_group arg_vars++       return $ CaseAlt (pat_con pat1) arg_vars match_result+  where+    pat1 = firstPat eqn1+    +    pat_args (DConPa _ pats) = pats+    pat_args _               = error "Internal error in th-desugar (pat_args)"++    pat_con (DConPa con _) = con+    pat_con _              = error "Internal error in th-desugar (pat_con)"++    match_group :: DsMonad q => [Name] -> q MatchResult+    match_group arg_vars+      = simplCase (arg_vars ++ vars) (map shift eqns)++    shift (EquationInfo (DConPa _ args : pats) exp) = EquationInfo (args ++ pats) exp+    shift _ = error "Internal error in th-desugar (shift)"+matchOneCon _ _ = error "Internal error in th-desugar (matchOneCon)"++mkDataConCase :: DsMonad q => Name -> [CaseAlt] -> q MatchResult+mkDataConCase var case_alts = do+  all_ctors <- get_all_ctors (alt_con $ head case_alts)+  return $ \fail ->+    let matches = map (mk_alt fail) case_alts in+    DCaseE (DVarE var) (matches ++ mk_default all_ctors fail)+  where+    mk_alt fail (CaseAlt con args body_fn)+      = let body = body_fn fail in+        DMatch (DConPa con (map DVarPa args)) body++    mk_default all_ctors fail | exhaustive_case all_ctors = []+                              | otherwise       = [DMatch DWildPa fail]++    mentioned_ctors = S.fromList $ map alt_con case_alts+    exhaustive_case all_ctors = all_ctors `S.isSubsetOf` mentioned_ctors++    get_all_ctors :: DsMonad q => Name -> q (S.Set Name)+    get_all_ctors con_name = do+      ty_name <- dataConNameToDataName con_name+      Just (DTyConI tycon_dec _) <- dsReify ty_name+      return $ S.fromList $ map get_con_name $ get_cons tycon_dec++    get_cons (DDataD _ _ _ _ cons _)     = cons+    get_cons (DDataInstD _ _ _ _ cons _) = cons+    get_cons _                           = []++    get_con_name (DCon _ _ n _) = n++matchEmpty :: DsMonad q => Name -> q [MatchResult]+matchEmpty var = return [mk_seq]+  where+    mk_seq fail = DCaseE (DVarE var) [DMatch DWildPa fail]++matchLiterals :: DsMonad q => [Name] -> [[EquationInfo]] -> q MatchResult+matchLiterals (var:vars) sub_groups+  = do alts <- mapM match_group sub_groups+       return (mkCoPrimCaseMatchResult var alts)+  where+    match_group :: DsMonad q => [EquationInfo] -> q (Lit, MatchResult)+    match_group eqns+      = do let DLitPa lit = firstPat (head eqns)+           match_result <- simplCase vars (shiftEqns eqns)+           return (lit, match_result)+matchLiterals [] _ = error "Internal error in th-desugar (matchLiterals)"++mkCoPrimCaseMatchResult :: Name -- Scrutinee+                        -> [(Lit, MatchResult)]+                        -> MatchResult+mkCoPrimCaseMatchResult var match_alts = mk_case+  where+    mk_case fail = let alts = map (mk_alt fail) match_alts in+                   DCaseE (DVarE var) (alts ++ [DMatch DWildPa fail])+    mk_alt fail (lit, body_fn)+      = DMatch (DLitPa lit) (body_fn fail)++matchBangs :: DsMonad q => [Name] -> [EquationInfo] -> q MatchResult+matchBangs (var:vars) eqns+  = do match_result <- simplCase (var:vars) $+                       map (decomposeFirstPat getBangPat) eqns+       return (mkEvalMatchResult var match_result)+matchBangs [] _ = error "Internal error in th-desugar (matchBangs)"++decomposeFirstPat :: (DPat -> DPat) -> EquationInfo -> EquationInfo+decomposeFirstPat extractpat (EquationInfo (pat:pats) body)+  = EquationInfo (extractpat pat : pats) body+decomposeFirstPat _ _ = error "Internal error in th-desugar (decomposeFirstPat)"++getBangPat :: DPat -> DPat+getBangPat (DBangPa p) = p+getBangPat _           = error "Internal error in th-desugar (getBangPat)"++mkEvalMatchResult :: Name -> MatchResult -> MatchResult+mkEvalMatchResult var body_fn fail+  = foldl DAppE (DVarE 'seq) [DVarE var, body_fn fail]++matchVariables :: DsMonad q => [Name] -> [EquationInfo] -> q MatchResult+matchVariables (_:vars) eqns = simplCase vars (shiftEqns eqns)+matchVariables _ _ = error "Internal error in th-desugar (matchVariables)"++shiftEqns :: [EquationInfo] -> [EquationInfo]+shiftEqns = map shift+  where+    shift (EquationInfo pats rhs) = EquationInfo (tail pats) rhs+++adjustMatchResult :: (DExp -> DExp) -> MatchResult -> MatchResult+adjustMatchResult wrap mr fail = wrap $ mr fail++-- from DsUtils+selectMatchVars :: DsMonad q => [DPat] -> q [Name]+selectMatchVars = mapM selectMatchVar++-- from DsUtils+selectMatchVar :: DsMonad q => DPat -> q Name+selectMatchVar (DBangPa pat)  = selectMatchVar pat+selectMatchVar (DTildePa pat) = selectMatchVar pat+selectMatchVar (DVarPa var)   = newUniqueName ('_' : nameBase var)+selectMatchVar _              = newUniqueName "_pat"++-- like GHC's runs+runs :: (a -> a -> Bool) -> [a] -> [[a]]+runs _ [] = []+runs p (x:xs) = case span (p x) xs of+                  (first, rest) -> (x:first) : (runs p rest)

@@ -0,0 +1,367 @@+{- Language/Haskell/TH/Desugar/Reify.hs++(c) Richard Eisenberg 2014+eir@cis.upenn.edu++Allows for reification from a list of declarations, without looking a name+up in the environment.+-}++{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-}++module Language.Haskell.TH.Desugar.Reify (+  -- * Reification+  reifyWithLocals_maybe, reifyWithLocals, reifyWithWarning, reifyInDecs,++  -- * Datatype lookup+  getDataD, dataConNameToCon, dataConNameToDataName,++  -- * Monad support+  DsMonad(..), DsM, withLocalDeclarations+  ) where++import Control.Monad.Reader+import Data.List+import Data.Maybe+#if __GLASGOW_HASKELL__ < 709+import Control.Applicative+#endif+import qualified Data.Set as S++import Language.Haskell.TH.Syntax hiding ( lift )++import Language.Haskell.TH.Desugar.Util++-- | Like @reify@ from Template Haskell, but looks also in any not-yet-typechecked+-- declarations. To establish this list of not-yet-typechecked declarations,+-- use 'withLocalDeclarations'. Returns 'Nothing' if reification fails.+-- Note that no inferred type information is available from local declarations;+-- bottoms may be used if necessary.+reifyWithLocals_maybe :: DsMonad q => Name -> q (Maybe Info)+reifyWithLocals_maybe name = qRecover+  (return . reifyInDecs name =<< localDeclarations)+  (Just `fmap` qReify name)++-- | Like 'reifyWithLocals_maybe', but throws an exception upon failure,+-- warning the user about separating splices.+reifyWithLocals :: DsMonad q => Name -> q Info+reifyWithLocals name = do+  m_info <- reifyWithLocals_maybe name+  case m_info of+    Nothing -> reifyFail name+    Just i  -> return i++-- | Reify a declaration, warning the user about splices if the reify fails.+-- The warning says that reification can fail if you try to reify a type in+-- the same splice as it is declared.+reifyWithWarning :: Quasi q => Name -> q Info+reifyWithWarning name = qRecover (reifyFail name) (qReify name)++-- | Print out a warning about separating splices and fail.+reifyFail :: Monad m => Name -> m a+reifyFail name =+  fail $ "Looking up " ++ (show name) ++ " in the list of available " +++       "declarations failed.\nThis lookup fails if the declaration " +++       "referenced was made in the same Template\nHaskell splice as the use " +++       "of the declaration. If this is the case, put\nthe reference to " +++       "the declaration in a new splice."++---------------------------------+-- Utilities+---------------------------------++-- | Extract the @TyVarBndr@s and constructors given the @Name@ of a type+getDataD :: Quasi q+         => String       -- ^ Print this out on failure+         -> Name         -- ^ Name of the datatype (@data@ or @newtype@) of interest+         -> q ([TyVarBndr], [Con])+getDataD err name = do+  info <- reifyWithWarning name+  dec <- case info of+           TyConI dec -> return dec+           _ -> badDeclaration+  case dec of+    DataD _cxt _name tvbs cons _derivings -> return (tvbs, cons)+    NewtypeD _cxt _name tvbs con _derivings -> return (tvbs, [con])+    _ -> badDeclaration+  where badDeclaration =+          fail $ "The name (" ++ (show name) ++ ") refers to something " +++                 "other than a datatype. " ++ err++-- | From the name of a data constructor, retrive the datatype definition it+-- is a part of.+dataConNameToDataName :: Quasi q => Name -> q Name+dataConNameToDataName con_name = do+  info <- reifyWithWarning con_name+  case info of+    DataConI _name _type parent_name _fixity -> return parent_name+    _ -> fail $ "The name " ++ show con_name ++ " does not appear to be " +++                "a data constructor."++-- | From the name of a data constructor, retrieve its definition as a @Con@+dataConNameToCon :: Quasi q => Name -> q Con+dataConNameToCon con_name = do+  -- we need to get the field ordering from the constructor. We must reify+  -- the constructor to get the tycon, and then reify the tycon to get the `Con`s+  type_name <- dataConNameToDataName con_name+  (_, cons) <- getDataD "This seems to be an error in GHC." type_name+  let m_con = find ((con_name ==) . get_con_name) cons+  case m_con of+    Just con -> return con+    Nothing -> impossible "Datatype does not contain one of its own constructors."++  where+    get_con_name (NormalC name _)  = name+    get_con_name (RecC name _)     = name+    get_con_name (InfixC _ name _) = name+    get_con_name (ForallC _ _ con) = get_con_name con++--------------------------------------------------+-- DsMonad+--------------------------------------------------++-- | A 'DsMonad' stores some list of declarations that should be considered+-- in scope. 'DsM' is the prototypical inhabitant of 'DsMonad'.+class Quasi m => DsMonad m where+  -- | Produce a list of local declarations.+  localDeclarations :: m [Dec]++instance DsMonad Q where+  localDeclarations = return []+instance DsMonad IO where+  localDeclarations = return []++-- | A convenient implementation of the 'DsMonad' class. Use by calling+-- 'withLocalDeclarations'.+newtype DsM q a = DsM (ReaderT [Dec] q a)+  deriving (Functor, Applicative, Monad, MonadTrans)++instance Quasi q => Quasi (DsM q) where+  qNewName          = lift `comp1` qNewName+  qReport           = lift `comp2` qReport+  qLookupName       = lift `comp2` qLookupName+  qReify            = lift `comp1` qReify+  qReifyInstances   = lift `comp2` qReifyInstances+  qLocation         = lift qLocation+  qRunIO            = lift `comp1` qRunIO+  qAddDependentFile = lift `comp1` qAddDependentFile+#if __GLASGOW_HASKELL__ >= 707+  qReifyRoles       = lift `comp1` qReifyRoles+  qReifyAnnotations = lift `comp1` qReifyAnnotations+  qReifyModule      = lift `comp1` qReifyModule+  qAddTopDecls      = lift `comp1` qAddTopDecls+  qAddModFinalizer  = lift `comp1` qAddModFinalizer+  qGetQ             = lift qGetQ+  qPutQ             = lift `comp1` qPutQ+#endif+                      +  qRecover (DsM handler) (DsM body) = DsM $ do+    env <- ask+    lift $ qRecover (runReaderT handler env) (runReaderT body env)++instance Quasi q => DsMonad (DsM q) where+  localDeclarations = DsM ask++-- | Add a list of declarations to be considered when reifying local+-- declarations.+withLocalDeclarations :: DsMonad q => [Dec] -> DsM q a -> q a+withLocalDeclarations new_decs (DsM x) = do+  orig_decs <- localDeclarations+  runReaderT x (orig_decs ++ new_decs)++-- helper functions for composition+comp1 :: (b -> c) -> (a -> b) -> a -> c+comp1 = (.)++comp2 :: (c -> d) -> (a -> b -> c) -> a -> b -> d+comp2 f g a b = f (g a b)++---------------------------+-- Reifying local declarations+---------------------------++-- | Look through a list of declarations and possibly return a relevant 'Info'+reifyInDecs :: Name -> [Dec] -> Maybe Info+reifyInDecs n decs = firstMatch (reifyInDec n decs) decs++reifyInDec :: Name -> [Dec] -> Dec -> Maybe Info+reifyInDec n decs (FunD n' _) | n `nameMatches` n' = Just $ mkVarI n decs+reifyInDec n decs (ValD pat _ _)+  | any (nameMatches n) (S.elems (extractBoundNamesPat pat)) = Just $ mkVarI n decs+reifyInDec n _    dec@(DataD    _ n' _ _ _) | n `nameMatches` n' = Just $ TyConI dec+reifyInDec n _    dec@(NewtypeD _ n' _ _ _) | n `nameMatches` n' = Just $ TyConI dec+reifyInDec n _    dec@(TySynD n' _ _)       | n `nameMatches` n' = Just $ TyConI dec+reifyInDec n decs dec@(ClassD _ n' _ _ _)   | n `nameMatches` n'+  = Just $ ClassI (stripClassDec dec) (findInstances n decs)+reifyInDec n decs (ForeignD (ImportF _ _ _ n' ty)) | n `nameMatches` n'+  = Just $ mkVarITy n decs ty+reifyInDec n decs (ForeignD (ExportF _ _ n' ty)) | n `nameMatches` n'+  = Just $ mkVarITy n decs ty+reifyInDec n decs dec@(FamilyD _ n' _ _) | n `nameMatches` n'+  = Just $ FamilyI (handleBug8884 dec) (findInstances n decs)+#if __GLASGOW_HASKELL__ >= 707+reifyInDec n _    dec@(ClosedTypeFamilyD n' _ _ _) | n `nameMatches` n'+  = Just $ FamilyI dec []+#endif++reifyInDec n decs (DataD _ ty_name tvbs cons _)+  | Just info <- maybeReifyCon n decs ty_name (map tvbToType tvbs) cons+  = Just info+reifyInDec n decs (NewtypeD _ ty_name tvbs con _)+  | Just info <- maybeReifyCon n decs ty_name (map tvbToType tvbs) [con]+  = Just info+reifyInDec n decs (ClassD _ _ _ _ sub_decs)+  | Just info <- firstMatch (reifyInDec n (sub_decs ++ decs)) sub_decs+  = Just info    -- must necessarily *not* be a method, because type signatures+                 -- don't reify+reifyInDec n decs (ClassD _ ty_name tvbs _ sub_decs)+  | Just ty <- findType n sub_decs+  = Just $ ClassOpI n (addClassCxt ty_name tvbs ty)+                    ty_name (findFixity n $ sub_decs ++ decs)+reifyInDec n decs (InstanceD _ _ sub_decs)+  | Just info <- firstMatch reify_in_instance sub_decs+  = Just info+  where+    reify_in_instance dec@(DataInstD {})    = reifyInDec n (sub_decs ++ decs) dec+    reify_in_instance dec@(NewtypeInstD {}) = reifyInDec n (sub_decs ++ decs) dec+    reify_in_instance _                     = Nothing+reifyInDec n decs (DataInstD _ ty_name tys cons _)+  | Just info <- maybeReifyCon n decs ty_name tys cons+  = Just info+reifyInDec n decs (NewtypeInstD _ ty_name tys con _)+  | Just info <- maybeReifyCon n decs ty_name tys [con]+  = Just info++reifyInDec _ _ _ = Nothing++maybeReifyCon :: Name -> [Dec] -> Name -> [Type] -> [Con] -> Maybe Info+maybeReifyCon n decs ty_name ty_args cons+  | Just con <- findCon n cons+  = Just $ DataConI n (maybeForallT tvbs [] $ con_to_type con)+                    ty_name fixity++  | Just ty <- findRecSelector n cons+      -- we don't try to ferret out naughty record selectors.+  = Just $ VarI n (maybeForallT tvbs [] $ mkArrows [result_ty] ty) Nothing fixity+  where+    result_ty = foldl AppT (ConT ty_name) ty_args++    con_to_type (NormalC _ stys) = mkArrows (map snd    stys)  result_ty+    con_to_type (RecC _ vstys)   = mkArrows (map thdOf3 vstys) result_ty+    con_to_type (InfixC t1 _ t2) = mkArrows (map snd [t1, t2]) result_ty+    con_to_type (ForallC bndrs cxt c) = ForallT bndrs cxt (con_to_type c)++    fixity = findFixity n decs+    tvbs = map PlainTV $ S.elems $ freeNamesOfTypes ty_args+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    ++mkVarITy :: Name -> [Dec] -> Type -> Info+mkVarITy n decs ty = VarI n ty Nothing (findFixity n decs)+    +findFixity :: Name -> [Dec] -> Fixity+findFixity n = fromMaybe defaultFixity . firstMatch match_fixity+  where+    match_fixity (InfixD fixity n') | n `nameMatches` n' = Just fixity+    match_fixity _                                   = Nothing++findType :: Name -> [Dec] -> Maybe Type+findType n = firstMatch match_type+  where+    match_type (SigD n' ty) | n `nameMatches` n' = Just ty+    match_type _                             = Nothing++findInstances :: Name -> [Dec] -> [Dec]+findInstances n = map stripInstanceDec . concatMap match_instance+  where+    match_instance d@(InstanceD _ ty _)        | ConT n' <- ty_head ty+                                               , n `nameMatches` n' = [d]+    match_instance d@(DataInstD _ n' _ _ _)    | n `nameMatches` n' = [d]+    match_instance d@(NewtypeInstD _ n' _ _ _) | n `nameMatches` n' = [d]+#if __GLASGOW_HASKELL__ >= 707+    match_instance d@(TySynInstD n' _)         | n `nameMatches` n' = [d]+#else+    match_instance d@(TySynInstD n' _ _)       | n `nameMatches` n' = [d]+#endif+    match_instance (InstanceD _ _ decs) = concatMap match_instance decs+    match_instance _                    = []++    ty_head (ForallT _ _ ty) = ty_head ty+    ty_head (AppT ty _)      = ty_head ty+    ty_head (SigT ty _)      = ty_head ty+    ty_head ty               = ty++stripClassDec :: Dec -> Dec+stripClassDec (ClassD cxt name tvbs fds sub_decs)+  = ClassD cxt name tvbs fds sub_decs'+  where+    sub_decs' = mapMaybe go sub_decs+    go (SigD n ty) = Just $ SigD n $ addClassCxt name tvbs ty+    go _           = Nothing+stripClassDec dec = dec++addClassCxt :: Name -> [TyVarBndr] -> Type -> Type+addClassCxt class_name tvbs ty = ForallT tvbs class_cxt ty+  where+#if __GLASGOW_HASKELL__ < 709+    class_cxt = [ClassP class_name (map tvbToType tvbs)]+#else+    class_cxt = [foldl AppT (ConT class_name) (map tvbToType tvbs)]+#endif++stripInstanceDec :: Dec -> Dec+stripInstanceDec (InstanceD cxt ty _) = InstanceD cxt ty []+stripInstanceDec dec                  = dec++mkArrows :: [Type] -> Type -> Type+mkArrows []     res_ty = res_ty+mkArrows (t:ts) res_ty = AppT (AppT ArrowT t) $ mkArrows ts res_ty++maybeForallT :: [TyVarBndr] -> Cxt -> Type -> Type+maybeForallT tvbs cxt ty+  | null tvbs && null cxt        = ty+  | ForallT tvbs2 cxt2 ty2 <- ty = ForallT (tvbs ++ tvbs2) (cxt ++ cxt2) ty2+  | otherwise                    = ForallT tvbs cxt ty++findCon :: Name -> [Con] -> Maybe Con+findCon n = find match_con+  where+    match_con (NormalC n' _)  = n `nameMatches` n'+    match_con (RecC n' _)     = n `nameMatches` n'+    match_con (InfixC _ n' _) = n `nameMatches` n'+    match_con (ForallC _ _ c) = match_con c++findRecSelector :: Name -> [Con] -> Maybe Type+findRecSelector n = firstMatch match_con+  where+    match_con (RecC _ vstys)  = firstMatch match_rec_sel vstys+    match_con (ForallC _ _ c) = match_con c+    match_con _               = Nothing++    match_rec_sel (n', _, ty) | n `nameMatches` n' = Just ty+    match_rec_sel _                     = Nothing+    ++handleBug8884 :: Dec -> Dec+#if __GLASGOW_HASKELL__ >= 707+handleBug8884 = id+#else+handleBug8884 (FamilyD flav name tvbs m_kind)+  = FamilyD flav name tvbs (Just stupid_kind)+  where+    kind_from_maybe = fromMaybe StarT+    tvb_kind (PlainTV _)    = Nothing+    tvb_kind (KindedTV _ k) = Just k+    +    result_kind = kind_from_maybe m_kind+    args_kinds  = map (kind_from_maybe . tvb_kind) tvbs++    stupid_kind = mkArrows args_kinds result_kind+handleBug8884 dec = dec+#endif    +

@@ -22,8 +22,14 @@ -- ---------------------------------------------------------------------------- -module Language.Haskell.TH.Desugar.Sweeten where+module Language.Haskell.TH.Desugar.Sweeten (+  expToTH, matchToTH, patToTH, decsToTH, decToTH,+  letDecToTH, typeToTH, kindToTH, +  conToTH, foreignToTH, pragmaToTH, ruleBndrToTH,+  clauseToTH, tvbToTH, cxtToTH, predToTH+  ) where+ import Prelude hiding (exp) import Language.Haskell.TH hiding (cxt) @@ -41,6 +47,11 @@ 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  matchToTH :: DMatch -> Match matchToTH (DMatch pat exp) = Match (patToTH pat) (NormalB (expToTH exp)) []@@ -90,6 +101,16 @@                        (map tySynEqnToTH eqns)] decToTH (DRoleAnnotD n roles) = [RoleAnnotD n roles] #endif+#if __GLASGOW_HASKELL__ < 709+decToTH (DStandaloneDerivD {}) =+  error "Standalone deriving supported only in GHC 7.10+"+decToTH (DDefaultSigD {})      =+  error "Default method signatures supported only in GHC 7.10+"+#else+decToTH (DStandaloneDerivD cxt ty) =+  [StandaloneDerivD (cxtToTH cxt) (typeToTH ty)]+decToTH (DDefaultSigD n ty)        = [DefaultSigD n (typeToTH ty)]+#endif decToTH _ = error "Newtype declaration without exactly 1 constructor."  letDecToTH :: DLetDec -> Dec@@ -123,6 +144,11 @@ #else pragmaToTH (DAnnP target exp) = Just $ AnnP target (expToTH exp) #endif+#if __GLASGOW_HASKELL__ < 709+pragmaToTH (DLineP {}) = Nothing+#else+pragmaToTH (DLineP n str) = Just $ LineP n str+#endif  ruleBndrToTH :: DRuleBndr -> RuleBndr ruleBndrToTH (DRuleVar n) = RuleVar n@@ -167,7 +193,7 @@     go _   (DVarPr _)       = error "Template Haskell in GHC <= 7.8 does not support variable constraints."     go acc (DConPr n) -      | nameBase n == "(~)"+      | nameBase n == "~"       , [t1, t2] <- acc       = EqualP t1 t2       | otherwise

@@ -8,30 +8,36 @@  {-# LANGUAGE CPP, TupleSections #-} -module Language.Haskell.TH.Desugar.Util where+module Language.Haskell.TH.Desugar.Util (+  newUniqueName,+  impossible, +  nameOccursIn, allNamesIn, mkTypeName, mkDataName,+  stripVarP_maybe, extractBoundNamesStmt,+  concatMapM, mapMaybeM, expectJustM,+  liftSndM, liftThdOf3M, stripPlainTV_maybe,+  liftSnd, liftThdOf3, splitAtList, extractBoundNamesDec,+  extractBoundNamesPat,+  tvbName, tvbToType, nameMatches, freeNamesOfTypes, thdOf3, firstMatch,+  tupleDegree_maybe, tupleNameDegree_maybe, unboxedTupleDegree_maybe,+  unboxedTupleNameDegree_maybe, splitTuple_maybe+  ) where -import Prelude hiding (mapM)+import Prelude hiding (mapM, foldl, concatMap, any) -import Language.Haskell.TH-import Language.Haskell.TH.Syntax ( Quasi(..), mkNameG_tc, mkNameG_d )+import Language.Haskell.TH hiding ( cxt )+import Language.Haskell.TH.Syntax +import Control.Arrow  ( second ) import qualified Data.Set as S import Data.Foldable-import Data.Generics+import Data.Generics hiding ( Fixity ) import Data.Traversable+import Data.Maybe import Data.Monoid --- | Reify a declaration, warning the user about splices if the reify fails.--- The warning says that reification can fail if you try to reify a type in--- the same splice as it is declared.-reifyWithWarning :: Quasi q => Name -> q Info-reifyWithWarning name = qRecover-  (fail $ "Looking up " ++ (show name) ++ " in the list of available " ++-        "declarations failed.\nThis lookup fails if the declaration " ++-        "referenced was made in the same Template\nHaskell splice as the use " ++-        "of the declaration. If this is the case, put\nthe reference to " ++-        "the declaration in a new splice.")-  (qReify name)+----------------------------------------+-- TH manipulations+----------------------------------------  -- | Like newName, but even more unique (unique across different splices), -- and with unique @nameBase@s.@@ -40,64 +46,6 @@   n <- qNewName str   qNewName $ show n --- | Report that a certain TH construct is impossible-impossible :: Quasi 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.")---- | Extract the @TyVarBndr@s and constructors given the @Name@ of a type-getDataD :: Quasi q-         => String       -- ^ Print this out on failure-         -> Name         -- ^ Name of the datatype (@data@ or @newtype@) of interest-         -> q ([TyVarBndr], [Con])-getDataD err name = do-  info <- reifyWithWarning name-  dec <- case info of-           TyConI dec -> return dec-           _ -> badDeclaration-  case dec of-    DataD _cxt _name tvbs cons _derivings -> return (tvbs, cons)-    NewtypeD _cxt _name tvbs con _derivings -> return (tvbs, [con])-    _ -> badDeclaration-  where badDeclaration =-          fail $ "The name (" ++ (show name) ++ ") refers to something " ++-                 "other than a datatype. " ++ err---- | From the name of a data constructor, retrive the datatype definition it--- is a part of.-dataConNameToDataName :: Quasi q => Name -> q Name-dataConNameToDataName con_name = do-  info <- reifyWithWarning con_name-  case info of-    DataConI _name _type parent_name _fixity -> return parent_name-    _ -> fail $ "The name " ++ show con_name ++ " does not appear to be " ++-                "a data constructor."---- | From the name of a data constructor, retrieve its definition as a @Con@-dataConNameToCon :: Quasi q => Name -> q Con-dataConNameToCon con_name = do-  -- we need to get the field ordering from the constructor. We must reify-  -- the constructor to get the tycon, and then reify the tycon to get the `Con`s-  type_name <- dataConNameToDataName con_name-  (_, cons) <- getDataD "This seems to be an error in GHC." type_name-  let m_con = find ((con_name ==) . get_con_name) cons-  case m_con of-    Just con -> return con-    Nothing -> impossible "Datatype does not contain one of its own constructors."--  where-    get_con_name (NormalC name _)  = name-    get_con_name (RecC name _)     = name-    get_con_name (InfixC _ name _) = name-    get_con_name (ForallC _ _ con) = get_con_name con---- | Check if a name occurs anywhere within a TH tree.-nameOccursIn :: Data a => Name -> a -> Bool-nameOccursIn n = everything (||) $ mkQ False (== n)---- | Extract all Names mentioned in a TH tree.-allNamesIn :: Data a => a -> [Name]-allNamesIn = everything (++) $ mkQ [] (:[])-                -- | Like TH's @lookupTypeName@, but if this name is not bound, then we assume -- it is declared in the current module. mkTypeName :: Quasi q => String -> q Name@@ -130,6 +78,90 @@ stripPlainTV_maybe (PlainTV n) = Just n stripPlainTV_maybe _           = Nothing +-- | Report that a certain TH construct is impossible+impossible :: Monad q => String -> q a+impossible err = fail (err ++ "\n    This should not happen in Haskell.\n    Please email eir@cis.upenn.edu with your code if you see this.")++-- | Extract a 'Name' from a 'TyVarBndr'+tvbName :: TyVarBndr -> Name+tvbName (PlainTV n)    = n+tvbName (KindedTV n _) = n++-- | Convert a 'TyVarBndr' into a 'Type'+tvbToType :: TyVarBndr -> Type+tvbToType = VarT . tvbName++-- | Do two names name the same thing?+nameMatches :: Name -> Name -> Bool+nameMatches n1@(Name occ1 flav1) n2@(Name occ2 flav2)+  | NameS <- flav1 = occ1 == occ2+  | NameS <- flav2 = occ1 == occ2+  | NameQ mod1 <- flav1+  , NameQ mod2 <- flav2+  = mod1 == mod2 && occ1 == occ2+  | NameQ mod1 <- flav1+  , NameG _ _ mod2 <- flav2+  = mod1 == mod2 && occ1 == occ2+  | NameG _ _ mod1 <- flav1+  , NameQ mod2 <- flav2+  = mod1 == mod2 && occ1 == occ2+  | otherwise+  = n1 == n2++-- | Extract the degree of a tuple+tupleDegree_maybe :: String -> Maybe Int+tupleDegree_maybe s = do+  '(' : s1 <- return s+  (commas, ")") <- return $ span (== ',') s1+  let degree+        | "" <- commas = 0+        | otherwise    = length commas + 1+  return degree++-- | Extract the degree of a tuple name+tupleNameDegree_maybe :: Name -> Maybe Int+tupleNameDegree_maybe = tupleDegree_maybe . nameBase++-- | Extract the degree of an unboxed tuple+unboxedTupleDegree_maybe :: String -> Maybe Int+unboxedTupleDegree_maybe s = do+  '(' : '#' : s1 <- return s+  (commas, "#)") <- return $ span (== ',') s1+  let degree+        | "" <- commas = 0+        | otherwise    = length commas + 1+  return degree++-- | Extract the degree of a tuple name+unboxedTupleNameDegree_maybe :: Name -> Maybe Int+unboxedTupleNameDegree_maybe = unboxedTupleDegree_maybe . nameBase++-- | If the argument is a tuple type, return the components+splitTuple_maybe :: Type -> Maybe [Type]+splitTuple_maybe t = go [] t+  where go args (t1 `AppT` t2) = go (t2:args) t1+        go args (t1 `SigT` _k) = go args t1+        go args (ConT con_name)+          | Just degree <- tupleNameDegree_maybe con_name+          , length args == degree+          = Just args+        go args (TupleT degree)+          | length args == degree+          = Just args+        go _ _ = Nothing++----------------------------------------+-- Free names, etc.+----------------------------------------++-- | Check if a name occurs anywhere within a TH tree.+nameOccursIn :: Data a => Name -> a -> Bool+nameOccursIn n = everything (||) $ mkQ False (== n)++-- | Extract all Names mentioned in a TH tree.+allNamesIn :: Data a => a -> [Name]+allNamesIn = everything (++) $ mkQ [] (:[])+                -- | Extract the names bound in a @Stmt@ extractBoundNamesStmt :: Stmt -> S.Set Name extractBoundNamesStmt (BindS pat _) = extractBoundNamesPat pat@@ -165,6 +197,27 @@ extractBoundNamesPat (SigP pat _)        = extractBoundNamesPat pat extractBoundNamesPat (ViewP _ pat)       = extractBoundNamesPat pat +freeNamesOfTypes :: [Type] -> S.Set Name+freeNamesOfTypes = mconcat . map go+  where+    go (ForallT tvbs cxt ty) = (go ty <> mconcat (map go_pred cxt))+                               S.\\ S.fromList (map tvbName tvbs)+    go (AppT t1 t2)          = go t1 <> go t2+    go (SigT ty _)           = go ty+    go (VarT n)              = S.singleton n+    go _                     = S.empty++#if __GLASGOW_HASKELL__ >= 709+    go_pred = go+#else+    go_pred (ClassP _ tys) = freeNamesOfTypes tys+    go_pred (EqualP t1 t2) = go t1 <> go t2+#endif++----------------------------------------+-- General utility+----------------------------------------+ -- like GHC's splitAtList :: [a] -> [b] -> ([b], [b]) splitAtList [] x = ([], x)@@ -173,40 +226,15 @@   (x : as, bs) splitAtList (_ : _) [] = ([], []) --- | If a type is a fully-applied tuple type, break it down into a list--- of its constituents. Otherwise, return Nothing.-splitTuple_maybe :: Type -> Maybe [Type]-splitTuple_maybe = go []-  where-    go acc (AppT left right) = go (right:acc) left-    go acc (SigT ty _)       = go acc ty-    go acc (TupleT n)-      | n == length acc = Just acc-    go acc (ConT name)-      | Just n <- tupleNameDegree_maybe name-      , n == length acc = Just acc-    go _ _ = Nothing---- | Extract the degree of a tuple, if the argument is a tuple-tupleDegree_maybe :: String -> Maybe Int-tupleDegree_maybe s = do-  '(' : s1 <- return s-  (commas, ")") <- return $ span (== ',') s1-  let degree-        | "" <- commas = 0-        | otherwise    = length commas + 1-  return degree---- | Extract the degree of a tuple name, if the argument is a tuple name-tupleNameDegree_maybe :: Name -> Maybe Int-tupleNameDegree_maybe = tupleDegree_maybe . nameBase- liftSnd :: (a -> b) -> (c, a) -> (c, b)-liftSnd f (c, a) = (c, f a)+liftSnd = second  liftSndM :: Monad m => (a -> m b) -> (c, a) -> m (c, b) liftSndM f (c, a) = f a >>= return . (c, ) +thdOf3 :: (a,b,c) -> c+thdOf3 (_,_,c) = c+ liftThdOf3 :: (a -> b) -> (c, d, a) -> (c, d, b) liftThdOf3 f (c, d, a) = (c, d, f a) @@ -221,3 +249,21 @@ concatMapM fn list = do   bss <- mapM fn list   return $ fold bss++-- like GHC's+mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b]+mapMaybeM _ [] = return []+mapMaybeM f (x:xs) = do+  y <- f x+  ys <- mapMaybeM f xs+  return $ case y of+    Nothing -> ys+    Just z  -> z : ys++expectJustM :: Monad m => String -> Maybe a -> m a+expectJustM _   (Just x) = return x+expectJustM err Nothing  = fail err++firstMatch :: (a -> Maybe b) -> [a] -> Maybe b+firstMatch f xs = listToMaybe $ mapMaybe f xs+    

@@ -6,7 +6,8 @@  {-# LANGUAGE TemplateHaskell, GADTs, PolyKinds, TypeFamilies,              MultiParamTypeClasses, FunctionalDependencies,-             FlexibleInstances, DataKinds, CPP, RankNTypes #-}+             FlexibleInstances, DataKinds, CPP, RankNTypes,+             StandaloneDeriving, DefaultSignatures #-} #if __GLASGOW_HASKELL__ >= 707 {-# LANGUAGE RoleAnnotations #-} #endif@@ -28,6 +29,9 @@ $(S.dectest8) $(S.dectest9) $(S.dectest10)+#if __GLASGOW_HASKELL__ >= 709+$(S.dectest11)+#endif  $(fmap unqualify S.instance_test) 

@@ -6,7 +6,8 @@  {-# LANGUAGE TemplateHaskell, GADTs, PolyKinds, TypeFamilies,              MultiParamTypeClasses, FunctionalDependencies,-             FlexibleInstances, DataKinds, CPP, RankNTypes #-}+             FlexibleInstances, DataKinds, CPP, RankNTypes,+             StandaloneDeriving, DefaultSignatures #-} #if __GLASGOW_HASKELL__ >= 707 {-# LANGUAGE RoleAnnotations #-} #endif@@ -21,7 +22,6 @@  import Language.Haskell.TH  ( reportError ) import Language.Haskell.TH.Desugar-import Language.Haskell.TH.Desugar.Sweeten  import Control.Monad @@ -46,6 +46,11 @@ $(return $ decsToTH [S.ds_dectest10]) #else $(dsDecSplice S.dectest10)+#endif++#if __GLASGOW_HASKELL__ >= 709+$(dsDecSplice S.dectest11)+$(dsDecSplice S.standalone_deriving_test) #endif  $(do decs <- S.rec_sel_test

@@ -6,35 +6,52 @@  {-# LANGUAGE TemplateHaskell, UnboxedTuples, ParallelListComp, CPP,              RankNTypes, ImpredicativeTypes, TypeFamilies,-             DataKinds, ConstraintKinds, PolyKinds #-}+             DataKinds, ConstraintKinds, PolyKinds, MultiParamTypeClasses,+             FlexibleInstances, ExistentialQuantification #-} {-# 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-warnings-deprecations #-}+            -fno-warn-missing-signatures -fno-warn-unused-do-bind #-}  module Test.Run where  import Prelude hiding ( exp )  import Test.HUnit-import Test.Hspec-import Test.Hspec.HUnit+import Test.Hspec hiding ( runIO )+-- import Test.Hspec.HUnit  import Test.Splices import qualified Test.DsDec import qualified Test.Dec import Test.Dec ( RecordSel ) import Language.Haskell.TH.Desugar-import Language.Haskell.TH.Desugar.Expand-import Language.Haskell.TH.Desugar.Sweeten-import Language.Haskell.TH as TH+import Language.Haskell.TH+import qualified Language.Haskell.TH.Syntax as Syn ( lift )  import Control.Monad+import Control.Applicative  #if __GLASGOW_HASKELL__ >= 707 import Data.Proxy #endif +-- |+-- Convert a HUnit test suite to a spec.  This can be used to run existing+-- HUnit tests with Hspec.+fromHUnitTest :: Test -> Spec+-- copied from https://github.com/hspec/hspec/blob/master/hspec-contrib/src/Test/Hspec/Contrib/HUnit.hs+fromHUnitTest t = case t of+  TestList xs -> mapM_ go xs+  x -> go x+  where+    go :: Test -> Spec+    go t_ = case t_ of+      TestLabel s (TestCase e) -> it s e+      TestLabel s (TestList xs) -> describe s (mapM_ go xs)+      TestLabel s x -> describe s (go x)+      TestList xs -> describe "<unlabeled>" (mapM_ go xs)+      TestCase e -> it "<unlabeled>" e+ tests :: Test tests = test [ "sections" ~: $test1_sections  @=? $(dsSplice test1_sections)              , "lampats"  ~: $test2_lampats   @=? $(dsSplice test2_lampats)@@ -89,6 +106,12 @@ test_e3b = $(test_expand3 >>= dsExp >>= expand >>= return . expToTH) test_e4a = $test_expand4 test_e4b = $(test_expand4 >>= dsExp >>= expand >>= return . expToTH)+#if __GLASGOW_HASKELL__ >= 707+test_e5a = $test_expand5+test_e5b = $(test_expand5 >>= dsExp >>= expand >>= return . expToTH)+test_e6a = $test_expand6+test_e6b = $(test_expand6 >>= dsExp >>= expand >>= return . expToTH)+#endif  hasSameType :: a -> a -> Bool hasSameType _ _ = True@@ -97,7 +120,12 @@ test_expand = and [ hasSameType test35a test35b                   , hasSameType test36a test36b                   , hasSameType test_e3a test_e3b-                  , hasSameType test_e4a test_e4b ]+                  , hasSameType test_e4a test_e4b+#if __GLASGOW_HASKELL__ >= 707+                  , hasSameType test_e5a test_e5b+                  , hasSameType test_e6a test_e6b+#endif+                  ]  test_dec :: [Bool] test_dec = $(do bools <- mapM testDecSplice dec_test_nums@@ -120,9 +148,13 @@                                    (Just [DTySynInstD _name2 (DTySynEqn lhs _rhs)]))                       <- dsInfo info                     case (resK, lhs) of+#if __GLASGOW_HASKELL__ < 709                       (DStarK, [DVarT _]) -> [| True |]+#else+                      (DStarK, [DSigT (DVarT _) (DVarK _)]) -> [| True |]+#endif                       _                                     -> do-                        TH.runIO $ do+                        runIO $ do                           putStrLn "Failed bug8884 test:"                           putStrLn $ show dinfo                         [| False |] )@@ -139,6 +171,42 @@ test_rec_sels = and $(do bools <- mapM testRecSelTypes [1..rec_sel_test_num_sels]                          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++local_reifications :: [String]+local_reifications = $(do decs <- reifyDecs+                          m_infos <- withLocalDeclarations decs $+                                     mapM reifyWithLocals_maybe reifyDecsNames+                          let m_infos' = assumeStarT m_infos+                          ListE <$> mapM (Syn.lift . show) (unqualify m_infos'))++$reifyDecs++$(return [])  -- somehow, this is necessary to get the staging correct for the+              -- reifications below. Weird.++normal_reifications :: [String]+normal_reifications = $(do infos <- mapM reify reifyDecsNames+                           ListE <$> mapM (Syn.lift . show . Just)+                                          (dropTrailing0s $ unqualify infos))++zipWith3M :: Monad m => (a -> b -> c -> m d) -> [a] -> [b] -> [c] -> m [d]+zipWith3M f (a:as) (b:bs) (c:cs) = liftM2 (:) (f a b c) (zipWith3M f as bs cs)+zipWith3M _ _ _ _ = return []++simplCase :: [Bool]+simplCase = $( do exps <- sequence simplCaseTests+                  dexps <- mapM dsExp exps+                  sexps <- mapM scExp dexps+                  bools <- zipWithM (\e1 e2 -> [| $(return e1) == $(return e2) |])+                    exps (map sweeten sexps)+                  return $ ListE bools )+ main :: IO () main = hspec $ do   describe "th-desugar library" $ do@@ -163,6 +231,13 @@      it "flattens DValDs" $ flatten_dvald -    it "extract record selectors" $ test_rec_sels+    it "extracts record selectors" $ test_rec_sels++    it "works with standalone deriving" $ test_standalone_deriving++    zipWith3M (\a b n -> it ("reifies local definition " ++ show n) $ a == b)+      local_reifications normal_reifications [1..]++    zipWithM (\b n -> it ("works on simplCase test " ++ show n) b) simplCase [1..]      fromHUnitTest tests

@@ -8,19 +8,20 @@              MultiWayIf, ParallelListComp, CPP, BangPatterns,              ScopedTypeVariables, RankNTypes, TypeFamilies, ImpredicativeTypes,              DataKinds, PolyKinds, GADTs, MultiParamTypeClasses,-             FunctionalDependencies, FlexibleInstances #-}+             FunctionalDependencies, FlexibleInstances, StandaloneDeriving,+             DefaultSignatures #-} {-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-type-defaults                 -fno-warn-name-shadowing #-}  module Test.Splices where  import Data.List+import Data.Char import GHC.Exts import GHC.TypeLits  import Language.Haskell.TH import Language.Haskell.TH.Desugar-import Language.Haskell.TH.Desugar.Sweeten import Data.Generics  #if __GLASGOW_HASKELL__ < 707@@ -50,6 +51,25 @@ 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 go)+  where+    go :: TyVarBndr -> TyVarBndr+    go (PlainTV n) = KindedTV n StarT+    go (KindedTV n k) = KindedTV n (assumeStarT k)+#endif++dropTrailing0s :: Data a => a -> a+dropTrailing0s = everywhere (mkT (mkName . frob . nameBase))+  where+    frob str+      | head str == 'r' = str+      | head str == 'R' = str+      | otherwise       = dropWhileEnd isDigit str+ eqTH :: (Data a, Show a) => a -> a -> Bool eqTH a b = show (unqualify a) == show (unqualify b) @@ -121,7 +141,7 @@  test27_kisig = [| let f :: Proxy (a :: Bool) -> ()                       f _ = () in-                  (f (Proxy :: Proxy False), f (Proxy :: Proxy True)) |]+                  (f (Proxy :: Proxy 'False), f (Proxy :: Proxy 'True)) |] test28_tupt = [| let f :: (a,b) -> a                      f (a,_) = a in                  map f [(1,'a'),(2,'b')] |]@@ -164,6 +184,19 @@                       f [True, False] = () in                   f |] +#if __GLASGOW_HASKELL__ >= 707+type family ClosedTF a where+  ClosedTF Int = Bool+  ClosedTF x   = Char++test_expand5 = [| let f :: ClosedTF Int -> ()+                      f True = () in+                  f |]+test_expand6 = [| let f :: ClosedTF Double -> ()+                      f 'x' = () 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@@ -180,8 +213,10 @@  #if __GLASGOW_HASKELL__ < 707 dec_test_nums = [1..9] :: [Int]-#else+#elif __GLASGOW_HASKELL__ < 709 dec_test_nums = [1..10] :: [Int]+#else+dec_test_nums = [1..11] :: [Int] #endif  dectest1 = [d| data Dec1 = Foo | Bar Int |]@@ -217,6 +252,16 @@                   Dec10 Bool = [] |] #endif +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+ instance_test = [d| instance (Show a, Show b) => Show (a -> b) where                        show _ = "function" |] @@ -263,3 +308,58 @@     -- used for expand+++reifyDecs :: Q [Dec]+reifyDecs = [d|+  r1 :: a -> a+  r1 x = x++  class R2 a b where+    r3 :: a -> b -> c -> a+    type R4 b a :: *+    data R5 a :: *++  data R6 a = R7 { r8 :: a -> a, r9 :: Bool }++  instance R2 (R6 a) a where+    r3 = undefined+    type R4 a (R6 a) = a+    data R5 (R6 a) = forall b. Show b => R10 { r11 :: a, naughty :: b }++  type family R12 a b :: *++  data family R13 a :: *++  data instance R13 Int = R14 { r15 :: Bool }++  r16, r17 :: Int+  (r16, r17) = (5, 6)++  newtype R18 = R19 Bool++  type R20 = Bool+#if __GLASGOW_HASKELL__ >= 707+  type family R21 (a :: k) (b :: k) :: k where R21 a b = b+#endif+  |]++reifyDecsNames :: [Name]+reifyDecsNames = map mkName+  [ "r1", "R2", "r3", "R4", "R5", "R6", "R7", "r8", "r9", "R10", "r11"+  , "R12", "R13", "R14", "r15", "r16", "r17", "R18", "R19", "R20"+#if __GLASGOW_HASKELL__ >= 707+  , "R21"+#endif+  ]++simplCaseTests :: [Q Exp]+simplCaseTests =+  [ [| map (\a -> case a :: [Int] of+        (_:_:_:_) -> (5 :: Int)+        _         -> 6) [[], [1], [1,2,3]]+     |]+  , [| let foo [] = True+           foo _  = False in (foo [], foo "hi") |]+  ]+                             

@@ -1,5 +1,5 @@ name:           th-desugar-version:        1.4.2.1+version:        1.5 cabal-version:  >= 1.10 synopsis:       Functions to desugar Template Haskell homepage:       http://www.cis.upenn.edu/~eir/packages/th-desugar@@ -26,7 +26,7 @@ source-repository this   type:     git   location: https://github.com/goldfirere/th-desugar.git-  tag:      v1.4.2.1+  tag:      v1.5  library   build-depends:      @@ -34,14 +34,17 @@       template-haskell,       containers >= 0.5,       mtl >= 2.1,-      syb >= 0.4+      syb >= 0.4,+      th-lift >= 0.6.1   default-extensions: TemplateHaskell   exposed-modules:    Language.Haskell.TH.Desugar,                       Language.Haskell.TH.Desugar.Sweeten,-                      Language.Haskell.TH.Desugar.Expand,-                      Language.Haskell.TH.Desugar.Lift+                      Language.Haskell.TH.Desugar.Lift,+                      Language.Haskell.TH.Desugar.Expand   other-modules:      Language.Haskell.TH.Desugar.Core,-                      Language.Haskell.TH.Desugar.Util+                      Language.Haskell.TH.Desugar.Match,+                      Language.Haskell.TH.Desugar.Util,+                      Language.Haskell.TH.Desugar.Reify   default-language:   Haskell2010   ghc-options:        -Wall @@ -61,4 +64,5 @@       mtl >= 2.1,       syb >= 0.4,       HUnit >= 1.2,-      hspec >= 1.11+      hspec >= 1.3,+      th-lift >= 0.6.1