Test.hs 3.63 KB
Newer Older
1
module Rules.Test (testRules, runTestGhcFlags, timeoutProgPath) where
2 3 4

import Base
import Expression
5 6
import Oracles.Flag
import Oracles.Setting
Andrey Mokhov's avatar
Andrey Mokhov committed
7
import Target
8
import Utilities
9

10 11
import System.Environment

12 13
-- TODO: clean up after testing
testRules :: Rules ()
Andrey Mokhov's avatar
Andrey Mokhov committed
14
testRules = do
15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34

    root <- buildRootRules

    root -/- timeoutPyPath ~> do
        copyFile "testsuite/timeout/timeout.py" (root -/- timeoutPyPath)

    -- TODO windows is still not supported.
    --
    -- See: https://github.com/ghc/ghc/blob/master/testsuite/timeout/Makefile#L23
    root -/- timeoutProgPath ~> do
        python <- builderPath Python
        need [root -/- timeoutPyPath]
        let script = unlines
                [ "#!/usr/bin/env sh"
                , "exec " ++ python ++ " $0.py \"$@\""
                ]
        liftIO $ do
            writeFile (root -/- timeoutProgPath) script
        makeExecutable (root -/- timeoutProgPath)

Andrey Mokhov's avatar
Andrey Mokhov committed
35
    "validate" ~> do
36
        need inplaceLibCopyTargets
37
        needBuilder $ Ghc CompileHs Stage2
Andrey Mokhov's avatar
Andrey Mokhov committed
38
        needBuilder $ GhcPkg Update Stage1
39
        needBuilder Hpc
40 41 42
        -- TODO: Figure out why @needBuilder Hsc2Hs@ doesn't work.
        -- TODO: Eliminate explicit filepaths.
        -- See https://github.com/snowleopard/hadrian/issues/376.
43
        need ["inplace/bin/hp2ps", "inplace/bin/hsc2hs"]
44
        build $ target (vanillaContext Stage2 compiler) (Make "testsuite/tests") [] []
Andrey Mokhov's avatar
Andrey Mokhov committed
45

46
    "test" ~> do
47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105
        -- Prepare the timeout program.
        need [ root -/- timeoutProgPath ]

        -- TODO This approach doesn't work.
        -- Set environment variables for test's Makefile.
        env <- sequence
            [ builderEnvironment "MAKE" $ Make ""
            , builderEnvironment "TEST_HC" $ Ghc CompileHs Stage2
            , AddEnv "TEST_HC_OPTS" <$> runTestGhcFlags ]

        makePath       <- builderPath $ Make ""
        top            <- topDirectory
        ghcPath        <- (top -/-) <$> builderPath (Ghc CompileHs Stage2)
        ghcFlags       <- runTestGhcFlags

        -- Set environment variables for test's Makefile.
        liftIO $ do
            setEnv "MAKE" makePath
            setEnv "TEST_HC" ghcPath
            setEnv "TEST_HC_OPTS" ghcFlags

        -- Execute the test target.
        buildWithCmdOptions env $ target (vanillaContext Stage2 compiler) RunTest [] []

-- | Extra flags to send to the Haskell compiler to run tests.
runTestGhcFlags :: Action String
runTestGhcFlags = do
    unregisterised <- flag GhcUnregisterised

    let ifMinGhcVer ver opt = do v <- ghcCanonVersion
                                 if ver <= v then pure opt
                                             else pure ""

    -- Read extra argument for test from command line, like `-fvectorize`.
    ghcOpts <- fromMaybe "" <$> (liftIO $ lookupEnv "EXTRA_HC_OPTS")

    -- See: https://github.com/ghc/ghc/blob/master/testsuite/mk/test.mk#L28
    let ghcExtraFlags = if unregisterised
                           then "-optc-fno-builtin"
                           else ""

    -- Take flags to send to the Haskell compiler from test.mk.
    -- See: https://github.com/ghc/ghc/blob/master/testsuite/mk/test.mk#L37
    unwords <$> sequence
        [ pure " -dcore-lint -dcmm-lint -no-user-package-db -rtsopts"
        , pure ghcOpts
        , pure ghcExtraFlags
        , ifMinGhcVer "711" "-fno-warn-missed-specialisations"
        , ifMinGhcVer "711" "-fshow-warning-groups"
        , ifMinGhcVer "801" "-fdiagnostics-color=never"
        , ifMinGhcVer "801" "-fno-diagnostics-show-caret"
        , pure "-dno-debug-output"
        ]

timeoutPyPath :: FilePath
timeoutPyPath = "test/bin/timeout.py"

timeoutProgPath :: FilePath
timeoutProgPath = "test/bin/timeout" <.> exe