th-desugar 1.2.1 → 1.3.0
raw patch · 8 files changed
+319/−92 lines, 8 filesdep +HUnitdep +hspecdep ~mtldep ~template-haskell
Dependencies added: HUnit, hspec
Dependency ranges changed: mtl, template-haskell
Files
- CHANGES.md +5/−0
- Language/Haskell/TH/Desugar/Core.hs +98/−50
- Language/Haskell/TH/Desugar/Expand.hs +55/−17
- Language/Haskell/TH/Desugar/Sweeten.hs +25/−8
- Language/Haskell/TH/Desugar/Util.hs +29/−1
- README.md +2/−0
- Test/Run.hs +89/−0
- th-desugar.cabal +16/−16
CHANGES.md view
@@ -1,3 +1,8 @@+Version 1.3.0+-------------+* Update to work with `type Pred = Type` in GHC 7.9. This changed the+`DPred` type for all GHC versions, though.+ Version 1.2.0 ------------- * Generalized interface to allow any member of the `Qausi` class, instead of
Language/Haskell/TH/Desugar/Core.hs view
@@ -48,12 +48,12 @@ deriving (Show, Typeable, Data) -- | Corresponds to TH's @Pat@ type.-data DPat = DLitP Lit- | DVarP Name- | DConP Name [DPat]- | DTildeP DPat- | DBangP DPat- | DWildP+data DPat = DLitPa Lit+ | DVarPa Name+ | DConPa Name [DPat]+ | DTildePa DPat+ | DBangPa DPat+ | DWildPa deriving (Show, Typeable, Data) -- | Corresponds to TH's @Type@ type.@@ -79,8 +79,10 @@ type DCxt = [DPred] -- | Corresponds to TH's @Pred@-data DPred = DClassP Name [DType]- | DEqualP DType DType+data DPred = DAppPr DPred DType+ | DSigPr DPred DKind+ | DVarPr Name+ | DConPr Name deriving (Show, Typeable, Data) -- | Corresponds to TH's @TyVarBndr@. Note that @PlainTV x@ and @KindedTV x StarT@ are@@ -129,7 +131,7 @@ e1' <- dsExp e1 e2' <- dsExp e2 e3' <- dsExp e3- return $ DCaseE e1' [DMatch (DConP 'True []) e2', DMatch (DConP 'False []) e3']+ return $ DCaseE e1' [DMatch (DConPa 'True []) e2', DMatch (DConPa '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@@ -138,7 +140,7 @@ scrutinee <- qNewName "scrutinee" exp' <- dsExp exp matches' <- dsMatches scrutinee matches- return $ DLetE [DValD (DVarP scrutinee) exp'] $+ return $ DLetE [DValD (DVarPa scrutinee) exp'] $ DCaseE (DVarE scrutinee) matches' dsExp (DoE stmts) = dsDoStmts stmts dsExp (CompE stmts) = dsComp stmts@@ -200,12 +202,12 @@ con_to_dmatch (RecC con_name args) = do let con_field_names = map fst_of_3 args field_var_names <- mapM (qNewName . nameBase) con_field_names- DMatch (DConP con_name (map DVarP field_var_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 _ = impossible "Internal error within th-desugar." - error_match = DMatch DWildP (DAppE (DVarE 'error)+ error_match = DMatch DWildPa (DAppE (DVarE 'error) (DLitE (StringL "Non-exhaustive patterns in record update"))) fst_of_3 (x, _, _) = x@@ -283,7 +285,7 @@ success' <- dsGuardStmts rest success failure (pat', success'') <- dsPatOverExp pat success' exp' <- dsExp exp- return $ DCaseE exp' [DMatch pat' success'', DMatch DWildP failure]+ return $ DCaseE exp' [DMatch pat' success'', DMatch DWildPa failure] dsGuardStmts (LetS decs : rest) success failure = do decs' <- dsLetDecs decs success' <- dsGuardStmts rest success failure@@ -291,8 +293,8 @@ 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 ]+ return $ DCaseE exp' [ DMatch (DConPa 'True []) success'+ , DMatch (DConPa 'False []) failure ] dsGuardStmts (ParS _ : _) _ _ = impossible "Parallel comprehension in a pattern guard." -- | Desugar the @Stmt@s in a @do@ expression@@ -359,14 +361,14 @@ 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+ 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 pats exp = do (pats', vars) <- runWriterT $ mapM dsPat pats- let name_decs = uncurry (zipWith (DValD . DVarP)) $ unzip vars+ let name_decs = uncurry (zipWith (DValD . DVarPa)) $ unzip vars return (pats', maybeDLetE name_decs exp) -- | Desugar a pattern, returning a list of (Name, DExp) pairs of extra@@ -381,37 +383,37 @@ -- | Desugar a pattern. 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-dsPat (UnboxedTupP pats) = DConP (unboxedTupleDataName (length pats)) <$>+dsPat (LitP lit) = return $ DLitPa lit+dsPat (VarP n) = return $ DVarPa n+dsPat (TupP pats) = DConPa (tupleDataName (length pats)) <$> mapM dsPat pats+dsPat (UnboxedTupP pats) = DConPa (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 (ConP name pats) = DConPa name <$> mapM dsPat pats+dsPat (InfixP p1 name p2) = DConPa name <$> mapM dsPat [p1, p2] dsPat (UInfixP _ _ _) = fail "Cannot desugar unresolved infix operators." dsPat (ParensP pat) = dsPat pat-dsPat (TildeP pat) = DTildeP <$> dsPat pat-dsPat (BangP pat) = DBangP <$> dsPat pat+dsPat (TildeP pat) = DTildePa <$> dsPat pat+dsPat (BangP pat) = DBangPa <$> dsPat pat dsPat (AsP name pat) = do pat' <- dsPat pat pat'' <- lift $ removeWilds pat' tell [(name, dPatToDExp pat'')] return pat''-dsPat WildP = return DWildP+dsPat WildP = return DWildPa dsPat (RecP con_name field_pats) = do con <- lift $ dataConNameToCon con_name reordered <- case con of RecC _name fields -> reorderFieldsPat fields field_pats _ -> lift $ impossible $ "Record syntax used with non-record constructor " ++ (show con_name) ++ "."- return $ DConP con_name reordered+ return $ DConPa con_name reordered dsPat (ListP pats) = go pats- where go [] = return $ DConP '[] []+ where go [] = return $ DConPa '[] [] go (h : t) = do h' <- dsPat h t' <- go t- return $ DConP '(:) [h', t']+ return $ DConPa '(:) [h', t'] dsPat (SigP _ _) = lift $ impossible ("At last check (Aug 2013), type patterns in signatures are not\n" ++@@ -421,22 +423,22 @@ -- | 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"+dPatToDExp (DLitPa lit) = DLitE lit+dPatToDExp (DVarPa name) = DVarE name+dPatToDExp (DConPa name pats) = foldl DAppE (DConE name) (map dPatToDExp pats)+dPatToDExp (DTildePa pat) = dPatToDExp pat+dPatToDExp (DBangPa pat) = dPatToDExp pat+dPatToDExp DWildPa = error "Internal error in th-desugar: wildcard in rhs of as-pattern" -- | Remove all wildcards from a pattern, replacing any wildcard with a fresh -- variable 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 <$> qNewName "wild"+removeWilds p@(DLitPa _) = return p+removeWilds p@(DVarPa _) = return p+removeWilds (DConPa con_name pats) = DConPa con_name <$> mapM removeWilds pats+removeWilds (DTildePa pat) = DTildePa <$> removeWilds pat+removeWilds (DBangPa pat) = DBangPa <$> removeWilds pat+removeWilds DWildPa = DVarPa <$> qNewName "wild" -- | Desugar @Dec@s that can appear in a let expression dsLetDecs :: Quasi q => [Dec] -> q [DLetDec]@@ -450,7 +452,7 @@ dsLetDec (ValD pat body where_decs) = do (pat', vars) <- dsPatX pat body' <- dsBody body where_decs error_exp- let extras = uncurry (zipWith (DValD . DVarP)) $ unzip vars+ let extras = uncurry (zipWith (DValD . DVarPa)) $ unzip vars return $ DValD pat' body' : extras where error_exp = DAppE (DVarE 'error) (DLitE@@ -478,7 +480,7 @@ 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) <$>+ clause <- DClause (map DVarPa arg_names) <$> (DCaseE scrutinee <$> foldrM (clause_to_dmatch scrutinee) [] clauses) return [clause] where@@ -492,7 +494,7 @@ scrutinee failure_matches -- | Desugar a type dsType :: Quasi q => Type -> q DType-dsType (ForallT tvbs preds ty) = DForallT <$> mapM dsTvb tvbs <*> mapM dsPred preds <*> dsType ty+dsType (ForallT tvbs preds ty) = DForallT <$> mapM dsTvb tvbs <*> concatMapM 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@@ -512,16 +514,59 @@ 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+#if __GLASGOW_HASKELL__ >= 709+dsType EqualityT = return $ DConT ''(~)+#endif -- | Desugar a @TyVarBndr@ dsTvb :: Quasi q => TyVarBndr -> q DTyVarBndr dsTvb (PlainTV n) = return $ DPlainTV n dsTvb (KindedTV n k) = DKindedTV n <$> dsKind k --- | Desugar a @Pred@-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 @Pred@, flattening any internal tuples+dsPred :: Quasi q => Pred -> q DCxt+#if __GLASGOW_HASKELL__ < 709+dsPred (ClassP n tys) = do+ ts' <- mapM dsType tys+ return [foldl DAppPr (DConPr n) ts']+dsPred (EqualP t1 t2) = do+ ts' <- mapM dsType [t1, t2]+ return [foldl DAppPr (DConPr ''(~)) ts']+#else+dsPred t+ | Just ts <- splitTuple_maybe t+ = concatMapM dsPred ts+dsPred t@(ForallT _ _ _) = impossible $ "Forall seen in constraint: " ++ show t+dsPred (AppT t1 t2) = do+ [p1] <- dsPred t1 -- tuples can't be applied!+ (:[]) <$> DAppPr p1 <$> dsType t2+dsPred (SigT ty ki) = do+ preds <- dsPred ty+ case preds of+ [p] -> (:[]) <$> DSigPr p <$> dsKind ki+ other -> return other -- just drop the kind signature on a tuple.+dsPred (VarT n) = return [DVarPr n]+dsPred (ConT n) = return [DConPr n]+dsPred t@(PromotedT _) =+ impossible $ "Promoted type seen as head of constraint: " ++ show t+dsPred (TupleT 0) = return [DConPr (tupleTypeName 0)]+dsPred (TupleT _) =+ impossible "Internal error in th-desugar in detecting tuple constraints."+dsPred t@(UnboxedTupleT _) =+ impossible $ "Unboxed tuple seen as head of constraint: " ++ show t+dsPred ArrowT = impossible "Arrow seen as head of constraint."+dsPred ListT = impossible "List seen as head of constraint."+dsPred (PromotedTupleT _) =+ impossible "Promoted tuple seen as head of constraint."+dsPred PromotedNilT = impossible "Promoted nil seen as head of constraint."+dsPred PromotedConsT = impossible "Promoted cons seen as head of constraint."+dsPred StarT = impossible "* seen as head of constraint."+dsPred ConstraintT =+ impossible "The kind `Constraint' seen as head of constraint."+dsPred t@(LitT _) =+ impossible $ "Type literal seen as head of constraint: " ++ show t+dsPred EqualityT = return [DConPr ''(~)]+#endif -- | Desugar a kind dsKind :: Quasi q => Kind -> q DKind@@ -554,6 +599,9 @@ dsKind StarT = return DStarK dsKind ConstraintT = return $ DConK ''Constraint [] dsKind (LitT _) = impossible "Literal used in a kind."+#if __GLASGOW_HASKELL__ >= 709+dsKind EqualityT = impossible "(~) used in a kind."+#endif -- 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@@ -564,7 +612,7 @@ reorderFieldsPat :: Quasi q => [VarStrictType] -> [FieldPat] -> PatM q [DPat] reorderFieldsPat field_decs field_pats =- reorderFields' dsPat field_decs field_pats (repeat DWildP)+ reorderFields' dsPat field_decs field_pats (repeat DWildPa) reorderFields' :: (Applicative m, Monad m) => (a -> m da)@@ -592,7 +640,7 @@ -- | 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+mkTupleDPat pats = DConPa (tupleDataName (length pats)) pats -- | Make a tuple 'Pat' from a list of 'Pat's. Avoids using a 1-tuple. mkTuplePat :: [Pat] -> Pat
Language/Haskell/TH/Desugar/Expand.hs view
@@ -15,6 +15,7 @@ ) where import qualified Data.Map as M+import Control.Monad import Control.Applicative import Language.Haskell.TH hiding (cxt) import Language.Haskell.TH.Syntax ( Quasi(..) )@@ -38,20 +39,42 @@ 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 (DConT n) = expandCon n args go args ty = return $ foldl DAppT ty args +-- | Expands all type synonyms in a desugared predicate.+expandPred :: Quasi q => DPred -> q DPred+expandPred = go []+ where+ go args (DAppPr p t) = do+ t' <- expandType t+ go (t' : args) p+ go args (DSigPr p k) = do+ p' <- go [] p+ return $ foldl DAppPr (DSigPr p' k) args+ go args (DConPr n) = do+ ty <- expandCon n args+ dTypeToDPred ty+ go args p = return $ foldl DAppPr p args++-- | Expand a constructor with given arguments+expandCon :: Quasi q+ => Name -- ^ Tycon name+ -> [DType] -- ^ Arguments+ -> q DType -- ^ Expanded type+expandCon n args = 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+ -- | Capture-avoiding substitution on types substTy :: Quasi q => M.Map Name DType -> DType -> q DType substTy vars (DForallT tvbs cxt ty) =@@ -89,12 +112,27 @@ extractDTvbName (DKindedTV n _) = n 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) =- DEqualP <$> substTy vars t1 <*> substTy vars t2+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)+ | Just ty <- M.lookup n vars+ = dTypeToDPred ty+ | otherwise+ = return $ DVarPr n+substPred _ p = return p +-- | Convert a 'DType' to a 'DPred'+dTypeToDPred :: Quasi 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+dTypeToDPred (DVarT n) = return $ DVarPr n+dTypeToDPred (DConT n) = return $ DConPr n+dTypeToDPred DArrowT = impossible "Arrow used as head of constraint"+dTypeToDPred (DLitT _) = impossible "Type literal used as head of constraint"++ -- | Expand all type synonyms 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 = everywhereM (mkM expandType)+expand = everywhereM (mkM expandType >=> mkM expandPred)
Language/Haskell/TH/Desugar/Sweeten.hs view
@@ -32,12 +32,12 @@ 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+patToTH (DLitPa lit) = LitP lit+patToTH (DVarPa n) = VarP n+patToTH (DConPa n pats) = ConP n (map patToTH pats)+patToTH (DTildePa pat) = TildeP (patToTH pat)+patToTH (DBangPa pat) = BangP (patToTH pat)+patToTH DWildPa = WildP letDecToTH :: DLetDec -> Dec letDecToTH (DFunD name clauses) = FunD name (map clauseToTH clauses)@@ -62,8 +62,25 @@ tvbToTH (DKindedTV n k) = KindedTV n (kindToTH k) predToTH :: DPred -> Pred-predToTH (DClassP n tys) = ClassP n (map typeToTH tys)-predToTH (DEqualP t1 t2) = EqualP (typeToTH t1) (typeToTH t2)+#if __GLASGOW_HASKELL__ < 709+predToTH = go []+ where+ go acc (DAppPr p t) = go (typeToTH t : acc) p+ go acc (DSigPr p _) = go acc p -- this shouldn't happen.+ go _ (DVarPr _)+ = error "Template Haskell in GHC <= 7.8 does not support variable constraints."+ go acc (DConPr n) + | nameBase n == "(~)"+ , [t1, t2] <- acc+ = EqualP t1 t2+ | otherwise+ = ClassP n acc+#else+predToTH (DAppPr p t) = AppT (predToTH p) (typeToTH t)+predToTH (DSigPr p k) = SigT (predToTH p) (kindToTH k)+predToTH (DVarPr n) = VarT n+predToTH (DConPr n) = ConT n+#endif kindToTH :: DKind -> Kind kindToTH (DForallK names ki) = ForallT (map PlainTV names) [] (kindToTH ki)
Language/Haskell/TH/Desugar/Util.hs view
@@ -128,4 +128,32 @@ splitAtList (_ : t) (x : xs) = let (as, bs) = splitAtList t xs in (x : as, bs)-splitAtList (_ : _) [] = ([], []) +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
README.md view
@@ -1,6 +1,8 @@ `th-desugar` Package ==================== +[](https://travis-ci.org/goldfirere/th-desugar)+ 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
+ Test/Run.hs view
@@ -0,0 +1,89 @@+{- Tests for the th-desugar package++(c) Richard Eisenberg 2013+eir@cis.upenn.edu+-}++{-# LANGUAGE TemplateHaskell, UnboxedTuples, ParallelListComp, CPP,+ RankNTypes, ImpredicativeTypes, TypeFamilies,+ DataKinds, ConstraintKinds #-}+{-# 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 #-}++module Test.Run where++import Test.HUnit+import Test.Hspec+import Test.Hspec.HUnit++import Test.Splices+import Language.Haskell.TH.Desugar+import Language.Haskell.TH.Desugar.Expand+import Language.Haskell.TH.Desugar.Sweeten++tests :: Test+tests = test [ "sections" ~: $test1_sections @=? $(dsSplice test1_sections)+ , "lampats" ~: $test2_lampats @=? $(dsSplice test2_lampats)+ , "lamcase" ~: $test3_lamcase @=? $(dsSplice test3_lamcase)+-- Must fix nested pattern-matching for this to work. Argh.+-- , "tuples" ~: $test4_tuples @=? $(dsSplice test4_tuples)+ , "ifs" ~: $test5_ifs @=? $(dsSplice test5_ifs)+ , "ifs2" ~: $test6_ifs2 @=? $(dsSplice test6_ifs2)+ , "let" ~: $test7_let @=? $(dsSplice test7_let)+ , "case" ~: $test8_case @=? $(dsSplice test8_case)+ , "do" ~: $test9_do @=? $(dsSplice test9_do)+ , "comp" ~: $test10_comp @=? $(dsSplice test10_comp)+#if __GLASGOW_HASKELL__ >= 707+ , "parcomp" ~: $test11_parcomp @=? $(dsSplice test11_parcomp)+ , "parcomp2" ~: $test12_parcomp2 @=? $(dsSplice test12_parcomp2)+#endif+ , "sig" ~: $test13_sig @=? $(dsSplice test13_sig)+ , "record" ~: $test14_record @=? $(dsSplice test14_record)+ , "litp" ~: $test15_litp @=? $(dsSplice test15_litp)+ , "tupp" ~: $test16_tupp @=? $(dsSplice test16_tupp)+ , "infixp" ~: $test17_infixp @=? $(dsSplice test17_infixp)+ , "tildep" ~: $test18_tildep @=? $(dsSplice test18_tildep)+ , "bangp" ~: $test19_bangp @=? $(dsSplice test19_bangp)+ , "asp" ~: $test20_asp @=? $(dsSplice test20_asp)+ , "wildp" ~: $test21_wildp @=? $(dsSplice test21_wildp)+ , "listp" ~: $test22_listp @=? $(dsSplice test22_listp)+-- type signatures in patterns not yet handled by Template Haskell+-- , "sigp" ~: $test23_sigp @=? $(dsSplice test23_sigp)+ , "fun" ~: $test24_fun @=? $(dsSplice test24_fun)+ , "fun2" ~: $test25_fun2 @=? $(dsSplice test25_fun2)+ , "forall" ~: $test26_forall @=? $(dsSplice test26_forall)+ , "kisig" ~: $test27_kisig @=? $(dsSplice test27_kisig)+ , "tupt" ~: $test28_tupt @=? $(dsSplice test28_tupt)+ , "listt" ~: $test29_listt @=? $(dsSplice test29_listt)+ , "promoted" ~: $test30_promoted @=? $(dsSplice test30_promoted)+ , "constraint" ~: $test31_constraint @=? $(dsSplice test31_constraint)+ , "tylit" ~: $test32_tylit @=? $(dsSplice test32_tylit)+ , "tvbs" ~: $test33_tvbs @=? $(dsSplice test33_tvbs)+ , "let_as" ~: $test34_let_as @=? $(dsSplice test34_let_as)+#if __GLASGOW_HASKELL__ >= 709+ , "pred" ~: $test37_pred @=? $(dsSplice test37_pred)+ , "pred2" ~: $test38_pred2 @=? $(dsSplice test38_pred2)+ , "eq" ~: $test39_eq @=? $(dsSplice test39_eq)+#endif+ ]++test35a = $test35_expand+test35b = $(test35_expand >>= dsExp >>= expand >>= return . expToTH)+test36a = $test36_expand+test36b = $(test36_expand >>= dsExp >>= expand >>= return . expToTH)++hasSameType :: a -> a -> Bool+hasSameType _ _ = True++test_expand :: Bool+test_expand = and [ hasSameType test35a test35b+ , hasSameType test36a test36b]++main :: IO ()+main = hspec $ do+ describe "th-desugar library" $ do+ it "compiles" $ True+ it "expands" $ test_expand++ fromHUnitTest tests
th-desugar.cabal view
@@ -1,5 +1,5 @@ name: th-desugar-version: 1.2.1+version: 1.3.0 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.2.1+ tag: v1.3.0 library build-depends: @@ -41,18 +41,18 @@ 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+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