th-desugar (empty) → 1.0.0
raw patch · 9 files changed
+885/−0 lines, 9 filesdep +basedep +containersdep +template-haskellsetup-changed
Dependencies added: base, containers, template-haskell
Files
- CHANGES.md +4/−0
- LICENSE +27/−0
- Language/Haskell/TH/Desugar.hs +32/−0
- Language/Haskell/TH/Desugar/Core.hs +573/−0
- Language/Haskell/TH/Desugar/Sweeten.hs +76/−0
- Language/Haskell/TH/Desugar/Util.hs +113/−0
- README.md +18/−0
- Setup.hs +2/−0
- th-desugar.cabal +40/−0
+ CHANGES.md view
@@ -0,0 +1,4 @@+Version 1.0+-----------++* Initial release
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2013, Richard Eisenberg+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice,+this list of conditions and the following disclaimer in the documentation+and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of its contributors may be+used to endorse or promote products derived from this software without+specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Language/Haskell/TH/Desugar.hs view
@@ -0,0 +1,32 @@+{- Language/Haskell/TH/Desugar.hs++(c) Richard Eisenberg 2013+eir@cis.upenn.edu+-}++{-|+Desugars full Template Haskell syntax into a smaller core syntax for further+processing. The desugared types and constructors are prefixed with a D.+-}++module Language.Haskell.TH.Desugar (+ -- * Desugared data types+ DExp(..), DLetDec(..), DPat(..), DType(..), DKind(..), DCxt, DPred(..),+ DTyVarBndr(..), DMatch(..), DClause(..),++ -- * Main desugaring functions+ dsExp, dsPat, dsPats, dsLetDec, dsType, dsKind, dsTvb, dsPred,++ -- ** Secondary desugaring functions+ dsMatches, dsBody, dsGuards, dsDoStmts, dsComp, dsClauses, ++ -- * Utility functions+ dPatToDExp, removeWilds, reifyWithWarning, getDataD, dataConNameToCon,+ mkTupleDExp, mkTupleDPat,++ -- ** Extracting bound names+ extractBoundNamesStmt, extractBoundNamesDec, extractBoundNamesPat+ ) where++import Language.Haskell.TH.Desugar.Core+import Language.Haskell.TH.Desugar.Util
+ Language/Haskell/TH/Desugar/Core.hs view
@@ -0,0 +1,573 @@+{- Language/Haskell/TH/Desugar/Core.hs++(c) Richard Eisenberg 2013+eir@cis.upenn.edu++Desugars full Template Haskell syntax into a smaller core syntax for further+processing. The desugared types and constructors are prefixed with a D.+-}++{-# LANGUAGE TemplateHaskell, LambdaCase, CPP #-}++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 Control.Applicative+import Control.Monad hiding (mapM)+import Control.Monad.Zip+import Data.Foldable+import Data.Traversable++import qualified Data.Set as S+import GHC.Exts++import Language.Haskell.TH.Desugar.Util++-- | Corresponds to TH's @Exp@ type. Note that @DLamE@ takes names, not patterns.+data DExp = DVarE Name+ | DConE Name+ | DLitE Lit+ | DAppE DExp DExp+ | DLamE [Name] DExp+ | DCaseE DExp [DMatch]+ | DLetE [DLetDec] DExp+ | DSigE DExp DType++-- | 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++-- | Corresponds to TH's @Pat@ type.+data DPat = DLitP Lit+ | DVarP Name+ | DConP Name [DPat]+ | DTildeP DPat+ | DBangP DPat+ | DWildP++-- | Corresponds to TH's @Type@ type.+data DType = DForallT [DTyVarBndr] DCxt DType+ | DAppT DType DType+ | DSigT DType DKind+ | DVarT Name+ | DConT Name+ | DArrowT+ | DLitT TyLit++-- | Corresponds to TH's @Kind@ type, which is a synonym for @Type@. 'DKind', though,+-- only contains constructors that make sense for kinds.+data DKind = DForallK [Name] DKind+ | DVarK Name+ | DConK Name [DKind]+ | DArrowK DKind DKind+ | DStarK++-- | Corresponds to TH's @Cxt@+type DCxt = [DPred]++-- | Corresponds to TH's @Pred@+data DPred = DClassP Name [DType]+ | DEqualP DType DType++-- | Corresponds to TH's @TyVarBndr@. Note that @PlainTV x@ and @KindedTV x StarT@ are+-- distinct, so we retain that distinction here.+data DTyVarBndr = DPlainTV Name+ | DKindedTV Name DKind+#if __GLASGOW_HASKELL__ >= 707+ | DRoledTV Name Role+ | DKindedRoledTV Name DKind Role+#endif++-- | Corresponds to TH's @Match@ type.+data DMatch = DMatch DPat DExp++-- | Corresponds to TH's @Clause@ type.+data DClause = DClause [DPat] DExp++-- | Desugar an expression+dsExp :: Exp -> Q DExp+dsExp (VarE n) = return $ DVarE n+dsExp (ConE n) = return $ DConE n+dsExp (LitE lit) = return $ DLitE lit+dsExp (AppE e1 e2) = DAppE <$> dsExp e1 <*> dsExp e2+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"+ op' <- dsExp op+ rhs' <- dsExp rhs+ return $ DLamE [lhsName] (foldl DAppE op' [DVarE lhsName, rhs'])+dsExp (InfixE (Just lhs) op (Just rhs)) =+ DAppE <$> (DAppE <$> dsExp op <*> dsExp lhs) <*> dsExp rhs+dsExp (UInfixE _ _ _) =+ fail "Cannot desugar unresolved infix operators."+dsExp (ParensE exp) = dsExp exp+dsExp (LamE pats exp) = dsLam pats =<< dsExp exp+dsExp (LamCaseE matches) = do+ x <- newName "x"+ matches' <- dsMatches x matches+ return $ DLamE [x] (DCaseE (DVarE x) matches')+dsExp (TupE exps) = do+ exps' <- mapM dsExp exps+ return $ foldl DAppE (DConE $ tupleDataName (length exps)) exps'+dsExp (UnboxedTupE exps) =+ foldl DAppE (DConE $ unboxedTupleDataName (length exps)) <$> mapM dsExp exps+dsExp (CondE e1 e2 e3) = do+ e1' <- dsExp e1+ e2' <- dsExp e2+ e3' <- dsExp e3+ return $ DCaseE e1' [DMatch (DConP 'True []) e2', DMatch (DConP 'False []) e3']+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 (CaseE exp matches) = do+ scrutinee <- newName "scrutinee"+ exp' <- dsExp exp+ matches' <- dsMatches scrutinee matches+ return $ DLetE [DValD (DVarP scrutinee) exp'] $+ DCaseE (DVarE scrutinee) matches'+dsExp (DoE stmts) = dsDoStmts stmts+dsExp (CompE stmts) = dsComp stmts+dsExp (ArithSeqE (FromR exp)) = DAppE (DVarE 'enumFrom) <$> dsExp exp+dsExp (ArithSeqE (FromThenR exp1 exp2)) =+ DAppE <$> (DAppE (DVarE 'enumFromThen) <$> dsExp exp1) <*> dsExp exp2+dsExp (ArithSeqE (FromToR exp1 exp2)) =+ DAppE <$> (DAppE (DVarE 'enumFromTo) <$> dsExp exp1) <*> dsExp exp2+dsExp (ArithSeqE (FromThenToR e1 e2 e3)) =+ DAppE <$> (DAppE <$> (DAppE (DVarE 'enumFromThenTo) <$> dsExp e1) <*>+ dsExp e2) <*>+ dsExp e3+dsExp (ListE exps) = go exps+ where go [] = return $ DConE '[]+ go (h : t) = DAppE <$> (DAppE (DConE '(:)) <$> dsExp h) <*> go t+dsExp (SigE exp ty) = DSigE <$> dsExp exp <*> dsType ty+dsExp (RecConE con_name field_exps) = do+ con <- dataConNameToCon con_name+ reordered <- case con of+ RecC _name fields -> reorderFields fields field_exps+ (repeat $ DVarE 'undefined)+ _ -> impossible $ "Record syntax used with non-record constructor "+ ++ (show con_name) ++ "."+ return $ foldl DAppE (DConE con_name) reordered+dsExp (RecUpdE exp field_exps) = do+ -- here, we need to use one of the field names to find the tycon, somewhat dodgily+ first_name <- case field_exps of+ ((name, _) : _) -> return name+ _ -> impossible "Record update with no fields listed."+ info <- reifyWithWarning 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."+ type_name <- extract_type_name applied_type+ (_, cons) <- getDataD "This seems to be an error in GHC." type_name+ 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])+ where+ extract_first_arg :: 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 (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++ con_to_dmatch :: 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+ DMatch (DConP con_name (map DVarP field_var_names)) <$>+ (foldl DAppE (DConE con_name) <$>+ (reorderFields args field_exps (map DVarE field_var_names)))+ con_to_dmatch _ = impossible "Internal error within th-desugar."++ error_match = DMatch DWildP (DAppE (DVarE 'error)+ (DLitE (StringL "Non-exhaustive patterns in record update")))++ fst_of_3 (x, _, _) = x++-- | Desugar a lambda expression, where the body has already been desugared+dsLam :: [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")+ let scrutinee = mkTupleDExp (map DVarE arg_names)+ (pats', xform) <- dsPats pats+ let match = DMatch (mkTupleDPat pats') (xform 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+ -> [Match] -- ^ Matches of the @case@ statement+ -> Q [DMatch]+dsMatches scr = go+ where+ go :: [Match] -> Q [DMatch]+ go [] = return []+ go (Match pat body where_decs : rest) = do+ rest' <- go rest+ let failure = DCaseE (DVarE scr) rest' -- this might be an empty case.+ exp' <- dsBody body where_decs failure+ (pat', xform) <- dsPat pat+ return (DMatch pat' (xform exp') : rest')++-- | Desugar a @Body@+dsBody :: Body -- ^ body to desugar+ -> [Dec] -- ^ "where" declarations+ -> DExp -- ^ what to do if the guards don't match+ -> Q DExp+dsBody (NormalB exp) decs _ =+ maybeDLetE <$> mapM dsLetDec decs <*> dsExp exp+dsBody (GuardedB guarded_exps) decs failure =+ maybeDLetE <$> mapM dsLetDec decs <*> dsGuards guarded_exps failure++-- | If decs is non-empty, delcare them in a let:+maybeDLetE :: [DLetDec] -> DExp -> DExp+maybeDLetE [] exp = exp+maybeDLetE decs exp = DLetE decs exp++-- | If matches is non-empty, make a case statement; otherwise make an error statement+maybeDCaseE :: String -> DExp -> [DMatch] -> DExp+maybeDCaseE err _ [] = DAppE (DVarE 'error) (DLitE (StringL err))+maybeDCaseE _ scrut matches = DCaseE scrut matches++-- | Desugar guarded expressions+dsGuards :: [(Guard, Exp)] -- ^ Guarded expressions+ -> DExp -- ^ What to do if none of the guards match+ -> Q DExp+dsGuards [] thing_inside = return thing_inside+dsGuards ((NormalG guard, exp) : rest) thing_inside =+ dsGuards ((PatG [NoBindS guard], 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+ -> DExp -- ^ What to do if the @Stmt@s yield success+ -> DExp -- ^ What to do if the @Stmt@s yield failure+ -> 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]+dsGuardStmts (LetS decs : rest) success failure = do+ decs' <- mapM dsLetDec decs+ success' <- dsGuardStmts rest success failure+ return $ DLetE decs' success'+dsGuardStmts (NoBindS exp : rest) success failure = do+ exp' <- dsExp exp+ success' <- dsGuardStmts rest success failure+ return $ DCaseE exp' [ DMatch (DConP 'True []) success'+ , DMatch (DConP 'False []) failure ]+dsGuardStmts (ParS _ : _) _ _ = impossible "Parallel comprehension in a pattern guard."++-- | Desugar the @Stmt@s in a @do@ expression+dsDoStmts :: [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+ exp' <- dsExp exp+ rest' <- dsDoStmts rest+ DAppE (DAppE (DVarE '(>>=)) exp') <$> dsLam [pat] rest'+dsDoStmts (LetS decs : rest) = DLetE <$> mapM dsLetDec decs <*> dsDoStmts rest+dsDoStmts (NoBindS exp : rest) = do+ exp' <- dsExp exp+ rest' <- dsDoStmts rest+ return $ DAppE (DAppE (DVarE '(>>)) exp') rest'+dsDoStmts (ParS _ : _) = impossible "Parallel comprehension in a do-statement."++-- | Desugar the @Stmt@s in a list or monad comprehension+dsComp :: [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+ exp' <- dsExp exp+ rest' <- dsComp rest+ DAppE (DAppE (DVarE '(>>=)) exp') <$> dsLam [pat] rest'+dsComp (LetS decs : rest) = DLetE <$> mapM dsLetDec decs <*> dsComp rest+dsComp (NoBindS exp : rest) = do+ exp' <- dsExp exp+ rest' <- dsComp rest+ return $ DAppE (DAppE (DVarE '(>>)) (DAppE (DVarE 'guard) exp')) rest'+dsComp (ParS stmtss : rest) = do+ (pat, exp) <- dsParComp stmtss+ rest' <- dsComp rest+ DAppE (DAppE (DVarE '(>>=)) exp) <$> dsLam [pat] rest'++-- | 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 [] = impossible "Empty list of parallel comprehension statements."+dsParComp [r] = do+ let rv = foldMap extractBoundNamesStmt r+ dsR <- dsComp (r ++ [mk_tuple_stmt rv])+ return (mk_tuple_pat rv, dsR)+dsParComp (q : rest) = do+ let qv = foldMap extractBoundNamesStmt q+ (rest_pat, rest_exp) <- dsParComp rest+ dsQ <- dsComp (q ++ [mk_tuple_stmt qv])+ let zipped = DAppE (DAppE (DVarE 'mzip) dsQ) rest_exp+ return (ConP (tupleDataName 2) [mk_tuple_pat qv, rest_pat], zipped)++-- helper function for dsParComp+mk_tuple_stmt :: S.Set Name -> Stmt+mk_tuple_stmt name_set =+ NoBindS (mkTupleExp (S.foldr ((:) . VarE) [] name_set))++-- helper function for dsParComp+mk_tuple_pat :: S.Set Name -> Pat+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]+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 (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)+dsPat (RecP con_name field_pats) = do+ con <- dataConNameToCon con_name+ (reordered, xform) <- 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)+dsPat (ListP pats) = go pats+ where go [] = return (DConP '[] [], id)+ go (h : t) = do+ (h', xform_h) <- dsPat h+ (t', xform_t) <- go t+ return (DConP '(:) [h', t'], xform_h . xform_t)+dsPat (SigP _ _) =+ 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+dPatToDExp (DVarP name) = DVarE name+dPatToDExp (DConP name pats) = foldl DAppE (DConE name) (map dPatToDExp pats)+dPatToDExp (DTildeP pat) = dPatToDExp pat+dPatToDExp (DBangP pat) = dPatToDExp pat+dPatToDExp DWildP = error "Internal error in th-desugar: wildcard in rhs of as-pattern"++-- | Remove all wildcards from a pattern, replacing any wildcard with a fresh+-- variable+removeWilds :: 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"++-- | Desugar @Dec@s that can appear in a let expression+dsLetDec :: Dec -> Q DLetDec+dsLetDec (FunD name clauses) = DFunD name <$> dsClauses name clauses+dsLetDec (ValD pat body where_decs) = do+ (pat', xform) <- dsPat pat+ DValD pat' <$> (xform <$> dsBody body where_decs error_exp)+ 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 _dec = impossible "Illegal declaration in let expression."++-- | Desugar clauses to a function definition+dsClauses :: Name -- ^ Name of the function+ -> [Clause] -- ^ Clauses to desugar+ -> 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+ (pats', xform) <- dsPats pats+ (:) <$>+ DClause pats' <$> (xform <$> (maybeDLetE <$> mapM dsLetDec where_decs <*> dsExp exp)) <*>+ dsClauses n rest+dsClauses n clauses@(Clause pats _ _ : _) = do+ arg_names <- replicateM (length pats) (newName "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 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)++-- | Desugar a type+dsType :: 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+dsType (VarT name) = return $ DVarT name+dsType (ConT name) = return $ DConT name+ -- the only difference between ConT and PromotedT is the name lookup. Here, we assume+ -- that the TH quote mechanism figured out the right name. Note that lookupDataName name+ -- does not necessarily work, because `name` has its original module attached, which+ -- may not be in scope.+dsType (PromotedT name) = return $ DConT name+dsType (TupleT n) = return $ DConT (tupleTypeName n)+dsType (UnboxedTupleT n) = return $ DConT (unboxedTupleTypeName n)+dsType ArrowT = return DArrowT+dsType ListT = return $ DConT ''[]+dsType (PromotedTupleT n) = return $ DConT (tupleDataName n)+dsType PromotedNilT = return $ DConT '[]+dsType PromotedConsT = return $ DConT '(:)+dsType StarT = impossible "The kind * seen in a type."+dsType ConstraintT = impossible "The kind `Constraint' seen in a type."+dsType (LitT lit) = return $ DLitT lit++-- | Desugar a @TyVarBndr@+dsTvb :: TyVarBndr -> Q DTyVarBndr+dsTvb (PlainTV n) = return $ DPlainTV n+dsTvb (KindedTV n k) = DKindedTV n <$> dsKind k+#if __GLASGOW_HASKELL__ >= 707+dsTvb (RoledTV n r) = return $ DRoledTV n r+dsTvb (KindedRoledTV n k r) = DKindedRoledTV n <$> dsKind k <*> pure r+#endif++-- | Desugar a @Pred@+dsPred :: 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 (ForallT tvbs cxt ki)+ | [] <- cxt+ , Just names <- mapM stripPlainTV_maybe tvbs+ = DForallK names <$> dsKind ki++ | otherwise+ = impossible "Annotations of kind variables or kind constraints."+dsKind (AppT (AppT ArrowT k1) k2) = DArrowK <$> dsKind k1 <*> dsKind k2+dsKind (AppT k1 k2) = do+ k1' <- dsKind k1+ (con_name, args) <- case k1' of+ DConK n as -> return (n, as)+ _ -> impossible "Illegal kind application."+ k2' <- dsKind k2+ return $ DConK con_name (args ++ [k2'])+dsKind k@(SigT _ _) = impossible $ "Super-kind signature in kind " ++ (pprint k)+dsKind (VarT name) = return $ DVarK name+dsKind (ConT name) = return $ DConK name []+dsKind (PromotedT name) = impossible $ "Promoted data constructor " ++ show name ++ " in kind."+dsKind (TupleT n) = return $ DConK (tupleTypeName n) []+dsKind (UnboxedTupleT _) = impossible "Unboxed tuple kind."+dsKind ArrowT = impossible "Unsaturated (->) in kind."+dsKind ListT = return $ DConK ''[] []+dsKind (PromotedTupleT _) = impossible "Promoted tuple used as a kind."+dsKind PromotedNilT = impossible "Promoted [] used as a kind."+dsKind PromotedConsT = impossible "Promoted (:) used as a kind."+dsKind StarT = return DStarK+dsKind ConstraintT = return $ DConK ''Constraint []+dsKind (LitT _) = impossible "Literal used in a kind."+ +-- 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 :: [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."++-- 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)++-- | Make a tuple 'DExp' from a list of 'DExp's. Avoids using a 1-tuple.+mkTupleDExp :: [DExp] -> DExp+mkTupleDExp [exp] = exp+mkTupleDExp exps = foldl DAppE (DConE $ tupleDataName (length exps)) exps++-- | Make a tuple 'Exp' from a list of 'Exp's. Avoids using a 1-tuple.+mkTupleExp :: [Exp] -> Exp+mkTupleExp [exp] = exp+mkTupleExp exps = foldl AppE (ConE $ tupleDataName (length exps)) exps++-- | Make a tuple 'DPat' from a list of 'DPat's. Avoids using a 1-tuple.+mkTupleDPat :: [DPat] -> DPat+mkTupleDPat [pat] = pat+mkTupleDPat pats = DConP (tupleDataName (length pats)) pats++-- | Make a tuple 'Pat' from a list of 'Pat's. Avoids using a 1-tuple.+mkTuplePat :: [Pat] -> Pat+mkTuplePat [pat] = pat+mkTuplePat pats = ConP (tupleDataName (length pats)) pats
+ Language/Haskell/TH/Desugar/Sweeten.hs view
@@ -0,0 +1,76 @@+{- Language/Haskell/TH/Desugar/Sweeten.hs++(c) Richard Eisenberg 2013+eir@cis.upenn.edu++Converts desugared TH back into real TH.+-}++{-# LANGUAGE CPP #-}++{-| The functions in this module convert desugared Template Haskell back into+ proper Template Haskell. -}++module Language.Haskell.TH.Desugar.Sweeten where++import Language.Haskell.TH++import Language.Haskell.TH.Desugar.Core++expToTH :: DExp -> Exp+expToTH (DVarE n) = VarE n+expToTH (DConE n) = ConE n+expToTH (DLitE l) = LitE l+expToTH (DAppE e1 e2) = AppE (expToTH e1) (expToTH e2)+expToTH (DLamE names exp) = LamE (map VarP names) (expToTH exp)+expToTH (DCaseE exp matches) = CaseE (expToTH exp) (map matchToTH matches)+expToTH (DLetE decs exp) = LetE (map letDecToTH decs) (expToTH exp)+expToTH (DSigE exp ty) = SigE (expToTH exp) (typeToTH ty)++matchToTH :: DMatch -> Match+matchToTH (DMatch pat exp) = Match (patToTH pat) (NormalB (expToTH exp)) []++patToTH :: DPat -> Pat+patToTH (DLitP lit) = LitP lit+patToTH (DVarP n) = VarP n+patToTH (DConP n pats) = ConP n (map patToTH pats)+patToTH (DTildeP pat) = TildeP (patToTH pat)+patToTH (DBangP pat) = BangP (patToTH pat)+patToTH DWildP = WildP++letDecToTH :: DLetDec -> Dec+letDecToTH (DFunD name clauses) = FunD name (map clauseToTH clauses)+letDecToTH (DValD pat exp) = ValD (patToTH pat) (NormalB (expToTH exp)) []+letDecToTH (DSigD name ty) = SigD name (typeToTH ty)+letDecToTH (DInfixD f name) = InfixD f name++clauseToTH :: DClause -> Clause+clauseToTH (DClause pats exp) = Clause (map patToTH pats) (NormalB (expToTH exp)) []++typeToTH :: DType -> Type+typeToTH (DForallT tvbs cxt ty) = ForallT (map tvbToTH tvbs) (map predToTH cxt) (typeToTH ty)+typeToTH (DAppT t1 t2) = AppT (typeToTH t1) (typeToTH t2)+typeToTH (DSigT ty ki) = SigT (typeToTH ty) (kindToTH ki)+typeToTH (DVarT n) = VarT n+typeToTH (DConT n) = ConT n+typeToTH DArrowT = ArrowT+typeToTH (DLitT lit) = LitT lit++tvbToTH :: DTyVarBndr -> TyVarBndr+tvbToTH (DPlainTV n) = PlainTV n+tvbToTH (DKindedTV n k) = KindedTV n (kindToTH k)+#if __GLASGOW_HASKELL__ >= 707+tvbToTH (DRoledTV n r) = RoledTV n r+tvbToTH (DKindedRoledTV n k r) = KindedRoledTV n (kindToTH k) r+#endif++predToTH :: DPred -> Pred+predToTH (DClassP n tys) = ClassP n (map typeToTH tys)+predToTH (DEqualP t1 t2) = EqualP (typeToTH t1) (typeToTH t2)++kindToTH :: DKind -> Kind+kindToTH (DForallK names ki) = ForallT (map PlainTV names) [] (kindToTH ki)+kindToTH (DVarK n) = VarT n+kindToTH (DConK n kis) = foldl AppT (ConT n) (map kindToTH kis)+kindToTH (DArrowK k1 k2) = AppT (AppT ArrowT (kindToTH k1)) (kindToTH k2)+kindToTH DStarK = StarT
+ Language/Haskell/TH/Desugar/Util.hs view
@@ -0,0 +1,113 @@+{- Language/Haskell/TH/Desugar/Util.hs++(c) Richard Eisenberg 2013+eir@cis.upenn.edu++Utility functions for th-desugar package.+-}++module Language.Haskell.TH.Desugar.Util where++import Language.Haskell.TH++import qualified Data.Set as S+import Data.Foldable++-- | 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+ (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)++-- | Report that a certain TH construct is impossible+impossible :: 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+ -> Name -- ^ Name of the datatype (@data@ or @newtype@) of interest+ -> Q ([TyVarBndr], [Con])+getDataD error 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. " ++ error++-- | From the name of a data constructor, retrieve its definition as a @Con@+dataConNameToCon :: 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+ info <- reifyWithWarning con_name+ type_name <- case info of+ DataConI _name _type parent_name _fixity -> return parent_name+ _ -> impossible "Non-data-con used to construct a record."+ (_, 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++-- | Extracts the name out of a variable pattern, or returns @Nothing@+stripVarP_maybe :: Pat -> Maybe Name+stripVarP_maybe (VarP name) = Just name+stripVarP_maybe _ = Nothing++-- | Extracts the name out of a @PlainTV@, or returns @Nothing@+stripPlainTV_maybe :: TyVarBndr -> Maybe Name+stripPlainTV_maybe (PlainTV n) = Just n+stripPlainTV_maybe _ = Nothing++-- | Extract the names bound in a @Stmt@+extractBoundNamesStmt :: Stmt -> S.Set Name+extractBoundNamesStmt (BindS pat _) = extractBoundNamesPat pat+extractBoundNamesStmt (LetS decs) = foldMap extractBoundNamesDec decs+extractBoundNamesStmt (NoBindS _) = S.empty+extractBoundNamesStmt (ParS stmtss) = foldMap (foldMap extractBoundNamesStmt) stmtss++-- | Extract the names bound in a @Dec@ that could appear in a @let@ expression.+extractBoundNamesDec :: Dec -> S.Set Name+extractBoundNamesDec (FunD name _) = S.singleton name+extractBoundNamesDec (ValD pat _ _) = extractBoundNamesPat pat+extractBoundNamesDec _ = S.empty++-- | Extract the names bound in a @Pat@+extractBoundNamesPat :: Pat -> S.Set Name+extractBoundNamesPat (LitP _) = S.empty+extractBoundNamesPat (VarP name) = S.singleton name+extractBoundNamesPat (TupP pats) = foldMap extractBoundNamesPat pats+extractBoundNamesPat (UnboxedTupP pats) = foldMap extractBoundNamesPat pats+extractBoundNamesPat (ConP _ pats) = foldMap extractBoundNamesPat pats+extractBoundNamesPat (InfixP p1 _ p2) = extractBoundNamesPat p1 `S.union`+ extractBoundNamesPat p2+extractBoundNamesPat (UInfixP p1 _ p2) = extractBoundNamesPat p1 `S.union`+ extractBoundNamesPat p2+extractBoundNamesPat (ParensP pat) = extractBoundNamesPat pat+extractBoundNamesPat (TildeP pat) = extractBoundNamesPat pat+extractBoundNamesPat (BangP pat) = extractBoundNamesPat pat+extractBoundNamesPat (AsP name pat) = S.singleton name `S.union` extractBoundNamesPat pat+extractBoundNamesPat WildP = S.empty+extractBoundNamesPat (RecP _ field_pats) = let (_, pats) = unzip field_pats in+ foldMap extractBoundNamesPat pats+extractBoundNamesPat (ListP pats) = foldMap extractBoundNamesPat pats+extractBoundNamesPat (SigP pat _) = extractBoundNamesPat pat+extractBoundNamesPat (ViewP _ pat) = extractBoundNamesPat pat
+ README.md view
@@ -0,0 +1,18 @@+`th-desugar` Package+====================++This package provides the `Language.Haskell.TH.Desugar` module, which desugars+Template Haskell's rich encoding of Haskell syntax into a simpler encoding.+This desugaring discards surface syntax information (such as the use of infix+operators) but retains the original meaning of the TH code. The intended use+of this package is as a preprocessor for more advanced code manipulation+tools. Note that the input to any of the `ds...` functions should be produced+from a TH quote, using the syntax `[| ... |]`. If the input to these functions+is a hand-coded TH syntax tree, the results may be unpredictable. In+particular, it is likely that promoted datatypes will not work as expected.++The package was designed for use with the `singletons` package, so some design+decisions are based on that use case, when more than one design choice was+possible.++I will try to keep this package up-to-date with respect to changes in GHC.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ th-desugar.cabal view
@@ -0,0 +1,40 @@+name: th-desugar+version: 1.0.0+cabal-version: >= 1.10+synopsis: Functions to desugar Template Haskell+homepage: http://www.cis.upenn.edu/~eir/packages/th-desugar+category: Template Haskell+author: Richard Eisenberg <eir@cis.upenn.edu>+maintainer: Richard Eisenberg <eir@cis.upenn.edu>+bug-reports: https://github.com/goldfirere/th-desugar/issues+stability: experimental+extra-source-files: README.md, CHANGES.md+license: BSD3+license-file: LICENSE+build-type: Simple+description:+ This package provides the Language.Haskell.TH.Desugar module, which desugars+ Template Haskell's rich encoding of Haskell syntax into a simpler encoding.+ This desugaring discards surface syntax information (such as the use of infix+ operators) but retains the original meaning of the TH code. The intended use+ of this package is as a preprocessor for more advanced code manipulation+ tools. Note that the input to any of the ds... functions should be produced+ from a TH quote, using the syntax [| ... |]. If the input to these functions+ is a hand-coded TH syntax tree, the results may be unpredictable. In+ particular, it is likely that promoted datatypes will not work as expected.++source-repository this+ type: git+ location: https://github.com/goldfirere/th-desugar.git+ tag: v1.0.0++library+ build-depends: + base >= 4 && < 5,+ template-haskell,+ containers >= 0.5+ exposed-modules: Language.Haskell.TH.Desugar, Language.Haskell.TH.Desugar.Sweeten+ other-modules: Language.Haskell.TH.Desugar.Core, Language.Haskell.TH.Desugar.Util+ default-language: Haskell2010+ +