th-desugar 1.0.0 → 1.1.0

raw patch · 6 files changed

+271/−98 lines, 6 filesdep +mtldep +sybPVP ok

version bump matches the API change (PVP)

Dependencies added: mtl, syb

API changes (from Hackage documentation)

Files

• CHANGES.md +14/−0
• Language/Haskell/TH/Desugar.hs +4/−2
• Language/Haskell/TH/Desugar/Core.hs +122/−92
• Language/Haskell/TH/Desugar/Expand.hs +107/−0
• Language/Haskell/TH/Desugar/Util.hs +16/−0
• th-desugar.cabal +8/−4

@@ -1,3 +1,17 @@+Version 1.1+-----------+* Added module `Language.Haskell.TH.Desugar.Expand`, which allows for expansion+  of type synonyms in desugared types.+* Added `Show`, `Typeable`, and `Data` instances to desugared types.+* Fixed bug where an as-pattern in a `let` statement was scoped incorrectly.+* Changed signature of `dsPat` to be more specific to as-patterns; this allowed+  for fixing the `let` scoping bug.+* Created new functions `dsPatOverExp` and `dsPatsOverExp` to allow for easy+  desugaring of patterns.+* Changed signature of `dsLetDec` to return a list of `DLetDec`s.+* Added `dsLetDecs` for convenience. Now, instead+  of using `mapM dsLetDec`, you should use `dsLetDecs`.+ Version 1.0 ----------- 

@@ -15,14 +15,16 @@   DTyVarBndr(..), DMatch(..), DClause(..),    -- * Main desugaring functions-  dsExp, dsPat, dsPats, dsLetDec, dsType, dsKind, dsTvb, dsPred,+  dsExp, dsPatOverExp, dsPatsOverExp, dsPatX,+  dsLetDecs, dsType, dsKind, dsTvb, dsPred,    -- ** Secondary desugaring functions+  PatM, dsPat, dsLetDec,   dsMatches, dsBody, dsGuards, dsDoStmts, dsComp, dsClauses,     -- * Utility functions   dPatToDExp, removeWilds, reifyWithWarning, getDataD, dataConNameToCon,-  mkTupleDExp, mkTupleDPat,+  mkTupleDExp, mkTupleDPat, maybeDLetE, maybeDCaseE,    -- ** Extracting bound names   extractBoundNamesStmt, extractBoundNamesDec, extractBoundNamesPat

