Type.hs

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

module Test.Type(
    sleep, sleepFileTime, sleepFileTimeCalibrate,
    testBuildArgs, testBuild, testSimple, testNone,
    shakeRoot,
    defaultTest, hasTracker, notCI, notWindowsCI, notMacCI,
    copyDirectoryChanged, copyFileChangedIO,
    assertWithin,
    assertBool, assertBoolIO, assertException, assertExceptionAfter,
    assertContents, assertContentsUnordered, assertContentsWords, assertContentsInfix,
    assertExists, assertMissing,
    assertTimings,
    (===),
    (&?%>),
    Pat(PatWildcard), pat,
    BinarySentinel(..), RandomType(..),
    ) where

import Development.Shake
import Development.Shake.Classes
import Development.Shake.Forward
import Development.Shake.Internal.FileName
import General.Extra
import Development.Shake.Internal.FileInfo
import Development.Shake.FilePath
import Development.Shake.Internal.Paths

import Control.Exception.Extra
import Control.Monad.Extra
import Data.List.Extra
import Text.Read(readMaybe)
import Data.Maybe
import Data.Either
import Data.Typeable
import System.Directory.Extra as IO
import System.Environment
import System.Random
import General.GetOpt
import System.IO.Extra as IO
import System.Time.Extra
import System.Info.Extra


testBuildArgs
    :: (([String] -> IO ()) -> IO ()) -- ^ The test driver
    -> [OptDescr (Either String a)] -- ^ Arguments the test can accept
    -> ([a] -> Rules ()) -- ^ The Shake script under test
    -> IO () -- ^ Sleep function, driven by passing @--sleep@
    -> IO ()
testBuildArgs f opts g = shakenEx False opts f
    (\os args -> if null args then g os else want args >> withoutActions (g os))

testBuild
    :: (([String] -> IO ()) -> IO ()) -- ^ The test driver
    -> Rules () -- ^ The Shake script under test
    -> IO () -- ^ Sleep function, driven by passing @--sleep@
    -> IO ()
testBuild f g = testBuildArgs f [] (const g)

testSimple :: IO () -> IO () -> IO ()
testSimple act = testBuild (const act) (pure ())

testNone :: IO () -> IO ()
testNone _ = pure ()

shakenEx
    :: Bool
    -> [OptDescr (Either String a)]
    -> (([String] -> IO ()) -> IO ())
    -> ([a] -> [String] -> Rules ())
    -> IO ()
    -> IO ()
shakenEx reenter options test rules sleeper = do
    initDataDirectory

    name:args <- getArgs
    putStrLn $ "## BUILD " ++ unwords (name:args)
    let forward = "--forward" `elem` args
    args <- pure $ delete "--forward" args
    let out = "output/" ++ name ++ "/"
    let change = if not reenter then withCurrentDirectory out else id
    let clean = do
            now <- getCurrentDirectory
            when (takeBaseName now /= name) $
                fail $ "Clean went horribly wrong! Dangerous deleting: " ++ show now
            withCurrentDirectory (now </> "..") $ do
                removePathForcibly now
                createDirectoryRecursive now
    unless reenter $ createDirectoryRecursive out
    case args of
        "test":_ -> do
            putStrLn $ "## TESTING " ++ name
            change $ test (\args -> withArgs (name:args) $ shakenEx True options test rules sleeper)
            putStrLn $ "## FINISHED TESTING " ++ name

        "clean":args -> do
            when (args /= []) $ fail "Unexpected additional arguments to 'clean'"
            change clean

        "perturb":args -> forever $ do
            del <- removeFilesRandom out
            threads <- randomRIO (1,4)
            putStrLn $ "## TESTING PERTURBATION (" ++ show del ++ " files, " ++ show threads ++ " threads)"
            shake shakeOptions{shakeFiles=out, shakeThreads=threads, shakeVerbosity=Error} $ rules [] args

        args -> change $ do
            t <- tracker
            opts <- pure shakeOptions{shakeFiles = "."}
            cwd <- getCurrentDirectory
            opts <- pure $ if forward then forwardOptions opts{shakeLintInside=[""]} else opts
                {shakeLint = Just t
                ,shakeLintInside = [cwd </> ".." </> ".."]
                ,shakeLintIgnore = [".cabal-sandbox/**",".stack-work/**","../../.stack-work/**"]}
            withArgs args $ do
                let optionsBuiltin = optionsEnumDesc
                        [(Clean, "Clean before building.")
                        ,(Sleep, "Pause before executing.")
                        ,(UsePredicate, "Use &?> in preference to &%>")]
                shakeArgsOptionsWith opts (optionsBuiltin `mergeOptDescr` options) $ \so extra files -> do
                    let (extra1, extra2) = partitionEithers extra
                    when (Clean `elem` extra1) clean
                    when (Sleep `elem` extra1) sleeper
                    so <- pure $ if UsePredicate `notElem` extra1 then so else
                        so{shakeExtra = addShakeExtra UsePredicateYes $ shakeExtra so}
                    if "clean" `elem` files then
                        clean >> pure Nothing
                    else pure $ Just $ (,) so $ do
                        -- if you have passed sleep, suppress the "no actions" warning
                        when (Sleep `elem` extra1) $ action $ pure ()
                        rules extra2 files

