Ghcid.hs

-- | Test behavior of the executable, polling files for changes
module Test.Ghcid(ghcidTest) where

import Control.Concurrent.Extra
import Control.Exception.Extra
import Control.Monad.Extra
import Data.Char
import Data.List.Extra
import System.Directory.Extra
import System.IO.Extra
import System.Time.Extra
import Data.Version.Extra
import System.Environment
import System.Process.Extra
import System.FilePath
import System.Exit

import Test.Tasty
import Test.Tasty.HUnit

import Ghcid
import Language.Haskell.Ghcid.Util
import Data.Functor
import Prelude


ghcidTest :: TestTree
ghcidTest = testGroup "Ghcid test"
    [basicTest
    ,dotGhciTest
    ,cabalTest
    ,stackTest
    ]


freshDir :: IO a -> IO a
freshDir act = withTempDir $ \tdir -> withCurrentDirectory tdir act

copyDir :: FilePath -> IO a -> IO ()
copyDir dir act = do
    b <- doesDirectoryExist dir
    if not b then putStrLn $ "Couldn't run test because test source is missing, " ++ dir else void $
        withTempDir $ \tdir -> do
            xs <- withCurrentDirectory dir $ listFilesRecursive "."
            forM_ xs $ \x -> do
                createDirectoryIfMissing True $ takeDirectory $ tdir </> x
                copyFile (dir </> x) (tdir </> x)
            withCurrentDirectory tdir act


whenStack :: IO a -> IO ()
whenStack act = do
    v <- findExecutable "stack"
    case v of
        Nothing -> putStrLn "Couldn't run test because stack is missing"
        Just _ -> void act


withGhcid :: [String] -> (([String] -> IO ()) -> IO a) -> IO a
withGhcid args script = do
    chan <- newChan
    let require want = do
            t <- timeout 30 $ readChan chan
            case t of
                Nothing -> fail $ "Require failed to produce results in time, expected: " ++ show want
                Just got -> assertApproxInfix want got
            sleep =<< getModTimeResolution

    let output = writeChan chan . filter (/= "") . map snd
    done <- newBarrier
    res <- bracket
        (flip forkFinally (const $ signalBarrier done ()) $
            withArgs (["--no-title","--no-status"]++args) $
                mainWithTerminal (return (100, 50)) output)
        killThread $ \_ -> script require
    waitBarrier done
    return res


-- | Since different versions of GHCi give different messages, we only try to find what
--   we require anywhere in the obtained messages, ignoring weird characters.
assertApproxInfix :: [String] -> [String] -> IO ()
assertApproxInfix want got = do
    -- Spacing and quotes tend to be different on different GHCi versions
    let simple = lower . filter (\x -> isLetter x || isDigit x || x == ':')
        got2 = simple $ unwords got
    all (`isInfixOf` got2) (map simple want) @?
        "Expected " ++ show want ++ ", got " ++ show got


write :: FilePath -> String -> IO ()
write file x = do
    print ("writeFile",file,x)
    writeFile file x

append :: FilePath -> String -> IO ()
append file x = do
    print ("appendFile",file,x)
    appendFile file x

rename :: FilePath -> FilePath -> IO ()
rename from to = do
    print ("renameFile",from,to)
    renameFile from to



---------------------------------------------------------------------
-- ACTUAL TEST SUITE

