{-# LANGUAGE LambdaCase, TypeFamilies #-} module Main where import Test.Tasty (TestTree, testGroup, defaultMain) import Test.Tasty.HUnit import DynFlags (xopt) import GHC hiding (loadModule, ParsedModule) import GHC.Paths ( libdir ) import Module as GHC (mkModuleName) import StringBuffer (hGetStringBuffer) import Control.Monad (Monad(..), mapM, (=<<)) import Control.Monad.IO.Class (MonadIO(..)) import Control.Reference ((^.)) import Data.Either.Combinators (mapRight, isLeft) import Data.List import Data.List.Split (splitOn) import Data.Maybe (Maybe(..), fromJust) import Language.Haskell.TH.LanguageExtensions (Extension(..)) import System.Directory (listDirectory) import System.FilePath import System.IO import Language.Haskell.Tools.AST as AST import Language.Haskell.Tools.BackendGHC (runTrf, trfModule, trfModuleRename) import Language.Haskell.Tools.PrettyPrint (prettyPrint) import Language.Haskell.Tools.PrettyPrint.Prepare import Language.Haskell.Tools.Refactor import Language.Haskell.Tools.Refactor.Builtin (builtinRefactorings) --import ExtensionOrganizerTest.Main (extensionOrganizerTestGroup) main :: IO () main = defaultMain nightlyTests nightlyTests :: TestTree nightlyTests = testGroup "all tests" [ testGroup "functional tests" functionalTests , testGroup "CppHs tests" $ map makeCpphsTest cppHsTests , testGroup "instance-control tests" $ map makeInstanceControlTest instanceControlTests ] functionalTests :: [TestTree] functionalTests = [ testGroup "reprint tests" (map makeReprintTest checkTestCases) , testGroup "refactor tests" $ map makeOrganizeImportsTest organizeImportTests ++ map makeGenerateSignatureTest generateSignatureTests ++ map makeWrongGenerateSigTest wrongGenerateSigTests ++ map makeGenerateExportsTest generateExportsTests ++ map makeRenameDefinitionTest renameDefinitionTests ++ map makeWrongRenameDefinitionTest wrongRenameDefinitionTests ++ map makeExtractBindingTest extractBindingTests ++ map makeWrongExtractBindingTest wrongExtractBindingTests ++ map makeInlineBindingTest inlineBindingTests ++ map makeWrongInlineBindingTest wrongInlineBindingTests ++ map makeFloatOutTest floatOutTests ++ map makeWrongFloatOutTest wrongFloatOutTests ++ map (makeMultiModuleTest checkMultiResults) multiModuleTests ++ map (makeMultiModuleTest checkMultiFail) wrongMultiModuleTests ] where checkTestCases = languageTests ++ organizeImportTests ++ map fst generateSignatureTests ++ generateExportsTests ++ map (\(mod,_,_) -> mod) renameDefinitionTests ++ map (\(mod,_,_) -> mod) wrongRenameDefinitionTests ++ map (\(mod,_,_) -> mod) extractBindingTests ++ map (\(mod,_,_) -> mod) wrongExtractBindingTests ++ map (\(mod,_) -> mod) inlineBindingTests rootDir = "examples" languageTests = [ "CPP.JustEnabled" , "CPP.ConditionalCode" , "Decl.AmbiguousFields" , "Decl.AnnPragma" , "Decl.ClassInfix" , "Decl.ClosedTypeFamily" , "Decl.CompletePragma" , "Decl.CtorOp" , "Decl.DataFamily" , "Decl.DataType" , "Decl.DataInstanceGADT" , "Decl.DataTypeDerivings" , "Decl.DefaultDecl" , "Decl.FunBind" , "Decl.FunctionalDeps" , "Decl.FunGuards" , "Decl.GADT" , "Decl.GadtConWithCtx" , "Decl.InfixAssertion" , "Decl.InfixInstances" , "Decl.InfixPatSyn" , "Decl.InjectiveTypeFamily" , "Decl.InlinePragma" , "Decl.InstanceFamily" , "Decl.InstanceOverlaps" , "Decl.InstanceSpec" , "Decl.LocalBindings" , "Decl.LocalBindingInDo" , "Decl.LocalFixity" , "Decl.MinimalPragma" , "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" , "Decl.ViewPatternSynonym" , "Expr.ArrowNotation" , "Expr.Case" , "Expr.DoNotation" , "Expr.GeneralizedListComp" , "Expr.EmptyCase" , "Expr.FunSection" , "Expr.If" , "Expr.LambdaCase" , "Expr.ListComp" , "Expr.MultiwayIf" , "Expr.Negate" , "Expr.Operator" , "Expr.ParenName" , "Expr.ParListComp" , "Expr.PatternAndDo" , "Expr.RecordPuns" , "Expr.RecordWildcards" , "Expr.RecursiveDo" , "Expr.Sections" , "Expr.SemicolonDo" , "Expr.StaticPtr" , "Expr.TupleSections" , "Expr.UnboxedSum" , "Module.Simple" , "Module.GhcOptionsPragma" , "Module.Export" , "Module.ExportSubs" , "Module.ExportModifiers" , "Module.NamespaceExport" , "Module.Import" , "Module.ImportOp" , "Module.LangPragmas" , "Module.PatternImport" , "Pattern.Backtick" , "Pattern.Constructor" -- , "Pattern.ImplicitParams" , "Pattern.Infix" , "Pattern.NestedWildcard" , "Pattern.NPlusK" , "Pattern.OperatorPattern" , "Pattern.Record" , "Pattern.UnboxedSum" , "Type.Bang" , "Type.Builtin" , "Type.Ctx" , "Type.ExplicitTypeApplication" , "Type.Forall" , "Type.Primitives" , "Type.TupleAssert" , "Type.TypeOperators" , "Type.Unpack" , "Type.Wildcard" , "TH.Brackets" , "TH.QuasiQuote.Define" , "TH.QuasiQuote.Use" , "TH.Splice.Define" , "TH.Splice.Use" , "TH.CrossDef" , "TH.ClassUse" , "TH.Splice.UseImported" , "TH.Splice.UseQual" , "TH.Splice.UseQualMulti" , "TH.LocalDefinition" , "TH.MultiImport" , "TH.NestedSplices" , "TH.Quoted" , "TH.WithWildcards" , "TH.DoubleSplice" , "TH.GADTFields" , "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.Ctor" , "Refactor.OrganizeImports.Class" , "Refactor.OrganizeImports.Coerce" , "Refactor.OrganizeImports.Fields" , "Refactor.OrganizeImports.Operator" , "Refactor.OrganizeImports.SameName" , "Refactor.OrganizeImports.Removed" , "Refactor.OrganizeImports.ReorderGroups" , "Refactor.OrganizeImports.ReorderComment" , "Refactor.OrganizeImports.KeepCtorOfMarshalled" , "Refactor.OrganizeImports.KeepHiding" , "Refactor.OrganizeImports.KeepPrelude" , "Refactor.OrganizeImports.KeepReexported" , "Refactor.OrganizeImports.KeepRenamedReexported" , "Refactor.OrganizeImports.KeepExplicit" , "Refactor.OrganizeImports.MakeExplicit.ImportOne" , "Refactor.OrganizeImports.MakeExplicit.ImportThree" , "Refactor.OrganizeImports.MakeExplicit.ImportClassFun" , "Refactor.OrganizeImports.MakeExplicit.ImportCon" , "Refactor.OrganizeImports.MakeExplicit.ImportRecordSel" , "Refactor.OrganizeImports.MakeExplicit.ImportUnited" , "Refactor.OrganizeImports.MakeExplicit.ImportUnitedCount" , "Refactor.OrganizeImports.MakeExplicit.ImportFour" , "Refactor.OrganizeImports.MakeExplicit.ImportFunHiddenClass" , "Refactor.OrganizeImports.MakeExplicit.ImportFunOutOfClass" , "Refactor.OrganizeImports.MakeExplicit.Renamed" , "Refactor.OrganizeImports.InstanceCarry.ImportOrphan" , "Refactor.OrganizeImports.InstanceCarry.ImportNonOrphan" , "Refactor.OrganizeImports.NarrowQual" , "Refactor.OrganizeImports.NarrowSpec" , "Refactor.OrganizeImports.StandaloneDeriving" , "Refactor.OrganizeImports.TemplateHaskell" , "Refactor.OrganizeImports.NarrowType" , "CPP.BetweenImports" , "CPP.ConditionalImport" , "CPP.ConditionalImportBegin" , "CPP.ConditionalImportEnd" , "CPP.ConditionalSubImport" , "CPP.ConditionalImportHalfRemoved" , "CPP.ConditionalImportMulti" , "CPP.ConditionalImportOrder" ] 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") , ("Refactor.GenerateTypeSignature.CanCaptureVariable", "8:10-8:10") , ("Refactor.GenerateTypeSignature.CanCaptureVariableHasOtherDef", "8:10-8:10") ] wrongGenerateSigTests = [ ("Refactor.GenerateTypeSignature.CannotCaptureVariable", "7:10-7:10") , ("Refactor.GenerateTypeSignature.CannotCaptureVariableNoExt", "8:10-8:10") , ("Refactor.GenerateTypeSignature.ComplexLhs", "3:1") , ("Refactor.GenerateTypeSignature.ComplexLhs", "4:1") , ("Refactor.GenerateTypeSignature.ComplexLhs", "5:1") , ("Refactor.GenerateTypeSignature.ComplexLhs", "6:1") ] 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.AccentName", "3:1-3:2", "รก") , ("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.FormattingAware", "3:1-3:2", "aa") , ("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.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") , ("Refactor.RenameDefinition.FunnyDo", "3:1-3:2", "aaa") , ("Refactor.RenameDefinition.RenameModuleAlias", "3:21-3:23", "L") , ("Refactor.RenameDefinition.MergeFields", "3:14-3:15", "y") , ("Refactor.RenameDefinition.MergeFields_RenameY", "3:34-3:35", "x") , ("Refactor.RenameDefinition.PatternSynonym", "6:9", "ArrowAppl") , ("Refactor.RenameDefinition.PatternSynonymTypeSig", "6:9", "ArrowAppl") , ("Refactor.RenameDefinition.QualImport", "5:1", "intercalate") ] 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") , ("Refactor.RenameDefinition.CrossRename", "4:1-4:2", "g") , ("Refactor.RenameDefinition.MergeFields", "5:16-5:18", "y2") -- fld in the same ctor , ("Refactor.RenameDefinition.MergeFields", "5:30-5:32", "x2") -- fld in the same ctor , ("Refactor.RenameDefinition.MergeFields", "5:16-5:18", "y") -- fld belongs to other type , ("Refactor.RenameDefinition.MergeFields", "7:16-7:18", "y3") -- types does not match , ("Refactor.RenameDefinition.MergeFields", "7:38-7:40", "x3") -- types does not match , ("Refactor.RenameDefinition.QualImportAlso", "6:1", "intercalate") -- there is a non-qualified import ] 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") , ("Refactor.ExtractBinding.ExistingLocalDef", "3:5-3:10", "a") , ("Refactor.ExtractBinding.Indentation", "3:12-3:18", "extracted") , ("Refactor.ExtractBinding.IndentationMultiLine", "3:12-3:18", "extracted") , ("Refactor.ExtractBinding.IndentationOperator", "3:13-3:20", "extracted") , ("Refactor.ExtractBinding.ExtractedFormatting", "4:5-5:7", "extracted") , ("Refactor.ExtractBinding.LeftSection", "3:5-3:8", "f") , ("Refactor.ExtractBinding.RightSection", "3:7-3:10", "f") , ("Refactor.ExtractBinding.SectionWithLocals", "6:13-6:24", "f") , ("Refactor.ExtractBinding.SectionInfix", "3:5-3:12", "f") , ("Refactor.ExtractBinding.AssocOp", "3:9-3:14", "b") , ("Refactor.ExtractBinding.AssocOpRightAssoc", "3:5-3:12", "g") , ("Refactor.ExtractBinding.AssocOpMiddle", "3:9-3:14", "b") , ("Refactor.ExtractBinding.SiblingDefs", "7:9-7:10", "a") , ("Refactor.ExtractBinding.Case", "3:26-3:31", "g") ] wrongExtractBindingTests = [ ("Refactor.ExtractBinding.TooSimple", "3:19-3:20", "x") , ("Refactor.ExtractBinding.NameConflict", "3:19-3:27", "stms") , ("Refactor.ExtractBinding.ViewPattern", "4:4-4:11", "idid") ] inlineBindingTests = [ ("Refactor.InlineBinding.Simplest", "4:1-4:2") , ("Refactor.InlineBinding.Nested", "4:1-4:2") , ("Refactor.InlineBinding.Local", "4:9-4:10") , ("Refactor.InlineBinding.LocalNested", "5:17-5:18") , ("Refactor.InlineBinding.WithLocals", "4:1-4:2") , ("Refactor.InlineBinding.MultiMatch", "4:1-4:2") , ("Refactor.InlineBinding.SimpleMultiMatch", "4:1-4:2") , ("Refactor.InlineBinding.AlreadyApplied", "4:1-4:2") , ("Refactor.InlineBinding.PatternMatched", "4:1-4:2") , ("Refactor.InlineBinding.MultiApplied", "4:1-4:2") , ("Refactor.InlineBinding.Operator", "4:1-4:2") , ("Refactor.InlineBinding.MultiMatchGuarded", "4:1-4:2") , ("Refactor.InlineBinding.RemoveSignatures", "5:1-5:2") , ("Refactor.InlineBinding.FilterSignatures", "5:1-5:2") , ("Refactor.InlineBinding.LetBind", "3:9-3:10") , ("Refactor.InlineBinding.LetStmt", "3:12-3:13") , ("Refactor.InlineBinding.LetGuard", "3:9-3:10") ] wrongInlineBindingTests = [ ("Refactor.InlineBinding.Recursive", "4:1-4:2") , ("Refactor.InlineBinding.InExportList", "4:1-4:2") , ("Refactor.InlineBinding.NotOccurring", "3:1") ] floatOutTests = [ ("Refactor.FloatOut.ToTopLevel", "4:10") , ("Refactor.FloatOut.FloatLocals", "5:18") , ("Refactor.FloatOut.MoveSignature", "5:10") , ("Refactor.FloatOut.MoveFixity", "5:11-5:14") , ("Refactor.FloatOut.NoCollosion", "5:18") ] wrongFloatOutTests = [ ("Refactor.FloatOut.NameCollosion", "4:10") , ("Refactor.FloatOut.NameCollosionWithImport", "4:11") , ("Refactor.FloatOut.NameCollosionWithLocal", "5:18") , ("Refactor.FloatOut.SharedSignature", "5:10") , ("Refactor.FloatOut.ImplicitLocal", "4:10") , ("Refactor.FloatOut.ImplicitParam", "4:10") ] 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", []) ] wrongMultiModuleTests = [ ("InlineBinding 3:1-3:2", "A", "Refactor" "InlineBinding" "AppearsInAnother", []) ] makeMultiModuleTest :: ((String, String, String, [String]) -> Either String [(String, Maybe String)] -> IO ()) -> (String, String, String, [String]) -> TestTree makeMultiModuleTest checker test@(refact, mod, root, _) = testCase (root ++ ":" ++ mod) $ do res <- performRefactors refact (rootDir root) [] mod checker test res checkMultiResults :: (String, String, String, [String]) -> Either String [(String, Maybe String)] -> IO () checkMultiResults _ (Left err) = assertFailure $ "The transformation failed : " ++ err checkMultiResults test@(_,_,root,_) (Right ((name, Just mod):rest)) = do expected <- loadExpected False ((rootDir root) ++ "_res") name assertEqual "The transformed result is not what is expected" (standardizeLineEndings expected) (standardizeLineEndings mod) checkMultiResults test (Right rest) checkMultiResults (r,m,root,removed) (Right ((name, Nothing) : rest)) = checkMultiResults (r,m,root,delete name removed) (Right rest) checkMultiResults (_,_,_,[]) (Right []) = return () checkMultiResults (_,_,_,removed) (Right []) = assertFailure $ "Modules has not been marked as removed: " ++ concat (intersperse ", " removed) checkMultiFail :: (String, String, String, [String]) -> Either String [(String, Maybe String)] -> IO () checkMultiFail _ (Left _) = return () checkMultiFail _ (Right _) = assertFailure "The transformation should fail." createTest :: String -> [String] -> String -> TestTree createTest refactoring args mod = testCase mod $ checkCorrectlyTransformed (refactoring ++ (concatMap (" "++) args)) rootDir mod createFailTest :: String -> [String] -> String -> TestTree createFailTest refactoring args mod = testCase mod $ checkTransformFails (refactoring ++ (concatMap (" "++) args)) rootDir mod makeOrganizeImportsTest :: String -> TestTree makeOrganizeImportsTest = createTest "OrganizeImports" [] makeGenerateSignatureTest :: (String, String) -> TestTree makeGenerateSignatureTest (mod, rng) = createTest "GenerateSignature" [rng] mod makeGenerateExportsTest :: String -> TestTree makeGenerateExportsTest mod = createTest "GenerateExports" [] mod makeRenameDefinitionTest :: (String, String, String) -> TestTree makeRenameDefinitionTest (mod, rng, newName) = createTest "RenameDefinition" [rng, newName] mod makeWrongRenameDefinitionTest :: (String, String, String) -> TestTree makeWrongRenameDefinitionTest (mod, rng, newName) = createFailTest "RenameDefinition" [rng, newName] mod makeWrongGenerateSigTest :: (String, String) -> TestTree makeWrongGenerateSigTest (mod, rng) = createFailTest "GenerateSignature" [rng] mod makeExtractBindingTest :: (String, String, String) -> TestTree makeExtractBindingTest (mod, rng, newName) = createTest "ExtractBinding" [rng, newName] mod makeWrongExtractBindingTest :: (String, String, String) -> TestTree makeWrongExtractBindingTest (mod, rng, newName) = createFailTest "ExtractBinding" [rng, newName] mod makeInlineBindingTest :: (String, String) -> TestTree makeInlineBindingTest (mod, rng) = createTest "InlineBinding" [rng] mod makeWrongInlineBindingTest :: (String, String) -> TestTree makeWrongInlineBindingTest (mod, rng) = createFailTest "InlineBinding" [rng] mod makeFloatOutTest :: (String, String) -> TestTree makeFloatOutTest (mod, rng) = createTest "FloatOut" [rng] mod makeWrongFloatOutTest :: (String, String) -> TestTree makeWrongFloatOutTest (mod, rng) = createFailTest "FloatOut" [rng] 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) testRefactor :: (UnnamedModule IdDom -> LocalRefactoring IdDom) -> String -> IO (Either String String) testRefactor refact moduleName = runGhc (Just libdir) $ do initGhcFlags useDirs [rootDir] mod <- loadModule rootDir moduleName >>= parseTyped res <- runRefactor (SourceFileKey (rootDir moduleSourceFile moduleName) moduleName, mod) [] (localRefactoring $ refact mod) 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 hSetEncoding expectedHandle utf8 hGetContents expectedHandle standardizeLineEndings = filter (/= '\r') makeReprintTest :: String -> TestTree makeReprintTest mod = testCase mod (checkCorrectlyPrinted rootDir mod) makeCpphsTest :: String -> TestTree makeCpphsTest mod = testCase mod (checkCorrectlyPrinted (rootDir "CppHs") mod) makeInstanceControlTest :: String -> TestTree makeInstanceControlTest mod = testCase mod (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 "Parsed: The original and the transformed source differ" expected actual assertEqual "Renamed: The original and the transformed source differ" expected actual' assertEqual "Typechecked: 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 sourceFiles <- filter ((== ".hs") . takeExtension) <$> listDirectory workingDir let sourceModules = map dropExtension sourceFiles runGhc (Just libdir) $ do initGhcFlagsForTest useFlags flags useDirs [workingDir] setTargets $ map (\mod -> (Target (TargetModule (GHC.mkModuleName mod)) True Nothing)) sourceModules 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 builtinRefactorings (splitOn " " command) (Right (SourceFileKey (workingDir moduleSourceFile target) target, targetMod)) (zip (map keyFromMS otherModules) otherMods) return $ (\case Right r -> Right $ (map (\case ContentChanged (n,m) -> (n ^. sfkModuleName, Just $ prettyPrint m) ModuleCreated 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 let hasStaticFlags = StaticPointers `xopt` ms_hspp_opts modSum hasCppExtension = Cpp `xopt` ms_hspp_opts modSum ms = if hasStaticFlags then forceAsmGen modSum else modSum p <- parseModule ms sourceOrigin <- if hasCppExtension then liftIO $ hGetStringBuffer (getModSumOrig ms) else return (fromJust $ ms_hspp_buf $ pm_mod_summary p) let annots = pm_annotations p (if hasCppExtension then prepareASTCpp else prepareAST) sourceOrigin . placeComments (fst annots) (getNormalComments $ snd annots) <$> (runTrf (fst annots) (getPragmaComments $ snd annots) $ trfModule ms $ pm_parsed_source p) type RenamedModule = Ann AST.UModule (Dom GHC.Name) SrcTemplateStage parseRenamed :: ModSummary -> Ghc RenamedModule parseRenamed modSum = do let hasStaticFlags = StaticPointers `xopt` ms_hspp_opts modSum hasCppExtension = Cpp `xopt` ms_hspp_opts modSum ms = if hasStaticFlags then forceAsmGen modSum else modSum p <- parseModule ms sourceOrigin <- if hasCppExtension then liftIO $ hGetStringBuffer (getModSumOrig ms) else return (fromJust $ ms_hspp_buf $ pm_mod_summary p) tc <- typecheckModule p let annots = pm_annotations p (if hasCppExtension then prepareASTCpp else prepareAST) sourceOrigin . placeComments (fst annots) (getNormalComments $ snd annots) <$> (do parseTrf <- runTrf (fst annots) (getPragmaComments $ snd annots) $ trfModule ms (pm_parsed_source p) runTrf (fst annots) (getPragmaComments $ snd annots) $ trfModuleRename ms 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 useFlags flags ((\case Right r -> Right (newContent r); Left l -> Left l) <$> (refact =<< parseTyped =<< loadModule workingDir target)) where refact m = performCommand builtinRefactorings (splitOn " " command) (Right (SourceFileKey (workingDir moduleSourceFile target) target,m)) [] newContent (ContentChanged (_, newContent) : _) = prettyPrint newContent newContent ((ModuleCreated _ newContent _) : _) = prettyPrint newContent newContent (_ : ress) = newContent ress