data Flags
    = Clean -- ^ Clean all the files before starting
    | Sleep -- ^ Call 'sleepFileTimeCalibrate' before starting
    | UsePredicate -- ^ Use &?> in preference to &%>
      deriving (Eq,Show)

data UsePredicateYes = UsePredicateYes deriving Typeable

(&?%>) :: [FilePattern] -> ([FilePath] -> Action ()) -> Rules ()
deps &?%> act = do
    so :: Maybe UsePredicateYes <- getShakeExtraRules
    if isJust so
        then (\x -> if x `elem` deps then Just deps else Nothing) &?> act
        else deps &%> act

-- A way to get back to the source files after you get directory changed
shakeRoot :: FilePath
shakeRoot = "../.."

tracker :: IO Lint
tracker = do
    fsatrace <- findExecutable $ "fsatrace" <.> exe
    -- Tracking on a Mac is pretty unreliable
    pure $ if not isMac && isJust fsatrace then LintFSATrace else LintBasic

-- Tests that don't currently work on CI
notCI :: IO () -> IO ()
notCI act = do
    b <- lookupEnv "CI"
    when (isNothing b) act

-- Tests that don't currently work on Windows CI
notWindowsCI :: IO () -> IO ()
notWindowsCI = if isWindows then notCI else id

-- Tests that don't currently work on Mac CI
notMacCI :: IO () -> IO ()
notMacCI = if isMac then notCI else id

hasTracker :: IO Bool
hasTracker = do
    t <- tracker
    pure $ t == LintFSATrace

assertFail :: String -> IO a
assertFail msg = error $ "ASSERTION FAILED: " ++ msg

assertBool :: Bool -> String -> IO ()
assertBool b msg = unless b $ assertFail msg

assertBoolIO :: IO Bool -> String -> IO ()
assertBoolIO b msg = do b <- b; assertBool b msg

infix 4 ===

(===) :: (Show a, Eq a) => a -> a -> IO ()
a === b = assertBool (a == b) $ "failed in ===\nLHS: " ++ show a ++ "\nRHS: " ++ show b


assertExists :: FilePath -> IO ()
assertExists file = do
    b <- IO.doesFileExist file
    assertBool b $ "File was expected to exist, but is missing: " ++ file

assertMissing :: FilePath -> IO ()
assertMissing file = do
    b <- IO.doesFileExist file
    assertBool (not b) $ "File was expected to be missing, but exists: " ++ file

assertWithin :: Seconds -> IO a -> IO a
assertWithin n act = do
    t <- timeout n act
    case t of
        Nothing -> assertFail $ "Expected to complete within " ++ show n ++ " seconds, but did not"
        Just v -> pure v

assertContents :: FilePath -> String -> IO ()
assertContents file want = do
    got <- IO.readFile' file
    assertBool (want == got) $ "File contents are wrong: " ++ file ++ "\nWANT: " ++ want ++ "\nGOT: " ++ got

assertContentsInfix :: FilePath -> String -> IO ()
assertContentsInfix file want = do
    got <- IO.readFile' file
    assertBool (want `isInfixOf` got) $ "File contents are wrong: " ++ file ++ "\nWANT (infix): " ++ want ++ "\nGOT: " ++ got

assertContentsOn :: (String -> String) -> FilePath -> String -> IO ()
assertContentsOn f file want = do
    got <- IO.readFile' file
    assertBool (f want == f got) $ "File contents are wrong: " ++ file ++ "\nWANT: " ++ want ++ "\nGOT: " ++ got ++
                                   "\nWANT (transformed): " ++ f want ++ "\nGOT (transformed): " ++ f got

assertContentsWords :: FilePath -> String -> IO ()
assertContentsWords = assertContentsOn (unwords . words)

assertContentsUnordered :: FilePath -> [String] -> IO ()
assertContentsUnordered file xs = assertContentsOn (unlines . sort . lines) file (unlines xs)

assertExceptionAfter :: (String -> String) -> [String] -> IO a -> IO ()
assertExceptionAfter tweak parts act = do
    res <- try_ act
    case res of
        Left err -> let s = tweak $ show err in forM_ parts $ \p ->
            assertBool (p `isInfixOf` s) $ "Incorrect exception, missing part:\nGOT: " ++ s ++ "\nWANTED: " ++ p
        Right _ -> error $ "Expected an exception containing " ++ show parts ++ ", but succeeded"

assertException :: [String] -> IO a -> IO ()
assertException = assertExceptionAfter id