basicTest :: TestTree
basicTest = testCase "Ghcid basic" $ freshDir $ do
    write "Main.hs" "main = print 1"
    withGhcid ["-cghci -fwarn-unused-binds Main.hs"] $ \require -> do
        require [allGoodMessage]
        write "Main.hs" "x"
        require ["Main.hs:1:1"," Parse error:"]
        write "Util.hs" "module Util where"
        write "Main.hs" "import Util\nmain = print 1"
        require [allGoodMessage]
        write "Util.hs" "module Util where\nx"
        require ["Util.hs:2:1","Parse error:"]
        write "Util.hs" "module Util() where\nx = 1"
        require ["Util.hs:2:1","Warning:","Defined but not used: `x'"]

        -- check warnings persist properly
        write "Main.hs" "import Util\nx"
        require ["Main.hs:2:1","Parse error:"
                ,"Util.hs:2:1","Warning:","Defined but not used: `x'"]
        write "Main.hs" "import Util\nmain = print 2"
        require ["Util.hs:2:1","Warning:","Defined but not used: `x'"]
        write "Main.hs" "main = print 3"
        require [allGoodMessage]
        write "Main.hs" "import Util\nmain = print 4"
        require ["Util.hs:2:1","Warning:","Defined but not used: `x'"]
        write "Util.hs" "module Util where"
        require [allGoodMessage]

        -- check recursive modules work
        write "Util.hs" "module Util where\nimport Main"
        require ["imports form a cycle","Main.hs","Util.hs"]
        write "Util.hs" "module Util where"
        require [allGoodMessage]

        ghcVer <- readVersion <$> systemOutput_ "ghc --numeric-version"

        -- check renaming files works
        when (ghcVer < makeVersion [8]) $ do
            -- note that due to GHC bug #9648 and #11596 this doesn't work with newer GHC
            -- see https://ghc.haskell.org/trac/ghc/ticket/11596
            rename "Util.hs" "Util2.hs"
            require ["Main.hs:1:8:","Could not find module `Util'"]
            rename "Util2.hs" "Util.hs"
            require [allGoodMessage]

        -- after this point GHC bugs mean nothing really works too much


dotGhciTest :: TestTree
dotGhciTest = testCase "Ghcid .ghci" $ copyDir "test/foo" $ do
    write "test.txt" ""
    ignore $ void $ system "chmod go-w .ghci"
    withGhcid ["--test=:test"] $ \require -> do
        require [allGoodMessage]
        sleep 1 -- time to write out the test
        readFile "test.txt" >>= (@?= "X") -- the test writes out X
        append "Test.hs" "\n"
        require [allGoodMessage]
        sleep 1 -- time to write out the test
        readFile "test.txt" >>= (@?= "XX")
        print =<< readFile ".ghci"
        write ".ghci" ":set -fwarn-unused-imports\n:load Root Paths.hs Test"
        require ["The import of Paths_foo is redundant"]
        sleep 1 -- time to write out the test
        readFile "test.txt" >>= (@?= "XX") -- but shouldn't run on warning


cabalTest :: TestTree
cabalTest = testCase "Ghcid Cabal" $ copyDir "test/bar" $ do
    env <- getEnvironment
    let db = ["--package-db=" ++ x | x <- maybe [] splitSearchPath $ lookup "GHC_PACKAGE_PATH" env]
    (_, _, _, pid) <- createProcess $
         (proc "cabal" $ "configure":db){env = Just $ filter ((/=) "GHC_PACKAGE_PATH" . fst) env}
    ExitSuccess <- waitForProcess pid

    withGhcid [] $ \require -> do
        require [allGoodMessage]
        orig <- readFile' "src/Literate.lhs"
        append "src/Literate.lhs" "> x"
        require ["src/Literate.lhs:5:3","Parse error:"]
        write "src/Literate.lhs" orig
        require [allGoodMessage]

stackTest :: TestTree
stackTest = testCase "Ghcid Stack" $ copyDir "test/bar" $ whenStack $ do
    system_ "stack init"
    createDirectoryIfMissing True ".stack-work"

    withGhcid [] $ \require -> do
        require [allGoodMessage]
        append "src/Literate.lhs" "> x"
        require ["src/Literate.lhs:5:3","Parse error:"]

    withGhcid ["src/Boot.hs"] $ \require -> do
        require [allGoodMessage]
        writeFile "src/Boot.hs" "X"
        require ["src/Boot.hs:1:1","Parse error:"]