{-# LANGUAGE TypeFamilies, GeneralizedNewtypeDeriving, DeriveDataTypeable, ScopedTypeVariables #-}

module Test.Errors(main) where

import Development.Shake
import Development.Shake.Classes
import Development.Shake.FilePath
import Test.Type
import Data.List.Extra
import Control.Monad
import Control.Concurrent.Extra
import General.GetOpt
import General.Extra
import Data.IORef
import System.Info
import Data.Version.Extra
import Control.Exception.Extra
import System.Directory as IO
import System.Time.Extra
import qualified System.IO.Extra as IO


data Args = Die deriving (Eq,Enum,Bounded,Show)

newtype BadBinary = BadBinary String deriving (NFData,Show,Eq,Hashable,Typeable)
type instance RuleResult BadBinary = BadBinary
instance Binary BadBinary where
    put (BadBinary x) = put x
    get = do x <- get; if x == "bad" then error "get: BadBinary \"bad\"" else return $ BadBinary x

main = testBuildArgs test optionsEnum $ \args -> do
    "norule" %> \_ ->
        need ["norule_isavailable"]

    "failcreate" %> \_ ->
        return ()

    ["failcreates", "failcreates2"] &%> \_ ->
        writeFile' "failcreates" ""

    "recursive_" %> \_ -> need ["intermediate_"]
    "intermediate_" %> \_ -> need ["recursive_"]

    "rec1" %> \_ -> need ["rec2"]
    "rec2" %> \_ -> need ["rec1"]

    "systemcmd" %> \_ ->
        cmd "random_missing_command"

    "stack1" %> \_ -> need ["stack2"]
    "stack2" %> \_ -> need ["stack3"]
    "stack3" %> \_ -> error "crash"

    "staunch1" %> \out -> do
        liftIO $ sleep 0.1
        writeFile' out "test"
    "staunch2" %> \_ -> error "crash"

    let catcher out op = out %> \out -> do
            writeFile' out "0"
            op $ do src <- IO.readFile' out; writeFile out $ show (read src + 1 :: Int)
    catcher "finally1" $ actionFinally $ fail "die"
    catcher "finally2" $ actionFinally $ return ()
    catcher "finally3" $ actionFinally $ liftIO $ sleep 10
    catcher "finally4" $ actionFinally $ need ["wait"]
    "wait" ~> do liftIO $ sleep 10
    catcher "exception1" $ actionOnException $ fail "die"
    catcher "exception2" $ actionOnException $ return ()

    "retry*" %> \out -> do
        ref <- liftIO $ newIORef 3
        actionRetry (read [last out]) $ liftIO $ do
            old <- readIORef ref
            writeIORef ref $ old - 1
            if old == 0 then writeFile' out "" else fail "die"

    res <- newResource "resource_name" 1
    "resource" %> \_ ->
        withResource res 1 $
            need ["resource-dep"]

    "overlap.txt" %> \out -> writeFile' out "overlap.txt"
    "overlap.t*" %> \out -> writeFile' out "overlap.t*"
    "overlap.*" %> \out -> writeFile' out "overlap.*"
    ["*.txx","*.tox"] &%> \_ -> fail "do not run"
    ["*p.txx"] &%> \_ -> fail "do not run"

    "chain.2" %> \out -> do
        src <- readFile' "chain.1"
        if src == "err" then error "err_chain" else writeFileChanged out src
    "chain.3" %> \out -> copyFile' "chain.2" out

    "tempfile" %> \out -> do
        file <- withTempFile $ \file -> do
            liftIO $ assertExists file
            return file
        liftIO $ assertMissing file
        withTempFile $ \file -> do
            liftIO $ assertExists file
            writeFile' out file
            fail "tempfile-died"

    "tempdir" %> \out -> do
        file <- withTempDir $ \dir -> do
            let file = dir </> "foo.txt"
            liftIO $ writeFile (dir </> "foo.txt") ""
                -- will throw if the directory does not exist
            writeFile' out ""
            return file
        liftIO $ assertMissing file

    phony "fail1" $ fail "die1"
    phony "fail2" $ fail "die2"

    when (Die `elem` args) $ action $ error "death error"

    "fresh_dir" %> \out -> liftIO $ createDirectoryRecursive out
    "need_dir" %> \out -> do
        liftIO $ createDirectoryRecursive "existing_dir"
        need ["existing_dir"]
        writeFile' out ""

    "persist_failure.1" %> \out -> do
        liftIO $ appendFile "persist_failure.log" "[pre]"
        need ["persist_failure.2"]
        liftIO $ appendFile "persist_failure.log" "[post]"
        writeFile' out ""
    "persist_failure.2" %> \out -> do
        src <- readFile' "persist_failure.3"
        liftIO $ print ("persist_failure.3", src)
        if src == "die" then do
            liftIO $ appendFile "persist_failure.log" "[err]"
            fail "die"
        else
            writeFileChanged out src

    "fast_failure" %> \_ -> do
        liftIO $ sleep 0.1
        fail "die"
    "slow_success" %> \out -> do
        liftIO $ sleep 20
        writeFile' out ""

    addOracle $ \(BadBinary x) -> return $ BadBinary $ 'b':x
    "badinput" %> \out -> do
        askOracle $ BadBinary "bad"
        liftIO $ appendFile out "x"
    "badoutput" %> \out -> do
        askOracle $ BadBinary "ad"
        liftIO $ appendFile out "x"
    "badnone" %> \out -> do
        alwaysRerun
        liftIO $ appendFile out "x"

    "produces1" %> \out -> do
        produces [out <.> "also"]
        writeFile' (out <.> "also") ""
        writeFile' out ""
    "produces2" %> \out -> do
        produces [out <.> "also"]
        writeFile' out ""

    "finalfinal" %> \out -> do
        writeFile' out ""
        lock <- liftIO newLock
        let output = withLock lock . appendFile out
        liftIO (sleep 100)
            `actionFinally` (output "X" >> sleep 0.1)
            `actionFinally` output "Y"

    let catching out = flip actionCatch $ \(e :: SomeException) -> writeFile' out $ show e
    "catch1" %> \out -> catching out $ fail "magic1"
    "catch2" %> \out -> catching out $ liftIO $ killThread =<< myThreadId
    "catch3.1" %> \out -> fail "magic3"
    "catch3.2" %> \out -> catching out $ need ["catch3.1"]

    -- not tested by default since only causes an error when idle GC is turned on
    phony "block" $
        liftIO $ putStrLn $ let x = x in x

test build = do
    -- on Windows, file paths may end up with \ separators, make sure we can still match them
    let crash args parts = assertExceptionAfter (replace "\\" "/") parts (build $ "--quiet" : args)
    build ["clean"]

    writeFile "chain.1" "x"
    build ["chain.3","--sleep"]
    writeFile "chain.1" "err"
    crash ["chain.3"] ["err_chain"]

    crash ["norule"] ["norule_isavailable"]
    crash ["failcreate"] ["failcreate"]
    crash ["failcreates"] ["failcreates"]
    crash ["recursive_"] ["recursive_","intermediate_","recursive"]
    crash ["rec1","rec2"] ["rec1","rec2","indirect recursion","recursive"]
    crash ["systemcmd"] ["systemcmd","random_missing_command"]
    crash ["stack1"] ["stack1","stack2","stack3","crash"]

    b <- IO.doesFileExist "staunch1"
    when b $ removeFile "staunch1"
    crash ["staunch1","staunch2","-j2"] ["crash"]
    assertBoolIO (not <$> IO.doesFileExist "staunch1") "File should not exist, should have crashed first"
    crash ["staunch1","staunch2","-j2","--keep-going","--silent"] ["crash"]
    assertBoolIO (IO.doesFileExist "staunch1") "File should exist, staunch should have let it be created"

    crash ["finally1"] ["die"]
    assertContents "finally1" "1"
    build ["finally2"]
    assertContents "finally2" "1"
    crash ["exception1"] ["die"]
    assertContents "exception1" "1"
    build ["exception2"]
    assertContents "exception2" "0"

    crash ["retry0"] ["positive","0"]
    crash ["retry1"] ["die"]
    build ["retry4"]

    forM_ ["finally3","finally4"] $ \name -> do
        t <- forkIO $ ignore $ build [name,"--exception"]
        retry 10 $ sleep 0.1 >> assertContents name "0"
        throwTo t (IndexOutOfBounds "test")
        retry 10 $ sleep 0.1 >> assertContents name "1"

    crash ["resource"] ["cannot currently introduce a dependency","withResource","resource_name"]

    build ["overlap.foo"]
    assertContents "overlap.foo" "overlap.*"
    build ["overlap.txt"]
    assertContents "overlap.txt" "overlap.txt"
    crash ["overlap.txx"] $
        ["key matches multiple rules","matched:  4","overlap.txx","overlap.t*","overlap.*","*.tox"] ++
        ["Test/Errors.hs" | compilerVersion >= readVersion "8.0"] -- when GHC got support for locations

    crash ["tempfile"] ["tempfile-died"]
    src <- readFile "tempfile"
    assertMissing src
    build ["tempdir"]

    crash ["--die"] $ ["Shake","death error"] ++
        ["Test/Errors.hs" | compilerVersion >= readVersion "8.0"] -- when GHC got support for locations

    putStrLn "## BUILD errors"
    (out,_) <- IO.captureOutput $ build []
    assertBool ("nothing to do" `isInfixOf` out) $ "Expected 'nothing to do', but got: " ++ out

    putStrLn "## BUILD errors fail1 fail2 -k -j2"
    (out,_) <- IO.captureOutput $ try_ $ build ["fail1","fail2","-k","-j2",""]
    assertBool ("die1" `isInfixOf` out && "die2" `isInfixOf` out) $ "Expected 'die1' and 'die2', but got: " ++ out

    crash ["fresh_dir"] ["expected a file, got a directory","fresh_dir"]
    crash ["need_dir"] ["expected a file, got a directory","existing_dir"]

    -- check errors don't persist to the database, #428
    writeFile "persist_failure.log" ""
    writeFile "persist_failure.3" "test"
    build ["persist_failure.1","--sleep"]
    writeFile "persist_failure.3" "die"
    crash ["persist_failure.1","--sleep"] []
    assertContents "persist_failure.log" "[pre][post][err][pre]"
    writeFile "persist_failure.3" "test"
    build ["persist_failure.1","--sleep"]
    assertContents "persist_failure.log" "[pre][post][err][pre]"
    writeFile "persist_failure.3" "more"
    build ["persist_failure.1"]
    assertContents "persist_failure.log" "[pre][post][err][pre][pre][post]"

    -- check a fast failure aborts a slow success
    (t, _) <- duration $ crash ["fast_failure","slow_success","-j2"] ["die"]
    assertBool (t < 10) $ "Took too long, expected < 10, got " ++ show t

    -- for exceptions on Key we die while reading the database, and restart from scratch
    build ["badinput"]
    build ["badinput","--silent"]
    assertContents "badinput" "xx"
    build ["badnone","--silent"] -- must be able to still run other rules
    assertContents "badnone" "x"

    -- for exceptions on Value we die while running the rule that requires it
    build ["badoutput"]
    crash ["badoutput"] ["badoutput","BadBinary"]
    build ["badnone"] -- must be able to still run other rules
    assertContents "badnone" "xx"

    -- check that produces works
    build ["produces1"]
    crash ["produces2"] ["produces","produces2.also"]

    -- check finally doesn't run twice, See https://github.com/ndmitchell/shake/issues/611
    t <- forkIO $ build ["finalfinal","--quiet"]
    sleep 0.2
    killThread t
    sleep 0.3
    assertContents "finalfinal" "XY"

    build ["catch1"]
    assertContents "catch1" "magic1"
    crash ["catch2"] [show ThreadKilled]
    crash ["catch3.2"] ["magic3"]