assertTimings :: ([String] -> IO ()) -> [(String, Seconds)] -> IO ()
assertTimings build expect = do
    build ["--report=report.json","--no-build"]
    src <- IO.readFile' "report.json"
    let f ('[':'\"':xs)
            | (name,_:',':xs) <- break (== '\"') xs
            , num <- takeWhile (`notElem` ",]") xs
            , Just num <- readMaybe num
            = (name, num :: Double)
        f x = error $ "Failed to parse JSON output in assertTimings, " ++ show x
    let got = [f x | x <- map drop1 $ lines src, x /= ""]
    forM_ expect $ \(name, val) ->
        case lookup name got of
            Nothing -> assertFail $ "Couldn't find key " ++ show name ++ " in profiling output"
            Just v -> assertBool (v >= val && v < (val + 1)) $ "Unexpected value, got " ++ show v ++ ", hoping for " ++ show val ++ " (+ 1 sec)"


defaultTest :: ([String] -> IO ()) -> IO ()
defaultTest build = do
    build ["--abbrev=output=$OUT","-j3","--report"]
    build ["--no-build","--report=-"]
    build []


-- | Sleep long enough for the modification time resolution to catch up
sleepFileTime :: IO ()
sleepFileTime = sleep 1


sleepFileTimeCalibrate :: FilePath -> IO (IO ())
sleepFileTimeCalibrate file = do
    createDirectoryRecursive $ takeDirectory file
    -- with 10 measurements can get a bit slow, see #451
    -- if it rounds to a second then 1st will be a fraction, but 2nd will be full second
    mtimes <- forM [1..2] $ \i -> fmap fst $ duration $ do
        writeFile file $ show i
        let time = fmap (fst . fromMaybe (error "File missing during sleepFileTimeCalibrate")) $
                        getFileInfo False $ fileNameFromString file
        t1 <- time
        flip loopM 0 $ \j -> do
            writeFile file $ show (i,j)
            t2 <- time
            pure $ if t1 == t2 then Left $ j+1 else Right ()
    putStrLn $ "Longest file modification time lag was " ++ show (ceiling (maximum' mtimes * 1000)) ++ "ms"
    pure $ sleep $ min 1 $ maximum' mtimes * 2


removeFilesRandom :: FilePath -> IO Int
removeFilesRandom x = do
    files <- getDirectoryContentsRecursive x
    n <- randomRIO (0,length files)
    rs <- replicateM (length files) (randomIO :: IO Double)
    mapM_ (removeFile . snd) $ sort $ zip rs files
    pure n


getDirectoryContentsRecursive :: FilePath -> IO [FilePath]
getDirectoryContentsRecursive dir = do
    xs <- IO.getDirectoryContents dir
    (dirs,files) <- partitionM IO.doesDirectoryExist [dir </> x | x <- xs, not $ "." `isPrefixOf` x]
    rest <- concatMapM getDirectoryContentsRecursive dirs
    pure $ files++rest


copyDirectoryChanged :: FilePath -> FilePath -> IO ()
copyDirectoryChanged old new = do
    xs <- getDirectoryContentsRecursive old
    forM_ xs $ \from -> do
        let to = new </> drop (length $ addTrailingPathSeparator old) from
        createDirectoryRecursive $ takeDirectory to
        copyFileChangedIO from to


copyFileChangedIO :: FilePath -> FilePath -> IO ()
copyFileChangedIO old new =
    unlessM (liftIO $ IO.doesFileExist new &&^ IO.fileEq old new) $
        copyFile old new

-- The operators %> ?> &*> &?> |?> |*> all have an isomorphism
data Pat = PatWildcard | PatPredicate | PatOrWildcard | PatAndWildcard | PatAndPredicate
    deriving (Read, Show, Enum, Bounded)

pat :: Pat -> FilePattern -> (FilePath -> Action ()) -> Rules ()
pat PatWildcard p act = p %> act
pat PatPredicate p act = (p ?==) ?> act
pat PatOrWildcard p act = [p] |%> act
pat PatAndWildcard p act =
    -- single wildcard shortcircuits, so we use multiple to avoid that
    -- and thus have to fake writing an extra file
    [p, p ++ "'"] &%> \[x,x'] -> do act x; writeFile' x' ""
pat PatAndPredicate p act = (\x -> if p ?== x then Just [x] else Nothing) &?> \[x] -> act x


---------------------------------------------------------------------
-- TEST MATERIAL
-- Some errors require multiple modules to replicate (e.g. #506), so put that here

newtype BinarySentinel a = BinarySentinel ()
    deriving (Eq,Show,NFData,Typeable,Hashable)

instance forall a . Typeable a => Binary (BinarySentinel a) where
    put (BinarySentinel ()) = put $ show (typeRep (Proxy :: Proxy a))
    get = do
        x <- get
        let want = show (typeRep (Proxy :: Proxy a))
        if x == want then pure $ BinarySentinel () else
            error $ "BinarySentinel failed, got " ++ show x ++ " but wanted " ++ show want

newtype RandomType = RandomType (BinarySentinel ())
    deriving (Eq,Show,NFData,Typeable,Hashable,Binary)