th-desugar 1.1.1 → 1.2.0
raw patch · 6 files changed
+99/−71 lines, 6 files
Files
- CHANGES.md +5/−0
- Language/Haskell/TH/Desugar/Core.hs +51/−46
- Language/Haskell/TH/Desugar/Expand.hs +10/−9
- Language/Haskell/TH/Desugar/Sweeten.hs +2/−1
- Language/Haskell/TH/Desugar/Util.hs +14/−12
- th-desugar.cabal +17/−3
CHANGES.md view
@@ -1,3 +1,8 @@+Version 1.2.0+-------------+* Generalized interface to allow any member of the `Qausi` class, instead of+ just `Q`.+ Version 1.1.1 ------------- * Made compatible with HEAD after change in role annotation syntax.
Language/Haskell/TH/Desugar/Core.hs view
@@ -11,9 +11,9 @@ module Language.Haskell.TH.Desugar.Core where -import Prelude hiding (mapM, foldl, foldr, all, elem)+import Prelude hiding (mapM, foldl, foldr, all, elem, exp) -import Language.Haskell.TH+import Language.Haskell.TH hiding (match, clause, cxt) import Language.Haskell.TH.Syntax hiding (lift) import Control.Applicative@@ -98,7 +98,7 @@ deriving (Show, Typeable, Data) -- | Desugar an expression-dsExp :: Exp -> Q DExp+dsExp :: Quasi q => Exp -> q DExp dsExp (VarE n) = return $ DVarE n dsExp (ConE n) = return $ DConE n dsExp (LitE lit) = return $ DLitE lit@@ -106,7 +106,7 @@ dsExp (InfixE Nothing op Nothing) = dsExp op dsExp (InfixE (Just lhs) op Nothing) = DAppE <$> (dsExp op) <*> (dsExp lhs) dsExp (InfixE Nothing op (Just rhs)) = do- lhsName <- newName "lhs"+ lhsName <- qNewName "lhs" op' <- dsExp op rhs' <- dsExp rhs return $ DLamE [lhsName] (foldl DAppE op' [DVarE lhsName, rhs'])@@ -117,7 +117,7 @@ dsExp (ParensE exp) = dsExp exp dsExp (LamE pats exp) = dsLam pats =<< dsExp exp dsExp (LamCaseE matches) = do- x <- newName "x"+ x <- qNewName "x" matches' <- dsMatches x matches return $ DLamE [x] (DCaseE (DVarE x) matches') dsExp (TupE exps) = do@@ -135,7 +135,7 @@ dsGuards guarded_exps failure dsExp (LetE decs exp) = DLetE <$> dsLetDecs decs <*> dsExp exp dsExp (CaseE exp matches) = do- scrutinee <- newName "scrutinee"+ scrutinee <- qNewName "scrutinee" exp' <- dsExp exp matches' <- dsMatches scrutinee matches return $ DLetE [DValD (DVarP scrutinee) exp'] $@@ -179,13 +179,13 @@ matches <- mapM con_to_dmatch filtered_cons return $ DCaseE exp' (matches ++ [error_match]) where- extract_first_arg :: Type -> Q Type+ extract_first_arg :: Quasi 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 :: Type -> Q Name+ extract_type_name :: Quasi 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@@ -196,10 +196,10 @@ all (`elem` con_field_names) field_names _ -> False) cons - con_to_dmatch :: Con -> Q DMatch+ con_to_dmatch :: Quasi 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 (newName . nameBase) con_field_names+ field_var_names <- mapM (qNewName . nameBase) con_field_names DMatch (DConP con_name (map DVarP field_var_names)) <$> (foldl DAppE (DConE con_name) <$> (reorderFields args field_exps (map DVarE field_var_names)))@@ -211,24 +211,25 @@ fst_of_3 (x, _, _) = x -- | Desugar a lambda expression, where the body has already been desugared-dsLam :: [Pat] -> DExp -> Q DExp+dsLam :: Quasi q => [Pat] -> DExp -> q DExp dsLam pats exp | Just names <- mapM stripVarP_maybe pats = return $ DLamE names exp | otherwise- = do arg_names <- replicateM (length pats) (newName "arg")+ = do arg_names <- replicateM (length pats) (qNewName "arg") let scrutinee = mkTupleDExp (map DVarE arg_names) (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-dsMatches :: Name -- ^ Name of the scrutinee, which must be a bare var+dsMatches :: Quasi q+ => Name -- ^ Name of the scrutinee, which must be a bare var -> [Match] -- ^ Matches of the @case@ statement- -> Q [DMatch]+ -> q [DMatch] dsMatches scr = go where- go :: [Match] -> Q [DMatch]+ go :: Quasi q => [Match] -> q [DMatch] go [] = return [] go (Match pat body where_decs : rest) = do rest' <- go rest@@ -238,10 +239,11 @@ return (DMatch pat' exp'' : rest') -- | Desugar a @Body@-dsBody :: Body -- ^ body to desugar+dsBody :: Quasi q+ => Body -- ^ body to desugar -> [Dec] -- ^ "where" declarations -> DExp -- ^ what to do if the guards don't match- -> Q DExp+ -> q DExp dsBody (NormalB exp) decs _ = maybeDLetE <$> dsLetDecs decs <*> dsExp exp dsBody (GuardedB guarded_exps) decs failure =@@ -258,22 +260,24 @@ maybeDCaseE _ scrut matches = DCaseE scrut matches -- | Desugar guarded expressions-dsGuards :: [(Guard, Exp)] -- ^ Guarded expressions+dsGuards :: Quasi q+ => [(Guard, Exp)] -- ^ Guarded expressions -> DExp -- ^ What to do if none of the guards match- -> Q DExp+ -> q DExp dsGuards [] thing_inside = return thing_inside-dsGuards ((NormalG guard, exp) : rest) thing_inside =- dsGuards ((PatG [NoBindS guard], exp) : rest) thing_inside+dsGuards ((NormalG gd, exp) : rest) thing_inside =+ dsGuards ((PatG [NoBindS gd], exp) : rest) thing_inside dsGuards ((PatG stmts, exp) : rest) thing_inside = do success <- dsExp exp failure <- dsGuards rest thing_inside dsGuardStmts stmts success failure -- | Desugar the @Stmt@s in a guard-dsGuardStmts :: [Stmt] -- ^ The @Stmt@s to desugar+dsGuardStmts :: Quasi 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- -> Q DExp+ -> q DExp dsGuardStmts [] success _failure = return success dsGuardStmts (BindS pat exp : rest) success failure = do success' <- dsGuardStmts rest success failure@@ -292,7 +296,7 @@ dsGuardStmts (ParS _ : _) _ _ = impossible "Parallel comprehension in a pattern guard." -- | Desugar the @Stmt@s in a @do@ expression-dsDoStmts :: [Stmt] -> Q DExp+dsDoStmts :: Quasi 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@@ -307,7 +311,7 @@ dsDoStmts (ParS _ : _) = impossible "Parallel comprehension in a do-statement." -- | Desugar the @Stmt@s in a list or monad comprehension-dsComp :: [Stmt] -> Q DExp+dsComp :: Quasi 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@@ -327,7 +331,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 :: [[Stmt]] -> Q (Pat, DExp)+dsParComp :: Quasi q => [[Stmt]] -> q (Pat, DExp) dsParComp [] = impossible "Empty list of parallel comprehension statements." dsParComp [r] = do let rv = foldMap extractBoundNamesStmt r@@ -352,14 +356,14 @@ -- | 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 :: Quasi q => 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 :: Quasi q => [Pat] -> DExp -> q ([DPat], DExp) dsPatsOverExp pats exp = do (pats', vars) <- runWriterT $ mapM dsPat pats let name_decs = uncurry (zipWith (DValD . DVarP)) $ unzip vars@@ -367,16 +371,16 @@ -- | 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 :: Quasi q => 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+type PatM q = WriterT [(Name, DExp)] q -- | Desugar a pattern.-dsPat :: Pat -> PatM DPat+dsPat :: Quasi q => Pat -> PatM q DPat dsPat (LitP lit) = return $ DLitP lit dsPat (VarP n) = return $ DVarP n dsPat (TupP pats) = DConP (tupleDataName (length pats)) <$> mapM dsPat pats@@ -426,20 +430,20 @@ -- | Remove all wildcards from a pattern, replacing any wildcard with a fresh -- variable-removeWilds :: DPat -> Q DPat+removeWilds :: Quasi q => DPat -> q DPat removeWilds p@(DLitP _) = return p removeWilds p@(DVarP _) = return p removeWilds (DConP con_name pats) = DConP con_name <$> mapM removeWilds pats removeWilds (DTildeP pat) = DTildeP <$> removeWilds pat removeWilds (DBangP pat) = DBangP <$> removeWilds pat-removeWilds DWildP = DVarP <$> newName "wild"+removeWilds DWildP = DVarP <$> qNewName "wild" -- | Desugar @Dec@s that can appear in a let expression-dsLetDecs :: [Dec] -> Q [DLetDec]+dsLetDecs :: Quasi q => [Dec] -> q [DLetDec] dsLetDecs = concatMapM dsLetDec -- | Desugar a single @Dec@, perhaps producing multiple 'DLetDec's-dsLetDec :: Dec -> Q [DLetDec]+dsLetDec :: Quasi q => Dec -> q [DLetDec] dsLetDec (FunD name clauses) = do clauses' <- dsClauses name clauses return [DFunD name clauses']@@ -458,9 +462,10 @@ dsLetDec _dec = impossible "Illegal declaration in let expression." -- | Desugar clauses to a function definition-dsClauses :: Name -- ^ Name of the function+dsClauses :: Quasi q+ => Name -- ^ Name of the function -> [Clause] -- ^ Clauses to desugar- -> Q [DClause]+ -> q [DClause] 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@@ -470,14 +475,14 @@ 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")+dsClauses n clauses@(Clause outer_pats _ _ : _) = do+ arg_names <- replicateM (length outer_pats) (qNewName "arg") let scrutinee = mkTupleDExp (map DVarE arg_names) clause <- DClause (map DVarP arg_names) <$> (DCaseE scrutinee <$> foldrM (clause_to_dmatch scrutinee) [] clauses) return [clause] where- clause_to_dmatch :: DExp -> Clause -> [DMatch] -> Q [DMatch]+ clause_to_dmatch :: Quasi q => DExp -> Clause -> [DMatch] -> q [DMatch] clause_to_dmatch scrutinee (Clause pats body where_decs) failure_matches = do exp <- dsBody body where_decs failure_exp (pats', exp') <- dsPatsOverExp pats exp@@ -486,7 +491,7 @@ failure_exp = maybeDCaseE ("Non-exhaustive patterns in " ++ (show n)) scrutinee failure_matches -- | Desugar a type-dsType :: Type -> Q DType+dsType :: Quasi q => Type -> q DType dsType (ForallT tvbs preds ty) = DForallT <$> mapM dsTvb tvbs <*> mapM dsPred preds <*> dsType ty dsType (AppT t1 t2) = DAppT <$> dsType t1 <*> dsType t2 dsType (SigT ty ki) = DSigT <$> dsType ty <*> dsKind ki@@ -509,17 +514,17 @@ dsType (LitT lit) = return $ DLitT lit -- | Desugar a @TyVarBndr@-dsTvb :: TyVarBndr -> Q DTyVarBndr+dsTvb :: Quasi q => TyVarBndr -> q DTyVarBndr dsTvb (PlainTV n) = return $ DPlainTV n dsTvb (KindedTV n k) = DKindedTV n <$> dsKind k -- | Desugar a @Pred@-dsPred :: Pred -> Q DPred+dsPred :: Quasi q => Pred -> q DPred dsPred (ClassP n tys) = DClassP n <$> mapM dsType tys dsPred (EqualP t1 t2) = DEqualP <$> dsType t1 <*> dsType t2 -- | Desugar a kind-dsKind :: Kind -> Q DKind+dsKind :: Quasi q => Kind -> q DKind dsKind (ForallT tvbs cxt ki) | [] <- cxt , Just names <- mapM stripPlainTV_maybe tvbs@@ -554,10 +559,10 @@ -- 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 :: [VarStrictType] -> [FieldExp] -> [DExp] -> Q [DExp]+reorderFields :: Quasi q => [VarStrictType] -> [FieldExp] -> [DExp] -> q [DExp] reorderFields = reorderFields' dsExp -reorderFieldsPat :: [VarStrictType] -> [FieldPat] -> PatM [DPat]+reorderFieldsPat :: Quasi q => [VarStrictType] -> [FieldPat] -> PatM q [DPat] reorderFieldsPat field_decs field_pats = reorderFields' dsPat field_decs field_pats (repeat DWildP)
Language/Haskell/TH/Desugar/Expand.hs view
@@ -16,7 +16,8 @@ import qualified Data.Map as M import Control.Applicative-import Language.Haskell.TH+import Language.Haskell.TH hiding (cxt)+import Language.Haskell.TH.Syntax ( Quasi(..) ) import Data.Data import Data.Generics @@ -24,7 +25,7 @@ import Language.Haskell.TH.Desugar.Util -- | Expands all type synonyms in a desugared type.-expandType :: DType -> Q DType+expandType :: Quasi q => DType -> q DType expandType = go [] where go [] (DForallT tvbs cxt ty) =@@ -52,7 +53,7 @@ go args ty = return $ foldl DAppT ty args -- | Capture-avoiding substitution on types-substTy :: M.Map Name DType -> DType -> Q DType+substTy :: Quasi 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@@ -69,11 +70,11 @@ = return $ DVarT n substTy _ ty = return ty -substTyVarBndrs :: M.Map Name DType -> [DTyVarBndr]- -> (M.Map Name DType -> [DTyVarBndr] -> Q DType)- -> Q DType+substTyVarBndrs :: Quasi q => 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+ new_names <- mapM (const (qNewName "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)@@ -87,7 +88,7 @@ extractDTvbName (DPlainTV n) = n extractDTvbName (DKindedTV n _) = n -substPred :: M.Map Name DType -> DPred -> Q DPred+substPred :: Quasi q => M.Map Name DType -> DPred -> q DPred substPred vars (DClassP name tys) = DClassP name <$> mapM (substTy vars) tys substPred vars (DEqualP t1 t2) =@@ -95,5 +96,5 @@ -- | 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 :: (Quasi q, Data a) => a -> q a expand = everywhereM (mkM expandType)
Language/Haskell/TH/Desugar/Sweeten.hs view
@@ -13,7 +13,8 @@ module Language.Haskell.TH.Desugar.Sweeten where -import Language.Haskell.TH+import Prelude hiding (exp)+import Language.Haskell.TH hiding (cxt) import Language.Haskell.TH.Desugar.Core
Language/Haskell/TH/Desugar/Util.hs view
@@ -11,32 +11,34 @@ module Language.Haskell.TH.Desugar.Util where import Language.Haskell.TH+import Language.Haskell.TH.Syntax ( Quasi(..) ) 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--- declared.-reifyWithWarning :: Name -> Q Info-reifyWithWarning name = recover+-- | 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.")- (reify name)+ (qReify name) -- | Report that a certain TH construct is impossible-impossible :: String -> Q a+impossible :: Quasi q => String -> q a impossible err = fail (err ++ "\nThis should not happen in Haskell.\nPlease 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 :: String -- ^ Print this out on failure+getDataD :: Quasi q+ => String -- ^ Print this out on failure -> Name -- ^ Name of the datatype (@data@ or @newtype@) of interest- -> Q ([TyVarBndr], [Con])-getDataD error name = do+ -> q ([TyVarBndr], [Con])+getDataD err name = do info <- reifyWithWarning name dec <- case info of TyConI dec -> return dec@@ -47,10 +49,10 @@ _ -> badDeclaration where badDeclaration = fail $ "The name (" ++ (show name) ++ ") refers to something " ++- "other than a datatype. " ++ error+ "other than a datatype. " ++ err -- | From the name of a data constructor, retrieve its definition as a @Con@-dataConNameToCon :: Name -> Q 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
th-desugar.cabal view
@@ -1,5 +1,5 @@ name: th-desugar-version: 1.1.1+version: 1.2.0 cabal-version: >= 1.10 synopsis: Functions to desugar Template Haskell homepage: http://www.cis.upenn.edu/~eir/packages/th-desugar@@ -40,5 +40,19 @@ Language.Haskell.TH.Desugar.Expand other-modules: Language.Haskell.TH.Desugar.Core, Language.Haskell.TH.Desugar.Util default-language: Haskell2010- - ++ -- This DOES NOT WORK with GHC HEAD, so commenting it out for now.+ -- test-suite spec+ -- type: exitcode-stdio-1.0+ -- ghc-options: -Wall -Werror -main-is Test.Run+ -- default-language: Haskell2010+ -- main-is: Test/Run.hs++ -- build-depends:+ -- base >= 4 && < 5,+ -- template-haskell,+ -- containers >= 0.5,+ -- mtl >= 2.1,+ -- syb >= 0.4,+ -- HUnit >= 1.2,+ -- hspec >= 1.3