{-# LANGUAGE LambdaCase , ViewPatterns , TypeFamilies #-} module Main where import GHC hiding (loadModule, ParsedModule) import DynFlags import GHC.Paths ( libdir ) import Module as GHC import Control.Monad.IO.Class import Control.Monad import Data.Maybe import Data.List import Data.Either.Combinators import Test.HUnit hiding (test) import System.IO import System.Exit import System.FilePath import Language.Haskell.Tools.AST as AST import Language.Haskell.Tools.AST.Rewrite as G import Language.Haskell.Tools.AST.FromGHC import Language.Haskell.Tools.Transform import Language.Haskell.Tools.PrettyPrint import Language.Haskell.Tools.Refactor.Perform import Language.Haskell.Tools.Refactor.Prepare import Language.Haskell.Tools.Refactor.GetModules import Language.Haskell.Tools.Refactor.Predefined.OrganizeImports import Language.Haskell.Tools.Refactor.Predefined.GenerateTypeSignature import Language.Haskell.Tools.Refactor.Predefined.GenerateExports import Language.Haskell.Tools.Refactor.Predefined.RenameDefinition import Language.Haskell.Tools.Refactor.Predefined.ExtractBinding import Language.Haskell.Tools.Refactor.RefactorBase import Language.Haskell.Tools.Refactor.Predefined.DataToNewtype import Language.Haskell.Tools.Refactor.Predefined.IfToGuards import Language.Haskell.Tools.Refactor.Predefined.DollarApp main :: IO () main = run nightlyTests run :: [Test] -> IO () run tests = do results <- runTestTT $ TestList tests if errors results + failures results > 0 then exitFailure else exitSuccess nightlyTests :: [Test] nightlyTests = unitTests ++ map makeCpphsTest cppHsTests ++ map makeInstanceControlTest instanceControlTests unitTests :: [Test] unitTests = genTests ++ functionalTests functionalTests :: [Test] functionalTests = map makeReprintTest checkTestCases ++ map makeOrganizeImportsTest organizeImportTests ++ map makeGenerateSignatureTest generateSignatureTests ++ map makeGenerateExportsTest generateExportsTests ++ map makeRenameDefinitionTest renameDefinitionTests ++ map makeWrongRenameDefinitionTest wrongRenameDefinitionTests ++ map makeExtractBindingTest extractBindingTests ++ map makeWrongExtractBindingTest wrongExtractBindingTests ++ map makeMultiModuleTest multiModuleTests ++ map makeMiscRefactorTest miscRefactorTests where checkTestCases = languageTests ++ organizeImportTests ++ map fst generateSignatureTests ++ generateExportsTests ++ map (\(mod,_,_) -> mod) renameDefinitionTests ++ map (\(mod,_,_) -> mod) wrongRenameDefinitionTests ++ map (\(mod,_,_) -> mod) extractBindingTests ++ map (\(mod,_,_) -> mod) wrongExtractBindingTests rootDir = ".." ".." "examples" languageTests = [ "Decl.AmbiguousFields" , "Decl.AnnPragma" , "Decl.ClosedTypeFamily" , "Decl.CtorOp" , "Decl.DataFamily" , "Decl.DataType" , "Decl.DataTypeDerivings" , "Decl.FunBind" , "Decl.FunctionalDeps" , "Decl.FunGuards" , "Decl.GADT" , "Decl.InjectiveTypeFamily" , "Decl.InlinePragma" , "Decl.InstanceOverlaps" , "Decl.InstanceSpec" , "Decl.LocalBindings" , "Decl.LocalFixity" , "Decl.MultipleFixity" , "Decl.MultipleSigs" , "Decl.OperatorBind" , "Decl.OperatorDecl" , "Decl.ParamDataType" , "Decl.PatternBind" , "Decl.PatternSynonym" , "Decl.RecordPatternSynonyms" , "Decl.RecordType" , "Decl.RewriteRule" , "Decl.SpecializePragma" , "Decl.StandaloneDeriving" , "Decl.TypeClass" , "Decl.TypeClassMinimal" , "Decl.TypeFamily" , "Decl.TypeFamilyKindSig" , "Decl.TypeInstance" , "Decl.TypeRole" , "Decl.TypeSynonym" , "Decl.ValBind" , "Expr.ArrowNotation" , "Expr.Case" , "Expr.DoNotation" , "Expr.GeneralizedListComp" , "Expr.EmptyCase" , "Expr.If" , "Expr.ImplicitParams" , "Expr.LambdaCase" , "Expr.ListComp" , "Expr.MultiwayIf" , "Expr.Negate" , "Expr.Operator" , "Expr.ParenName" , "Expr.ParListComp" , "Expr.RecordPuns" , "Expr.RecordWildcards" , "Expr.RecursiveDo" , "Expr.Sections" , "Expr.StaticPtr" , "Expr.TupleSections" , "Module.Simple" , "Module.GhcOptionsPragma" , "Module.Export" , "Module.NamespaceExport" , "Module.Import" , "Pattern.Backtick" , "Pattern.Constructor" , "Pattern.ImplicitParams" , "Pattern.Infix" , "Pattern.NPlusK" , "Pattern.Record" , "Type.Bang" , "Type.Builtin" , "Type.Ctx" , "Type.ExplicitTypeApplication" , "Type.Forall" , "Type.Primitives" , "Type.TypeOperators" , "Type.Unpack" , "Type.Wildcard" , "TH.Brackets" , "TH.QuasiQuote.Define" , "TH.QuasiQuote.Use" , "TH.Splice.Define" , "TH.Splice.Use" , "Refactor.CommentHandling.CommentTypes" , "Refactor.CommentHandling.BlockComments" , "Refactor.CommentHandling.Crosslinking" , "Refactor.CommentHandling.FunctionArgs" ] cppHsTests = [ "Language.Preprocessor.Cpphs" , "Language.Preprocessor.Unlit" , "Language.Preprocessor.Cpphs.CppIfdef" , "Language.Preprocessor.Cpphs.HashDefine" , "Language.Preprocessor.Cpphs.MacroPass" , "Language.Preprocessor.Cpphs.Options" , "Language.Preprocessor.Cpphs.Position" , "Language.Preprocessor.Cpphs.ReadFirst" , "Language.Preprocessor.Cpphs.RunCpphs" , "Language.Preprocessor.Cpphs.SymTab" , "Language.Preprocessor.Cpphs.Tokenise" ] instanceControlTests = [ "Control.Instances.Test" , "Control.Instances.Morph" , "Control.Instances.ShortestPath" , "Control.Instances.TypeLevelPrelude" ] organizeImportTests = [ "Refactor.OrganizeImports.Narrow" , "Refactor.OrganizeImports.Reorder" , "Refactor.OrganizeImports.Unused" , "Refactor.OrganizeImports.Ctor" , "Refactor.OrganizeImports.Class" , "Refactor.OrganizeImports.Operator" , "Refactor.OrganizeImports.SameName" , "Refactor.OrganizeImports.Removed" ] generateSignatureTests = [ ("Refactor.GenerateTypeSignature.Simple", "3:1-3:10") , ("Refactor.GenerateTypeSignature.Function", "3:1-3:15") , ("Refactor.GenerateTypeSignature.HigherOrder", "3:1-3:14") , ("Refactor.GenerateTypeSignature.Polymorph", "3:1-3:10") , ("Refactor.GenerateTypeSignature.PolymorphSub", "5:3-5:4") , ("Refactor.GenerateTypeSignature.PolymorphSubMulti", "5:3-5:4") , ("Refactor.GenerateTypeSignature.Placement", "4:1-4:10") , ("Refactor.GenerateTypeSignature.Tuple", "3:1-3:18") , ("Refactor.GenerateTypeSignature.Complex", "3:1-3:21") , ("Refactor.GenerateTypeSignature.Local", "4:3-4:12") , ("Refactor.GenerateTypeSignature.Let", "3:9-3:18") , ("Refactor.GenerateTypeSignature.TypeDefinedInModule", "3:1-3:1") , ("Refactor.GenerateTypeSignature.BringToScope.AlreadyQualImport", "6:1-6:2") ] generateExportsTests = [ "Refactor.GenerateExports.Normal" , "Refactor.GenerateExports.Operators" ] renameDefinitionTests = [ ("Refactor.RenameDefinition.AmbiguousFields", "4:14-4:15", "xx") , ("Refactor.RenameDefinition.RecordField", "3:22-3:23", "xCoord") , ("Refactor.RenameDefinition.Constructor", "3:14-3:19", "Point2D") , ("Refactor.RenameDefinition.Type", "5:16-5:16", "Point2D") , ("Refactor.RenameDefinition.Function", "3:1-3:2", "q") , ("Refactor.RenameDefinition.QualName", "3:1-3:2", "q") , ("Refactor.RenameDefinition.BacktickName", "3:1-3:2", "g") , ("Refactor.RenameDefinition.ParenName", "4:3-4:5", "<->") , ("Refactor.RenameDefinition.RecordWildcards", "4:32-4:33", "yy") , ("Refactor.RenameDefinition.RecordPatternSynonyms", "4:16-4:17", "xx") , ("Refactor.RenameDefinition.ClassMember", "7:3-7:4", "q") , ("Refactor.RenameDefinition.LocalFunction", "4:5-4:6", "g") , ("Refactor.RenameDefinition.LayoutAware", "3:1-3:2", "main") , ("Refactor.RenameDefinition.Arg", "4:3-4:4", "y") , ("Refactor.RenameDefinition.FunTypeVar", "3:6-3:7", "x") , ("Refactor.RenameDefinition.FunTypeVarLocal", "5:10-5:11", "b") , ("Refactor.RenameDefinition.ClassTypeVar", "3:9-3:10", "f") , ("Refactor.RenameDefinition.TypeOperators", "4:13-4:15", "x1") , ("Refactor.RenameDefinition.NoPrelude", "4:1-4:2", "map") , ("Refactor.RenameDefinition.UnusedDef", "3:1-3:2", "map") , ("Refactor.RenameDefinition.ImplicitParams", "8:17-8:20", "compare") , ("Refactor.RenameDefinition.SameCtorAndType", "3:6-3:13", "P2D") , ("Refactor.RenameDefinition.RoleAnnotation", "4:11-4:12", "AA") , ("Refactor.RenameDefinition.TypeBracket", "6:6-6:7", "B") , ("Refactor.RenameDefinition.ValBracket", "8:11-8:12", "B") ] wrongRenameDefinitionTests = [ ("Refactor.RenameDefinition.LibraryFunction", "4:5-4:7", "identity") , ("Refactor.RenameDefinition.NameClash", "5:9-5:10", "h") , ("Refactor.RenameDefinition.NameClash", "3:1-3:2", "map") , ("Refactor.RenameDefinition.WrongName", "4:1-4:2", "F") , ("Refactor.RenameDefinition.WrongName", "4:1-4:2", "++") , ("Refactor.RenameDefinition.WrongName", "7:6-7:7", "x") , ("Refactor.RenameDefinition.WrongName", "7:6-7:7", ":+:") , ("Refactor.RenameDefinition.WrongName", "7:10-7:11", "x") , ("Refactor.RenameDefinition.WrongName", "9:6-9:7", "A") , ("Refactor.RenameDefinition.WrongName", "9:19-9:19", ".+++.") , ("Refactor.RenameDefinition.WrongName", "11:3-11:3", ":+++:") , ("Refactor.RenameDefinition.IllegalQualRename", "4:30-4:34", "Bl") ] extractBindingTests = [ ("Refactor.ExtractBinding.Simple", "3:19-3:27", "exaggerate") , ("Refactor.ExtractBinding.Parentheses", "3:23-3:62", "sqDistance") , ("Refactor.ExtractBinding.AddToExisting", "3:10-3:12", "b") , ("Refactor.ExtractBinding.LocalDefinition", "4:13-4:16", "y") , ("Refactor.ExtractBinding.ClassInstance", "6:30-6:35", "g") , ("Refactor.ExtractBinding.ListComprehension", "5:25-5:39", "notDivisible") , ("Refactor.ExtractBinding.Records", "5:5-5:39", "plus") , ("Refactor.ExtractBinding.RecordWildcards", "6:5-6:27", "plus") ] wrongExtractBindingTests = [ ("Refactor.ExtractBinding.TooSimple", "3:19-3:20", "x") , ("Refactor.ExtractBinding.NameConflict", "3:19-3:27", "stms") ] multiModuleTests = [ ("RenameDefinition 5:5-5:6 bb", "A", "Refactor" "RenameDefinition" "MultiModule", []) , ("RenameDefinition 1:8-1:9 C", "B", "Refactor" "RenameDefinition" "RenameModule", ["B"]) , ("RenameDefinition 3:8-3:9 C", "A", "Refactor" "RenameDefinition" "RenameModule", ["B"]) , ("RenameDefinition 6:1-6:9 hello", "Use", "Refactor" "RenameDefinition" "SpliceDecls", []) , ("RenameDefinition 5:1-5:5 exprSplice", "Define", "Refactor" "RenameDefinition" "SpliceExpr", []) , ("RenameDefinition 6:1-6:4 spliceTyp", "Define", "Refactor" "RenameDefinition" "SpliceType", []) ] miscRefactorTests = [ ("Refactor.DataToNewtype.Cases", \_ _ -> dataToNewtype) , ("Refactor.IfToGuards.Simple", \wd mod -> ifToGuards (readSrcSpan (toFileName wd mod) "3:11-3:33")) , ("Refactor.DollarApp.FirstSingle", \wd mod -> dollarApp (readSrcSpan (toFileName wd mod) "5:5-5:12")) , ("Refactor.DollarApp.FirstMulti", \wd mod -> dollarApp (readSrcSpan (toFileName wd mod) "5:5-5:16")) , ("Refactor.DollarApp.InfixOperator", \wd mod -> dollarApp (readSrcSpan (toFileName wd mod) "5:5-5:16")) , ("Refactor.DollarApp.AnotherOperator", \wd mod -> dollarApp (readSrcSpan (toFileName wd mod) "5:5-5:15")) , ("Refactor.DollarApp.ImportDollar", \wd mod -> dollarApp (readSrcSpan (toFileName wd mod) "6:5-6:12")) ] makeMultiModuleTest :: (String, String, String, [String]) -> Test makeMultiModuleTest (refact, mod, root, removed) = TestLabel (root ++ ":" ++ mod) $ TestCase $ do res <- performRefactors refact (rootDir root) [] mod case res of Right result -> checkResults result removed Left err -> assertFailure $ "The transformation failed : " ++ err where checkResults :: [(String, Maybe String)] -> [String] -> IO () checkResults ((name, Just mod):rest) removed = do expected <- loadExpected False ((rootDir root) ++ "_res") name assertEqual "The transformed result is not what is expected" (standardizeLineEndings expected) (standardizeLineEndings mod) checkResults rest removed checkResults ((name, Nothing) : rest) removed = checkResults rest (delete name removed) checkResults [] [] = return () checkResults [] removed = assertFailure $ "Modules has not been marked as removed: " ++ concat (intersperse ", " removed) createTest :: String -> [String] -> String -> Test createTest refactoring args mod = TestLabel mod $ TestCase $ checkCorrectlyTransformed (refactoring ++ (concatMap (" "++) args)) rootDir mod createFailTest :: String -> [String] -> String -> Test createFailTest refactoring args mod = TestLabel mod $ TestCase $ checkTransformFails (refactoring ++ (concatMap (" "++) args)) rootDir mod makeOrganizeImportsTest :: String -> Test makeOrganizeImportsTest = createTest "OrganizeImports" [] makeGenerateSignatureTest :: (String, String) -> Test makeGenerateSignatureTest (mod, rng) = createTest "GenerateSignature" [rng] mod makeGenerateExportsTest :: String -> Test makeGenerateExportsTest mod = createTest "GenerateExports" [] mod makeRenameDefinitionTest :: (String, String, String) -> Test makeRenameDefinitionTest (mod, rng, newName) = createTest "RenameDefinition" [rng, newName] mod makeWrongRenameDefinitionTest :: (String, String, String) -> Test makeWrongRenameDefinitionTest (mod, rng, newName) = createFailTest "RenameDefinition" [rng, newName] mod makeExtractBindingTest :: (String, String, String) -> Test makeExtractBindingTest (mod, rng, newName) = createTest "ExtractBinding" [rng, newName] mod makeWrongExtractBindingTest :: (String, String, String) -> Test makeWrongExtractBindingTest (mod, rng, newName) = createFailTest "ExtractBinding" [rng, newName] mod checkCorrectlyTransformed :: String -> String -> String -> IO () checkCorrectlyTransformed command workingDir moduleName = do expected <- loadExpected True workingDir moduleName res <- performRefactor command workingDir [] moduleName assertEqual "The transformed result is not what is expected" (Right (standardizeLineEndings expected)) (mapRight standardizeLineEndings res) makeMiscRefactorTest :: (String, FilePath -> String -> LocalRefactoring IdDom) -> Test makeMiscRefactorTest (moduleName, refact) = TestLabel moduleName $ TestCase $ do expected <- loadExpected True rootDir moduleName res <- testRefactor (localRefactoring (refact rootDir moduleName)) moduleName assertEqual "The transformed result is not what is expected" (Right (standardizeLineEndings expected)) (mapRight standardizeLineEndings res) testRefactor :: Refactoring IdDom -> String -> IO (Either String String) testRefactor refact moduleName = runGhc (Just libdir) $ do initGhcFlags useDirs [rootDir] mod <- loadModule rootDir moduleName >>= parseTyped res <- runRefactor (toFileName rootDir moduleName, mod) [] refact case res of Right r -> return $ Right $ prettyPrint $ snd $ fromContentChanged $ head r Left err -> return $ Left err checkTransformFails :: String -> String -> String -> IO () checkTransformFails command workingDir moduleName = do res <- performRefactor command workingDir [] moduleName assertBool "The transform should fail for the given input" (isLeft res) loadExpected :: Bool -> String -> String -> IO String loadExpected resSuffix workingDir moduleName = do -- need to use binary or line endings will be translated expectedHandle <- openBinaryFile (workingDir map (\case '.' -> pathSeparator; c -> c) moduleName ++ (if resSuffix then "_res" else "") ++ ".hs") ReadMode hGetContents expectedHandle standardizeLineEndings = filter (/= '\r') makeReprintTest :: String -> Test makeReprintTest mod = TestLabel mod $ TestCase (checkCorrectlyPrinted rootDir mod) makeCpphsTest :: String -> Test makeCpphsTest mod = TestLabel mod $ TestCase (checkCorrectlyPrinted (rootDir "CppHs") mod) makeInstanceControlTest :: String -> Test makeInstanceControlTest mod = TestLabel mod $ TestCase (checkCorrectlyPrinted (rootDir "InstanceControl") mod) checkCorrectlyPrinted :: String -> String -> IO () checkCorrectlyPrinted workingDir moduleName = do -- need to use binary or line endings will be translated expectedHandle <- openBinaryFile (workingDir map (\case '.' -> pathSeparator; c -> c) moduleName ++ ".hs") ReadMode expected <- hGetContents expectedHandle (actual, actual', actual'') <- runGhc (Just libdir) $ do parsed <- loadModule workingDir moduleName actual <- prettyPrint <$> parseAST parsed actual' <- prettyPrint <$> parseRenamed parsed actual'' <- prettyPrint <$> parseTyped parsed return (actual, actual', actual'') assertEqual "The original and the transformed source differ" expected actual assertEqual "The original and the transformed source differ" expected actual' assertEqual "The original and the transformed source differ" expected actual'' performRefactors :: String -> String -> [String] -> String -> IO (Either String [(String, Maybe String)]) performRefactors command workingDir flags target = do mods <- getModules workingDir runGhc (Just libdir) $ do initGhcFlags useFlags flags useDirs (concatMap fst mods) setTargets (map (\mod -> (Target (TargetModule (GHC.mkModuleName mod)) True Nothing)) (concatMap snd mods)) load LoadAllTargets allMods <- getModuleGraph selectedMod <- getModSummary (GHC.mkModuleName target) let otherModules = filter (not . (\ms -> ms_mod ms == ms_mod selectedMod && ms_hsc_src ms == ms_hsc_src selectedMod)) allMods targetMod <- parseTyped selectedMod otherMods <- mapM parseTyped otherModules res <- performCommand (readCommand (toFileName workingDir target) command) (target, targetMod) (zip (map (GHC.moduleNameString . moduleName . ms_mod) otherModules) otherMods) return $ (\case Right r -> Right $ (map (\case ContentChanged (n,m) -> (n, Just $ prettyPrint m) ModuleRemoved m -> (m, Nothing) )) r Left l -> Left l) $ res type ParsedModule = Ann AST.UModule (Dom RdrName) SrcTemplateStage parseAST :: ModSummary -> Ghc ParsedModule parseAST modSum = do p <- parseModule modSum let annots = pm_annotations p srcBuffer = fromJust $ ms_hspp_buf $ pm_mod_summary p prepareAST srcBuffer . placeComments (snd annots) <$> (runTrf (fst annots) (getPragmaComments $ snd annots) $ trfModule modSum $ pm_parsed_source p) type RenamedModule = Ann AST.UModule (Dom GHC.Name) SrcTemplateStage parseRenamed :: ModSummary -> Ghc RenamedModule parseRenamed modSum = do p <- parseModule modSum tc <- typecheckModule p let annots = pm_annotations p srcBuffer = fromJust $ ms_hspp_buf $ pm_mod_summary p prepareAST srcBuffer . placeComments (getNormalComments $ snd annots) <$> (do parseTrf <- runTrf (fst annots) (getPragmaComments $ snd annots) $ trfModule modSum (pm_parsed_source p) runTrf (fst annots) (getPragmaComments $ snd annots) $ trfModuleRename modSum parseTrf (fromJust $ tm_renamed_source tc) (pm_parsed_source p)) performRefactor :: String -> FilePath -> [String] -> String -> IO (Either String String) performRefactor command workingDir flags target = runGhc (Just libdir) $ do initGhcFlags useFlags flags useDirs [workingDir] ((\case Right r -> Right (newContent r); Left l -> Left l) <$> (refact =<< parseTyped =<< loadModule workingDir target)) where refact m = performCommand (readCommand (toFileName workingDir target) command) (target,m) [] newContent (ContentChanged (_, newContent) : ress) = prettyPrint newContent newContent (_ : ress) = newContent ress -- tests for ast-gen genTests :: [Test] genTests = testBase ++ map makeGenTest testExprs ++ map makeGenTest testPatterns ++ map makeGenTest testType ++ map makeGenTest testBinds ++ map makeGenTest testDecls ++ map makeGenTest testModules makeGenTest :: SourceInfoTraversal elem => (String, Ann elem dom SrcTemplateStage) -> Test makeGenTest (expected, ast) = TestLabel expected $ TestCase $ assertEqual "The generated AST is not what is expected" expected (prettyPrint ast) testBase = [ makeGenTest ("A.b", mkNormalName $ mkQualifiedName ["A"] "b") , makeGenTest ("A.+", mkQualOp ["A"] "+") , makeGenTest ("`mod`", mkBacktickOp [] "mod") , makeGenTest ("(+)", mkParenName $ mkSimpleName "+") ] testExprs = [ ("a + 3", mkInfixApp (mkVar (mkName "a")) (mkUnqualOp "+") (mkLit $ mkIntLit 3)) , ("(\"xx\"++)", mkLeftSection (mkLit (mkStringLit "xx")) (mkUnqualOp "++")) , ("(1, [2, 3])", mkTuple [ mkLit (mkIntLit 1), mkList [ mkLit (mkIntLit 2), mkLit (mkIntLit 3) ] ]) , ("P { x = 1 }", mkRecCon (mkName "P") [ mkFieldUpdate (mkName "x") (mkLit $ mkIntLit 1) ]) , ("if f a then x else y", mkIf (mkApp (mkVar $ mkName "f") (mkVar $ mkName "a")) (mkVar $ mkName "x") (mkVar $ mkName "y")) , ("let nat = [0..] in !z", mkLet [mkLocalValBind $ mkSimpleBind' (mkName "nat") (mkEnum (mkLit (mkIntLit 0)) Nothing Nothing)] (mkPrefixApp (mkUnqualOp "!") (mkVar $ mkName "z")) ) , ( "case x of Just y -> y\n" ++ " Nothing -> 0", mkCase (mkVar (mkName "x")) [ mkAlt (mkAppPat (mkName "Just") [mkVarPat (mkName "y")]) (mkCaseRhs $ mkVar (mkName "y")) Nothing , mkAlt (mkVarPat $ mkName "Nothing") (mkCaseRhs $ mkLit $ mkIntLit 0) Nothing ]) , ( "if | x > y -> x\n" ++ " | otherwise -> y", mkMultiIf [ mkGuardedCaseRhs [mkGuardCheck $ mkInfixApp (mkVar (mkName "x")) (mkUnqualOp ">") (mkVar (mkName "y"))] (mkVar (mkName "x")) , mkGuardedCaseRhs [mkGuardCheck $ mkVar (mkName "otherwise")] (mkVar (mkName "y")) ]) , ( "do x <- a\n" ++ " return x", mkDoBlock [ G.mkBindStmt (mkVarPat (mkName "x")) (mkVar (mkName "a")) , mkExprStmt (mkApp (mkVar $ mkName "return") (mkVar $ mkName "x")) ]) ] testPatterns = [ ("~[0, a]", mkIrrefutablePat $ mkListPat [ mkLitPat (mkIntLit 0), mkVarPat (mkName "a") ]) , ("p@Point{ x = 1 }", mkAsPat (mkName "p") $ mkRecPat (mkName "Point") [ mkPatternField (mkName "x") (mkLitPat (mkIntLit 1)) ]) , ("!(_, f -> 3)", mkBangPat $ mkTuplePat [mkWildPat, mkViewPat (mkVar $ mkName "f") (mkLitPat (mkIntLit 3))]) ] testType = [ ("forall x . Eq x => x -> ()", mkForallType [mkTypeVar (mkName "x")] $ mkCtxType (mkContextOne (mkClassAssert (mkName "Eq") [mkVarType (mkName "x")])) $ mkFunctionType (mkVarType (mkName "x")) (mkVarType (mkName "()"))) , ("(A :+: B) (x, x)", mkTypeApp (mkParenType $ mkInfixTypeApp (mkVarType (mkName "A")) (mkUnqualOp ":+:") (mkVarType (mkName "B"))) (mkTupleType [ mkVarType (mkName "x"), mkVarType (mkName "x") ])) ] testBinds = [( "x = (a, b) where a = 3\n" ++ " b = 4", mkSimpleBind (mkVarPat (mkName "x")) (mkUnguardedRhs (mkTuple [(mkVar (mkName "a")), (mkVar (mkName "b"))])) (Just $ mkLocalBinds' [ mkLocalValBind $ mkSimpleBind' (mkName "a") (mkLit $ mkIntLit 3) , mkLocalValBind $ mkSimpleBind' (mkName "b") (mkLit $ mkIntLit 4) ]) ) ,( "f i 0 = i\n" ++ "f i x = x", mkFunctionBind' (mkName "f") [ ([mkVarPat $ mkName "i", mkLitPat $ mkIntLit 0], mkVar $ mkName "i") , ([mkVarPat $ mkName "i", mkVarPat $ mkName "x"], mkVar $ mkName "x") ]) ] testDecls = [ ("id :: a -> a", mkTypeSigDecl $ mkTypeSignature (mkName "id") (mkFunctionType (mkVarType (mkName "a")) (mkVarType (mkName "a")))) , ("id x = x", mkValueBinding $ mkFunctionBind' (mkName "id") [([mkVarPat $ mkName "x"], mkVar $ mkName "x")]) , ("data A a = A a deriving Show", mkDataDecl mkDataKeyword Nothing (mkDeclHeadApp (mkNameDeclHead (mkName "A")) (mkTypeVar (mkName "a"))) [mkConDecl (mkName "A") [mkVarType (mkName "a")]] (Just $ mkDeriving [mkInstanceHead (mkName "Show")])) , ("data A = A { x :: Int }", mkDataDecl mkDataKeyword Nothing (mkNameDeclHead (mkName "A")) [mkRecordConDecl (mkName "A") [mkFieldDecl [mkName "x"] (mkVarType (mkName "Int"))]] Nothing) , ( "class A t => C t where f :: t\n" ++ " type T t :: *" , mkClassDecl (Just $ mkContextOne (mkClassAssert (mkName "A") [mkVarType (mkName "t")])) (mkDeclHeadApp (mkNameDeclHead (mkName "C")) (mkTypeVar (mkName "t"))) [] (Just $ mkClassBody [ mkClassElemSig $ mkTypeSignature (mkName "f") (mkVarType (mkName "t")) , mkClassElemTypeFam (mkDeclHeadApp (mkNameDeclHead (mkName "T")) (mkTypeVar (mkName "t"))) (Just $ mkTypeFamilyKindSpec $ mkKindConstraint $ mkKindStar) ]) ) , ("instance C Int where f = 0", mkInstanceDecl Nothing (mkInstanceRule Nothing $ mkAppInstanceHead (mkInstanceHead $ mkName "C") (mkVarType (mkName "Int"))) (Just $ mkInstanceBody [mkInstanceBind $ mkSimpleBind' (mkName "f") (mkLit $ mkIntLit 0)])) , ("infixl 6 +", mkFixityDecl $ mkInfixL 6 (mkUnqualOp "+")) ] testModules = [ ("", G.mkModule [] Nothing [] []) , ("module Test(x, A(a), B(..)) where", G.mkModule [] (Just $ mkModuleHead (G.mkModuleName "Test") (Just $ mkExportSpecs [ mkExportSpec $ mkIESpec (mkName "x") Nothing , mkExportSpec $ mkIESpec (mkName "A") (Just $ mkSubList [mkName "a"]) , mkExportSpec $ mkIESpec (mkName "B") (Just mkSubAll) ]) Nothing) [] []) , ("\nimport qualified A\n" ++ "import B as BB(x)\n" ++ "import B hiding (x)", G.mkModule [] Nothing [ mkImportDecl False True False Nothing (G.mkModuleName "A") Nothing Nothing , mkImportDecl False False False Nothing (G.mkModuleName "B") (Just $ G.mkModuleName "BB") (Just $ mkImportSpecList [mkIESpec (mkName "x") Nothing]) , mkImportDecl False False False Nothing (G.mkModuleName "B") Nothing (Just $ mkImportHidingList [mkIESpec (mkName "x") Nothing]) ] []) ]