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 qualified Data.Map.Strict as SMap (Map, map)
import System.FilePath (FilePath, addExtension, (</>))
import ExtensionOrganizerTest.AnnotationParser (getExtensionAnnotations)
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
]
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)
loadModuleAST :: FilePath -> ModuleName -> Ghc TypedModule
loadModuleAST dir moduleName = do
useFlags ["-w"]
modSummary <- loadModule (testRoot </> dir) moduleName
parseTyped modSummary
getExtensionsFrom :: FilePath -> ModuleName -> IO SimpleMap
getExtensionsFrom dir moduleName = runGhc (Just libdir) $ do
modAST <- loadModuleAST dir moduleName
exts <- collectExtensions modAST
return $! simplifyExtMap exts
getExtAnnotsFrom :: FilePath -> ModuleName -> IO SimpleMap
getExtAnnotsFrom dir moduleName = do
s <- readFile $ addExtension (mkModulePath dir moduleName) ".hs"
return $! getExtensionAnnotations s
mkTest :: FilePath -> ModuleName -> TestTree
mkTest dir moduleName = testCase moduleName $ mkAssertion dir moduleName
mkAssertion :: FilePath -> ModuleName -> IO ()
mkAssertion dir moduleName = do
expected <- getExtAnnotsFrom dir moduleName
result <- getExtensionsFrom dir moduleName
assertEqual "Failure" (mapSort expected) (mapSort result)
where mapSort = SMap.map sort
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"
, "NoOccurenceON"
, "NoOccurenceOFF"
, "SameTyVars"
, "TopLevelTyVar"
, "TopLevelWiredInType"
]
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" ]