module Main where
import Test.Tasty (TestTree, testGroup, defaultMain)
import Test.Tasty.HUnit (assertEqual, testCase)
import GHC hiding (loadModule, ModuleName)
import GHC.Paths (libdir)
import Language.Haskell.TH.LanguageExtensions (Extension)
import SrcLoc (SrcSpan(..), srcSpanEndLine)
import Data.List (sort)
import Control.Monad (unless)
import qualified Data.Map.Strict as SMap (Map, map)
import System.FilePath (FilePath, addExtension, (</>))
import ExtensionOrganizerTest.AnnotationParser
import Language.Haskell.Tools.Refactor hiding (ModuleName)
import Language.Haskell.Tools.Refactor.Builtin.OrganizeExtensions
import Control.Reference (_1, (.-))
{- NOTE:
Exhaustive checks for Pattern type AST nodes are not given for each check.
We only give exhaustive test cases for nested patterns in bangPatternsTest.
-}
main :: IO ()
main = defaultMain extensionOrganizerTestGroup
extensionOrganizerTestGroup = testGroup "ExtensionOrganizerTest"
[ mkTests recordWildCardsTest
, mkTests flexibleInstancesTest
, mkTests derivingsTest
, mkTests patternSynonymsTest
, mkTests bangPatternsTest
, mkTests templateHaskellTest
, mkTests viewPatternsTest
, mkTests lambdaCaseTest
, mkTests tupleSectionsTest
, mkNestedTests magicHashTest
, mkTests functionalDependenciesTest
, mkTests defaultSignaturesTest
, mkTests recursiveDoTest
, mkTests arrowsTest
, mkTests parallelListCompTest
, mkTests typeFamiliesTest
, mkTests multiParamTypeClassesTest
, mkTests constraintKindsTest
, mkTests kindSignaturesTest
, mkTests explicitNamespacesTest
, mkTests overloadedStringsTest
, mkTests gadtsTest
, mkTests existentialQuantificationTest
, mkTests constrainedClassMethodsTest
, mkTests multiWayIfTest
, mkTests typeOperatorsTest
]
testRoot = "test/ExtensionOrganizerTest"
mkModulePath :: FilePath -> ModuleName -> FilePath
mkModulePath testDir testName = testRoot </> testDir </> testName
type NestedTestSuite = (FilePath, [TestSuite])
type TestSuite = (FilePath, [TestName])
type TestName = String
type ModuleName = String
type Line = Int
type SimpleMap = SMap.Map (LogicalRelation Extension) [Line]
spanToLine :: SrcSpan -> Line
spanToLine (RealSrcSpan s) = srcSpanEndLine s
simplifyExtMap :: ExtMap -> SimpleMap
simplifyExtMap = SMap.map (map spanToLine)
getExtensionsFrom :: FilePath -> ModuleName -> IO SimpleMap
getExtensionsFrom dir moduleName = runGhc (Just libdir) $ do
modAST <- loadModuleAST (testRoot </> dir) moduleName
exts <- collectExtensions modAST
return $! simplifyExtMap exts
getLclExtAnnotsFrom :: FilePath -> ModuleName -> IO SimpleMap
getLclExtAnnotsFrom dir moduleName = do
s <- readFile $ addExtension (mkModulePath dir moduleName) ".hs"
return $! getLocalExtensionAnnotations s
getGlbExtAnnotsFrom :: FilePath -> ModuleName -> IO [Extension]
getGlbExtAnnotsFrom dir moduleName = do
s <- readFile $ addExtension (mkModulePath dir moduleName) ".hs"
return $! getGlobalExtensionAnnotations s
mkTest :: FilePath -> ModuleName -> TestTree
mkTest dir moduleName = testCase moduleName $ mkAssertion dir moduleName
-- | Compares the local annotations with the result of the checker.
-- Also compares the global expected result with minimized extension set.
mkAssertion :: FilePath -> ModuleName -> IO ()
mkAssertion dir moduleName = do
global <- getGlbExtAnnotsFrom dir moduleName
local <- getLclExtAnnotsFrom dir moduleName
result <- getExtensionsFrom dir moduleName
let minimalExts = determineExtensions result
mapSort = SMap.map sort
assertEqual "Failure" (mapSort local) (mapSort result)
unless (null global) $ assertEqual "Failure" (sort global) (sort minimalExts)
mkTests :: TestSuite -> TestTree
mkTests (testDir, tests) = testGroup testDir (map (mkTest testDir) tests)
mkNestedTests :: NestedTestSuite -> TestTree
mkNestedTests (parentDir, suites) = testGroup parentDir nestedTests
where nestedSuites = map (_1 .- (parentDir </>)) suites
nestedTests = map mkTests nestedSuites
recordWildCardsTest :: TestSuite
recordWildCardsTest = (recordWildCardsRoot, recordWildCardsModules)
recordWildCardsRoot = "RecordWildCardsTest"
recordWildCardsModules = [ "InExpression"
, "InPattern"
]
flexibleInstancesTest :: TestSuite
flexibleInstancesTest = (flexibleInstancesRoot, flexibleInstancesModules)
flexibleInstancesRoot = "FlexibleInstancesTest"
flexibleInstancesModules = [ "Combined"
, "NestedTypes"
, "NestedUnitTyCon"
, "NestedWiredInType"
, "NoOccurence"
, "SameTyVars"
, "TopLevelTyVar"
, "TopLevelWiredInType"
, "SynonymCombined"
, "SynonymNestedTypes"
, "SynonymNestedUnitTyCon"
, "SynonymNestedWiredInType"
, "SynonymNoOccurence"
, "SynonymSameTyVars"
, "SynonymTopLevelTyVar"
]
derivingsTest :: TestSuite
derivingsTest = (derivingsRoot, derivingsModules)
derivingsRoot = "DerivingsTest"
derivingsModules = [ "DataDeriving"
, "DataDerivingStrategies"
, "NewtypeDeriving"
, "NewtypeDerivingStrategies"
, "StandaloneData"
, "StandaloneDataStrategies"
, "StandaloneDataSynonyms"
, "StandaloneDataSynonymsStrategies"
, "StandaloneNewtype"
, "StandaloneNewtypeStrategies"
, "StandaloneNewtypeAny"
, "StandaloneNewtypeSynonyms"
, "StandaloneNewtypeSynonymsStrategies"
, "StandaloneNewtypeSynonymsAny"
]
patternSynonymsTest :: TestSuite
patternSynonymsTest = (patSynRoot, patSynModules)
patSynRoot = "PatternSynonymsTest"
patSynModules = [ "UniDirectional"
, "BiDirectional"
]
bangPatternsTest :: TestSuite
bangPatternsTest = (bangPatternsRoot, bangPatternsModules)
bangPatternsRoot = "BangPatternsTest"
bangPatternsModules = [ "Combined"
, "InAlt"
, "InExpr"
, "InMatchLhs"
, "InPatSynRhs"
, "InPattern"
, "InRhsGuard"
, "InStmt"
, "InValueBind"
]
templateHaskellTest :: TestSuite
templateHaskellTest = (thRoot, thModules)
thRoot = "TemplateHaskellTest"
thModules = [ "Quote"
, "Splice"
]
viewPatternsTest :: TestSuite
viewPatternsTest = (vpRoot, vpModules)
vpRoot = "ViewPatternsTest"
vpModules = [ "InAlt"
, "InExpr"
, "InMatchLhs"
, "InMatchLhsNested"
]
lambdaCaseTest :: TestSuite
lambdaCaseTest = (lcRoot, lcModules)
lcRoot = "LambdaCaseTest"
lcModules = [ "InCaseRhs"
, "InCompStmt"
, "InExpr"
, "InFieldUpdate"
, "InPattern"
, "InRhs"
, "InRhsGuard"
, "InStmt"
, "InTupSecElem"
]
tupleSectionsTest :: TestSuite
tupleSectionsTest = (tsRoot, tsModules)
tsRoot = "TupleSectionsTest"
tsModules = [ "InCaseRhs"
, "InCompStmt"
, "InExpr"
, "InFieldUpdate"
, "InPattern"
, "InRhs"
, "InRhsGuard"
, "InStmt"
, "InTupSecElem"
, "NoTupleSections"
]
magicHashTest :: NestedTestSuite
magicHashTest = (mhRoot, [magicHashLiteralTest, magicHashNameTest])
mhRoot = "MagicHashTest"
magicHashNameTest :: TestSuite
magicHashNameTest = (mhNameRoot, mhNameModules)
mhNameRoot = "Name"
mhNameModules = [ "InAssertion"
, "InClassElement"
, "InDecl"
, "InDeclHead"
, "InExpr"
, "InFieldDecl"
, "InFieldUpdate"
, "InFunDeps"
, "InInstanceHead"
--, "InKind" NO PARSE
, "InMatchLhs"
, "InPatSynLhs"
, "InPattern"
, "InPatternField"
, "InType"
--, "InTypeFamily" NO PARSE
, "InTypeSig"
]
magicHashLiteralTest :: TestSuite
magicHashLiteralTest = (mhLiteralRoot, mhLiteralModules)
mhLiteralRoot = "Literal"
mhLiteralModules = [ "InExpr" ]
functionalDependenciesTest :: TestSuite
functionalDependenciesTest = (fdRoot, fdModules)
fdRoot = "FunctionalDependenciesTest"
fdModules = [ "Basic" ]
defaultSignaturesTest :: TestSuite
defaultSignaturesTest = (dsRoot, dsModules)
dsRoot = "DefaultSignaturesTest"
dsModules = [ "Basic" ]
recursiveDoTest :: TestSuite
recursiveDoTest = (rdRoot, rdModules)
rdRoot = "RecursiveDoTest"
rdModules = [ "MDo"
, "RecStmt"
]
arrowsTest :: TestSuite
arrowsTest = (arrRoot, arrModules)
arrRoot = "ArrowsTest"
arrModules = [ "Basic" ]
parallelListCompTest :: TestSuite
parallelListCompTest = (pcRoot, pcModules)
pcRoot = "ParallelListCompTest"
pcModules = [ "InCaseRhs"
, "InCompStmt"
, "InExpr"
, "InFieldUpdate"
, "InPattern"
, "InRhs"
, "InRhsGuard"
, "InStmt"
, "InTupSecElem"
]
typeFamiliesTest :: TestSuite
typeFamiliesTest = (tfRoot, tfModules)
tfRoot = "TypeFamiliesTest"
tfModules = [ "AssocDataFamily"
, "AssocGDataFamily"
, "AssocTypeFamily"
, "ClosedTypeFamilyDecl"
, "DataFamilyDecl"
, "GDataFamilyDecl"
, "NestedTypeEqualityContextSynonyms"
, "NestedTypeEqualitySynonyms"
, "TypeEqualityContext"
, "TypeEqualityContextSynonyms"
, "TypeEquality"
, "TypeEqualitySynonyms"
, "TypeEqualityInName"
, "TypeFamilyDecl"
]
multiParamTypeClassesTest :: TestSuite
multiParamTypeClassesTest = (mptcRoot, mptcModules)
mptcRoot = "MultiParamTypeClassesTest"
mptcModules = [ "MultipleTyVars"
, "ZeroTyVars"
]
constraintKindsTest :: TestSuite
constraintKindsTest = (ckRoot, ckModules)
ckRoot = "ConstraintKindsTest"
ckModules = [ "ClassConstraints"
, "ComplexConstraints"
, "NotClassConstraints"
]
kindSignaturesTest :: TestSuite
kindSignaturesTest = (ksRoot, ksModules)
ksRoot = "KindSignaturesTest"
ksModules = [ "InClassDecl"
, "InDataDecl"
, "InForAll"
, "InTypeFamily"
, "InTypeSynonym"
]
explicitNamespacesTest :: TestSuite
explicitNamespacesTest = (esRoot, esModules)
esRoot = "ExplicitNamespacesTest"
esModules = [ "Import"
, "Export"
]
overloadedStringsTest :: TestSuite
overloadedStringsTest = (osRoot, osModules)
osRoot = "OverloadedStringsTest"
osModules = [ "Synonym"
, "Newtype"
, "Other"
]
gadtsTest :: TestSuite
gadtsTest = (gadtRoot, gadtModules)
gadtRoot = "GADTsTest"
gadtModules = [ "AssocGDataFamily"
, "GDataFamilyDecl"
, "GDataInstDecl"
, "NormalContext"
, "NormalExistential"
, "NormalOnlySyntax"
, "NormalSpecResultType"
, "RecordContext"
, "RecordExistential"
, "RecordOnlySyntax"
, "RecordSpecResultType"
, "TypeEquality"
, "TypeEqualityWithOnlySyntax"
]
existentialQuantificationTest :: TestSuite
existentialQuantificationTest = (eqRoot, eqModules)
eqRoot = "ExistentialQuantificationTest"
eqModules = [ "WithGADT"
, "WithGADTSyntax"
, "WithoutGADTSyntax"
]
constrainedClassMethodsTest :: TestSuite
constrainedClassMethodsTest = (ccmRoot, ccmModules)
ccmRoot = "ConstrainedClassMethodsTest"
ccmModules = [ "MixedTyVars"
, "NullaryConstraint"
, "OnlyClassTyVars"
]
multiWayIfTest :: TestSuite
multiWayIfTest = (mwiRoot, mwiModules)
mwiRoot = "MultiWayIfTest"
mwiModules = [ "InCaseRhs"
, "InCompStmt"
, "InExpr"
, "InFieldUpdate"
, "InPattern"
, "InRhs"
, "InRhsGuard"
, "InStmt"
, "InTupSecElem"
]
typeOperatorsTest :: TestSuite
typeOperatorsTest = (toRoot, toModules)
toRoot = "TypeOperatorsTest"
toModules = [ "InfixClassDecl"
, "InfixDataDecl"
, "InfixInstance"
, "InfixTypeAnnot"
, "InfixTypeSig"
, "NormalClassDecl"
, "NormalDataDecl"
, "NormalInstance"
]