@@ -7,20 +7,22 @@ processing. The desugared types and constructors are prefixed with a D. -} -{-# LANGUAGE TemplateHaskell, LambdaCase, CPP #-}+{-# LANGUAGE TemplateHaskell, LambdaCase, CPP, DeriveDataTypeable #-}  module Language.Haskell.TH.Desugar.Core where  import Prelude hiding (mapM, foldl, foldr, all, elem)  import Language.Haskell.TH-import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Syntax hiding (lift)  import Control.Applicative import Control.Monad hiding (mapM) import Control.Monad.Zip+import Control.Monad.Writer hiding (mapM) import Data.Foldable import Data.Traversable+import Data.Data hiding (Fixity)  import qualified Data.Set as S import GHC.Exts@@ -36,12 +38,14 @@           | DCaseE DExp [DMatch]           | DLetE [DLetDec] DExp           | DSigE DExp DType+          deriving (Show, Typeable, Data)  -- | Declarations as used in a @let@ statement. Other @Dec@s are not desugared. data DLetDec = DFunD Name [DClause]              | DValD DPat DExp              | DSigD Name DType              | DInfixD Fixity Name+             deriving (Show, Typeable, Data)  -- | Corresponds to TH's @Pat@ type. data DPat = DLitP Lit@@ -50,6 +54,7 @@           | DTildeP DPat           | DBangP DPat           | DWildP+          deriving (Show, Typeable, Data)  -- | Corresponds to TH's @Type@ type. data DType = DForallT [DTyVarBndr] DCxt DType@@ -59,6 +64,7 @@            | DConT Name            | DArrowT            | DLitT TyLit+           deriving (Show, Typeable, Data)  -- | Corresponds to TH's @Kind@ type, which is a synonym for @Type@. 'DKind', though, --   only contains constructors that make sense for kinds.@@ -67,6 +73,7 @@            | DConK Name [DKind]            | DArrowK DKind DKind            | DStarK+           deriving (Show, Typeable, Data)  -- | Corresponds to TH's @Cxt@ type DCxt = [DPred]@@ -74,6 +81,7 @@ -- | Corresponds to TH's @Pred@ data DPred = DClassP Name [DType]            | DEqualP DType DType+           deriving (Show, Typeable, Data)  -- | Corresponds to TH's @TyVarBndr@. Note that @PlainTV x@ and @KindedTV x StarT@ are --   distinct, so we retain that distinction here.@@ -83,12 +91,15 @@                 | DRoledTV Name Role                 | DKindedRoledTV Name DKind Role #endif+                deriving (Show, Typeable, Data)  -- | Corresponds to TH's @Match@ type. data DMatch = DMatch DPat DExp+  deriving (Show, Typeable, Data)  -- | Corresponds to TH's @Clause@ type. data DClause = DClause [DPat] DExp+  deriving (Show, Typeable, Data)  -- | Desugar an expression dsExp :: Exp -> Q DExp@@ -126,7 +137,7 @@ dsExp (MultiIfE guarded_exps) =   let failure = DAppE (DVarE 'error) (DLitE (StringL "None-exhaustive guards in multi-way if")) in   dsGuards guarded_exps failure-dsExp (LetE decs exp) = DLetE <$> mapM dsLetDec decs <*> dsExp exp+dsExp (LetE decs exp) = DLetE <$> dsLetDecs decs <*> dsExp exp dsExp (CaseE exp matches) = do   scrutinee <- newName "scrutinee"   exp' <- dsExp exp@@ -211,8 +222,8 @@   | otherwise   = do arg_names <- replicateM (length pats) (newName "arg")        let scrutinee = mkTupleDExp (map DVarE arg_names)-       (pats', xform) <- dsPats pats-       let match = DMatch (mkTupleDPat pats') (xform exp)+       (pats', exp') <- dsPatsOverExp pats exp+       let match = DMatch (mkTupleDPat pats') exp'        return $ DLamE arg_names (DCaseE scrutinee [match])  -- | Desugar a list of matches for a @case@ statement@@ -227,8 +238,8 @@       rest' <- go rest       let failure = DCaseE (DVarE scr) rest'  -- this might be an empty case.       exp' <- dsBody body where_decs failure-      (pat', xform) <- dsPat pat-      return (DMatch pat' (xform exp') : rest')+      (pat', exp'') <- dsPatOverExp pat exp'+      return (DMatch pat' exp'' : rest')  -- | Desugar a @Body@ dsBody :: Body      -- ^ body to desugar@@ -236,9 +247,9 @@        -> DExp      -- ^ what to do if the guards don't match        -> Q DExp dsBody (NormalB exp) decs _ =-  maybeDLetE <$> mapM dsLetDec decs <*> dsExp exp+  maybeDLetE <$> dsLetDecs decs <*> dsExp exp dsBody (GuardedB guarded_exps) decs failure =-  maybeDLetE <$> mapM dsLetDec decs <*> dsGuards guarded_exps failure+  maybeDLetE <$> dsLetDecs decs <*> dsGuards guarded_exps failure  -- | If decs is non-empty, delcare them in a let: maybeDLetE :: [DLetDec] -> DExp -> DExp@@ -269,12 +280,12 @@              -> Q DExp dsGuardStmts [] success _failure = return success dsGuardStmts (BindS pat exp : rest) success failure = do-  (pat', xform) <- dsPat pat-  exp' <- dsExp exp   success' <- dsGuardStmts rest success failure-  return $ DCaseE exp' [DMatch pat' (xform success'), DMatch DWildP failure]+  (pat', success'') <- dsPatOverExp pat success'+  exp' <- dsExp exp+  return $ DCaseE exp' [DMatch pat' success'', DMatch DWildP failure] dsGuardStmts (LetS decs : rest) success failure = do-  decs' <- mapM dsLetDec decs+  decs' <- dsLetDecs decs   success' <- dsGuardStmts rest success failure   return $ DLetE decs' success' dsGuardStmts (NoBindS exp : rest) success failure = do@@ -292,7 +303,7 @@   exp' <- dsExp exp   rest' <- dsDoStmts rest   DAppE (DAppE (DVarE '(>>=)) exp') <$> dsLam [pat] rest'-dsDoStmts (LetS decs : rest) = DLetE <$> mapM dsLetDec decs <*> dsDoStmts rest+dsDoStmts (LetS decs : rest) = DLetE <$> dsLetDecs decs <*> dsDoStmts rest dsDoStmts (NoBindS exp : rest) = do   exp' <- dsExp exp   rest' <- dsDoStmts rest@@ -307,7 +318,7 @@   exp' <- dsExp exp   rest' <- dsComp rest   DAppE (DAppE (DVarE '(>>=)) exp') <$> dsLam [pat] rest'-dsComp (LetS decs : rest) = DLetE <$> mapM dsLetDec decs <*> dsComp rest+dsComp (LetS decs : rest) = DLetE <$> dsLetDecs decs <*> dsComp rest dsComp (NoBindS exp : rest) = do   exp' <- dsExp exp   rest' <- dsComp rest@@ -343,64 +354,71 @@ mk_tuple_pat name_set =   mkTuplePat (S.foldr ((:) . VarP) [] name_set) --- | Desugar a pattern, returning the desugared pattern and a transformation to---   be applied to the scope of the pattern match-dsPat :: Pat -> Q (DPat, DExp -> DExp)-dsPat (LitP lit) = return (DLitP lit, id)-dsPat (VarP n) = return (DVarP n, id)-dsPat (TupP pats) = dsConPats (tupleDataName (length pats)) pats-dsPat (UnboxedTupP pats) = dsConPats (unboxedTupleDataName (length pats)) pats-dsPat (ConP name pats) = dsConPats name pats-dsPat (InfixP p1 name p2) = dsConPats name [p1, p2]+-- | Desugar a pattern, along with processing a (desugared) expression that+-- is the entire scope of the variables bound in the pattern.+dsPatOverExp :: Pat -> DExp -> Q (DPat, DExp)+dsPatOverExp pat exp = do+  (pat', vars) <- runWriterT $ dsPat pat+  let name_decs = uncurry (zipWith (DValD . DVarP)) $ unzip vars+  return (pat', maybeDLetE name_decs exp)++-- | Desugar multiple patterns. Like 'dsPatOverExp'.+dsPatsOverExp :: [Pat] -> DExp -> Q ([DPat], DExp)+dsPatsOverExp pats exp = do+  (pats', vars) <- runWriterT $ mapM dsPat pats+  let name_decs = uncurry (zipWith (DValD . DVarP)) $ unzip vars+  return (pats', maybeDLetE name_decs exp)++-- | Desugar a pattern, returning a list of (Name, DExp) pairs of extra+-- variables that must be bound within the scope of the pattern+dsPatX :: Pat -> Q (DPat, [(Name, DExp)])+dsPatX = runWriterT . dsPat++-- | Desugaring a pattern also returns the list of variables bound in as-patterns+-- and the values they should be bound to. This variables must be brought into+-- scope in the "body" of the pattern.+type PatM = WriterT [(Name, DExp)] Q++-- | Desugar a pattern.+dsPat :: Pat -> PatM DPat+dsPat (LitP lit) = return $ DLitP lit+dsPat (VarP n) = return $ DVarP n+dsPat (TupP pats) = DConP (tupleDataName (length pats)) <$> mapM dsPat pats+dsPat (UnboxedTupP pats) = DConP (unboxedTupleDataName (length pats)) <$>+                           mapM dsPat pats+dsPat (ConP name pats) = DConP name <$> mapM dsPat pats+dsPat (InfixP p1 name p2) = DConP name <$> mapM dsPat [p1, p2] dsPat (UInfixP _ _ _) =   fail "Cannot desugar unresolved infix operators." dsPat (ParensP pat) = dsPat pat-dsPat (TildeP pat) = dsPatModifier DTildeP pat-dsPat (BangP pat) = dsPatModifier DBangP pat+dsPat (TildeP pat) = DTildeP <$> dsPat pat+dsPat (BangP pat) = DBangP <$> dsPat pat dsPat (AsP name pat) = do-  (pat', xform) <- dsPat pat-  pat'' <- removeWilds pat'-  let xform' exp = DLetE [DValD (DVarP name) (dPatToDExp pat'')] (xform exp)-  return (pat'', xform')-dsPat WildP = return (DWildP, id)+  pat' <- dsPat pat+  pat'' <- lift $ removeWilds pat'+  tell [(name, dPatToDExp pat'')]+  return pat''+dsPat WildP = return DWildP dsPat (RecP con_name field_pats) = do-  con <- dataConNameToCon con_name-  (reordered, xform) <- case con of+  con <- lift $ dataConNameToCon con_name+  reordered <- case con of     RecC _name fields -> reorderFieldsPat fields field_pats-    _ -> impossible $ "Record syntax used with non-record constructor "-                      ++ (show con_name) ++ "."-  return (DConP con_name reordered, xform)+    _ -> lift $ impossible $ "Record syntax used with non-record constructor "+                             ++ (show con_name) ++ "."+  return $ DConP con_name reordered dsPat (ListP pats) = go pats-  where go [] = return (DConP '[] [], id)+  where go [] = return $ DConP '[] []         go (h : t) = do-          (h', xform_h) <- dsPat h-          (t', xform_t) <- go t-          return (DConP '(:) [h', t'], xform_h . xform_t)+          h' <- dsPat h+          t' <- go t+          return $ DConP '(:) [h', t'] dsPat (SigP _ _) =-  impossible ("At last check (Aug 2013), type patterns in signatures are not\n" +++  lift $ impossible+             ("At last check (Aug 2013), type patterns in signatures are not\n" ++               "supported in GHC. They are not supported in th-desugar either.") dsPat (ViewP _ _) =   fail "View patterns are not supported in th-desugar. Use pattern guards instead." --- | Desugar a list of patterns, producing a list of desugared patterns and one---   transformation (like 'dsPat')-dsPats :: [Pat] -> Q ([DPat], DExp -> DExp)-dsPats pats = do-  (pats', xforms) <- mapAndUnzipM dsPat pats-  return (pats', foldr (.) id xforms)---- | Desugar patterns that are the arguments to a data constructor-dsConPats :: Name -> [Pat] -> Q (DPat, DExp -> DExp)-dsConPats name pats = do-  (pats', xform) <- dsPats pats-  return (DConP name pats', xform)---- | Desugar a modified pattern (e.g., body of a @TildeP@)-dsPatModifier :: (DPat -> DPat) -> Pat -> Q (DPat, DExp -> DExp)-dsPatModifier mod pat = do-  (pat', xform) <- dsPat pat-  return (mod pat', xform)- -- | Convert a 'DPat' to a 'DExp'. Fails on 'DWildP'. dPatToDExp :: DPat -> DExp dPatToDExp (DLitP lit) = DLitE lit@@ -421,16 +439,26 @@ removeWilds DWildP = DVarP <$> newName "wild"  -- | Desugar @Dec@s that can appear in a let expression-dsLetDec :: Dec -> Q DLetDec-dsLetDec (FunD name clauses) = DFunD name <$> dsClauses name clauses+dsLetDecs :: [Dec] -> Q [DLetDec]+dsLetDecs = concatMapM dsLetDec++-- | Desugar a single @Dec@, perhaps producing multiple 'DLetDec's+dsLetDec :: Dec -> Q [DLetDec]+dsLetDec (FunD name clauses) = do+  clauses' <- dsClauses name clauses+  return [DFunD name clauses'] dsLetDec (ValD pat body where_decs) = do-  (pat', xform) <- dsPat pat-  DValD pat' <$> (xform <$> dsBody body where_decs error_exp)+  (pat', vars) <- dsPatX pat+  body' <- dsBody body where_decs error_exp+  let extras = uncurry (zipWith (DValD . DVarP)) $ unzip vars+  return $ DValD pat' body' : extras   where     error_exp = DAppE (DVarE 'error) (DLitE                        (StringL $ "Non-exhaustive patterns for " ++ pprint pat))-dsLetDec (SigD name ty) = DSigD name <$> dsType ty-dsLetDec (InfixD fixity name) = return $ DInfixD fixity name+dsLetDec (SigD name ty) = do+  ty' <- dsType ty+  return [DSigD name ty']+dsLetDec (InfixD fixity name) = return [DInfixD fixity name] dsLetDec _dec = impossible "Illegal declaration in let expression."  -- | Desugar clauses to a function definition@@ -440,10 +468,12 @@ dsClauses _ [] = return [] dsClauses n (Clause pats (NormalB exp) where_decs : rest) = do   -- this is just a convenience optimization; we could tuple up all the patterns-  (pats', xform) <- dsPats pats-  (:) <$>-    DClause pats' <$> (xform <$> (maybeDLetE <$> mapM dsLetDec where_decs <*> dsExp exp)) <*>-    dsClauses n rest+  rest' <- dsClauses n rest+  exp' <- dsExp exp+  where_decs' <- dsLetDecs where_decs+  let exp_with_wheres = maybeDLetE where_decs' exp'+  (pats', exp'') <- dsPatsOverExp pats exp_with_wheres+  return $ DClause pats' exp'' : rest' dsClauses n clauses@(Clause pats _ _ : _) = do   arg_names <- replicateM (length pats) (newName "arg")   let scrutinee = mkTupleDExp (map DVarE arg_names)@@ -453,12 +483,12 @@   where     clause_to_dmatch :: DExp -> Clause -> [DMatch] -> Q [DMatch]     clause_to_dmatch scrutinee (Clause pats body where_decs) failure_matches = do-      (pats', xform) <- dsPats pats-      let failure_exp = maybeDCaseE ("Non-exhaustive patterns in " ++ (show n))-                                    scrutinee failure_matches       exp <- dsBody body where_decs failure_exp-      return (DMatch (mkTupleDPat pats') (xform exp) : failure_matches)-+      (pats', exp') <- dsPatsOverExp pats exp+      return (DMatch (mkTupleDPat pats') exp' : failure_matches)+      where+        failure_exp = maybeDCaseE ("Non-exhaustive patterns in " ++ (show n))+                                  scrutinee failure_matches -- | Desugar a type dsType :: Type -> Q DType dsType (ForallT tvbs preds ty) = DForallT <$> mapM dsTvb tvbs <*> mapM dsPred preds <*> dsType ty@@ -533,24 +563,24 @@ -- if a field is missing from the second argument, use the corresponding expression -- from the third argument reorderFields :: [VarStrictType] -> [FieldExp] -> [DExp] -> Q [DExp]-reorderFields [] _ _ = return []-reorderFields ((field_name, _, _) : rest) field_exps (deflt : rest_deflt) = do-  rest' <- reorderFields rest field_exps rest_deflt-  case find (\(exp_name, _) -> exp_name == field_name) field_exps of-    Just (_, exp) -> (: rest') <$> dsExp exp-    Nothing -> return $ deflt : rest'-reorderFields (_ : _) _ [] = impossible "Internal error in th-desugar."+reorderFields = reorderFields' dsExp --- like reorderFields, but for patterns, assuming a default of DWildP-reorderFieldsPat :: [VarStrictType] -> [FieldPat] -> Q ([DPat], DExp -> DExp)-reorderFieldsPat [] _ = return ([], id)-reorderFieldsPat ((field_name, _, _) : rest) field_pats = do-  (rest', rest_xform) <- reorderFieldsPat rest field_pats-  case find (\(pat_name, _) -> pat_name == field_name) field_pats of-    Just (_, pat) -> do-      (pat', xform) <- dsPat pat-      return $ (pat' : rest', xform . rest_xform)-    Nothing -> return (DWildP : rest', rest_xform)+reorderFieldsPat :: [VarStrictType] -> [FieldPat] -> PatM [DPat]+reorderFieldsPat field_decs field_pats =+  reorderFields' dsPat field_decs field_pats (repeat DWildP)++reorderFields' :: (Applicative m, Monad m)+               => (a -> m da)+               -> [VarStrictType] -> [(Name, a)]+               -> [da] -> m [da]+reorderFields' _ [] _ _ = return []+reorderFields' ds_thing ((field_name, _, _) : rest)+               field_things (deflt : rest_deflt) = do+  rest' <- reorderFields' ds_thing rest field_things rest_deflt+  case find (\(thing_name, _) -> thing_name == field_name) field_things of+    Just (_, thing) -> (: rest') <$> ds_thing thing+    Nothing -> return $ deflt : rest'+reorderFields' _ (_ : _) _ [] = error "Internal error in th-desugar."  -- | Make a tuple 'DExp' from a list of 'DExp's. Avoids using a 1-tuple. mkTupleDExp :: [DExp] -> DExp

@@ -0,0 +1,107 @@+{- Language/Haskell/TH/Desugar/Expand.hs++(c) Richard Eisenberg 2013+eir@cis.upenn.edu+-}++{-# LANGUAGE CPP #-}++{-| Expands type synonyms in desugared types, ignoring type families.+See also the package th-expand-syns for doing this to non-desugared types.+-}++module Language.Haskell.TH.Desugar.Expand (+  expand, expandType, substTy+  ) where++import qualified Data.Map as M+import Control.Applicative+import Language.Haskell.TH+import Data.Data+import Data.Generics++import Language.Haskell.TH.Desugar.Core+import Language.Haskell.TH.Desugar.Util++-- | Expands all type synonyms in a desugared type.+expandType :: DType -> Q DType+expandType = go []+  where+    go [] (DForallT tvbs cxt ty) =+      DForallT tvbs <$> mapM expand cxt <*> expandType ty+    go _ (DForallT {}) =+      impossible "A forall type is applied to another type."+    go args (DAppT t1 t2) = do+      t2' <- expandType t2+      go (t2' : args) t1+    go args (DSigT ty ki) = do+      ty' <- go [] ty+      return $ foldl DAppT (DSigT ty' ki) args+    go args (DConT n) = do+      info <- reifyWithWarning n+      case info of+        TyConI (TySynD _n tvbs rhs)+          | length args >= length tvbs -> do+          let (syn_args, rest_args) = splitAtList tvbs args+          rhs' <- dsType rhs+          rhs'' <- expandType rhs'+          tvbs' <- mapM dsTvb tvbs+          ty <- substTy (M.fromList $ zip (map extractDTvbName tvbs') syn_args) rhs''+          return $ foldl DAppT ty rest_args+        _ -> return $ foldl DAppT (DConT n) args+    go args ty = return $ foldl DAppT ty args++-- | Capture-avoiding substitution on types+substTy :: M.Map Name DType -> DType -> Q DType+substTy vars (DForallT tvbs cxt ty) =+  substTyVarBndrs vars tvbs $ \vars' tvbs' -> do+    cxt' <- mapM (substPred vars') cxt+    ty' <- substTy vars' ty+    return $ DForallT tvbs' cxt' ty'+substTy vars (DAppT t1 t2) =+  DAppT <$> substTy vars t1 <*> substTy vars t2+substTy vars (DSigT ty ki) =+  DSigT <$> substTy vars ty <*> pure ki+substTy vars (DVarT n)+  | Just ty <- M.lookup n vars+  = return ty+  | otherwise+  = return $ DVarT n+substTy _ ty = return ty++substTyVarBndrs :: M.Map Name DType -> [DTyVarBndr]+                -> (M.Map Name DType -> [DTyVarBndr] -> Q DType)+                -> Q DType+substTyVarBndrs vars tvbs thing = do+  new_names <- mapM (const (newName "local")) tvbs+  let new_vars = M.fromList (zip (map extractDTvbName tvbs) (map DVarT new_names))+  -- this is very inefficient. Oh well.+  thing (M.union vars new_vars) (zipWith substTvb tvbs new_names)++substTvb :: DTyVarBndr -> Name -> DTyVarBndr+substTvb (DPlainTV _) n = DPlainTV n+substTvb (DKindedTV _ k) n = DKindedTV n k+#if __GLASGOW_HASKELL__ >= 707+substTvb (DRoledTV _ r) n = DRoledTV n r+substTvb (DKindedRoledTV _ k r) n = DKindedRoledTV n k r+#endif++-- | Extract the name from a @TyVarBndr@+extractDTvbName :: DTyVarBndr -> Name+extractDTvbName (DPlainTV n) = n+extractDTvbName (DKindedTV n _) = n+#if __GLASGOW_HASKELL__ >= 707+extractDTvbName (DRoledTV n _) = n+extractDTvbName (DKindedRoledTV n _ _) = n+#endif++substPred :: M.Map Name DType -> DPred -> Q DPred+substPred vars (DClassP name tys) =+  DClassP name <$> mapM (substTy vars) tys+substPred vars (DEqualP t1 t2) =+  DEqualP <$> substTy vars t1 <*> substTy vars t2++-- | Expand all type synonyms in the desugared abstract syntax tree provided.+-- Normally, the first parameter should have a type like 'DExp' or 'DLetDec'.+expand :: Data a => a -> Q a+expand = everywhereM (mkM expandType)

@@ -6,12 +6,15 @@ Utility functions for th-desugar package. -} +{-# LANGUAGE CPP #-}+ module Language.Haskell.TH.Desugar.Util where  import Language.Haskell.TH  import qualified Data.Set as S import Data.Foldable+import Control.Applicative  -- | 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@@ -111,3 +114,16 @@ extractBoundNamesPat (ListP pats)        = foldMap extractBoundNamesPat pats extractBoundNamesPat (SigP pat _)        = extractBoundNamesPat pat extractBoundNamesPat (ViewP _ pat)       = extractBoundNamesPat pat++-- | Concatenate the result of a @mapM@+concatMapM :: Applicative m => (a -> m [b]) -> [a] -> m [b]+concatMapM _ [] = pure []+concatMapM f (a : as) = (++) <$> f a <*> concatMapM f as++-- like GHC's+splitAtList :: [a] -> [b] -> ([b], [b])+splitAtList [] x = ([], x)+splitAtList (_ : t) (x : xs) =+  let (as, bs) = splitAtList t xs in+  (x : as, bs)+splitAtList (_ : _) [] = ([], [])      

@@ -1,5 +1,5 @@ name:           th-desugar-version:        1.0.0+version:        1.1.0 cabal-version:  >= 1.10 synopsis:       Functions to desugar Template Haskell homepage:       http://www.cis.upenn.edu/~eir/packages/th-desugar@@ -26,14 +26,18 @@ source-repository this   type:     git   location: https://github.com/goldfirere/th-desugar.git-  tag:      v1.0.0+  tag:      v1.1.0  library   build-depends:             base >= 4 && < 5,       template-haskell,-      containers >= 0.5-  exposed-modules:    Language.Haskell.TH.Desugar, Language.Haskell.TH.Desugar.Sweeten+      containers >= 0.5,+      mtl >= 2.1,+      syb >= 0.4+  exposed-modules:    Language.Haskell.TH.Desugar,+                      Language.Haskell.TH.Desugar.Sweeten,+                      Language.Haskell.TH.Desugar.Expand   other-modules:      Language.Haskell.TH.Desugar.Core, Language.Haskell.TH.Desugar.Util   default-language:   Haskell2010