{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, ScopedTypeVariables #-} module Test.Type( sleep, sleepFileTime, sleepFileTimeCalibrate, shakeTest, shakeTest_, root, noTest, hasTracker, copyDirectoryChanged, copyFileChanged, assertWithin, assertBool, assertBoolIO, assertException, assertContents, assertContentsUnordered, assertContentsWords, assertExists, assertMissing, (===), (&?%>), Pat(PatWildcard), pat, BinarySentinel(..), RandomType(..), ) where import Development.Shake hiding (copyFileChanged) 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 import Data.Maybe import Data.Either import Data.Typeable.Extra import qualified Data.ByteString as BS import System.Directory.Extra as IO import System.Environment.Extra import System.Random import General.GetOpt import System.IO.Extra as IO import System.Time.Extra import Prelude shakeTest :: (([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 () shakeTest f opts g = shakenEx False opts f (\os args -> if null args then g os else want args >> withoutActions (g os)) shakeTest_ :: (([String] -> IO ()) -> IO ()) -- ^ The test driver -> Rules () -- ^ The Shake script under test -> IO () -- ^ Sleep function, driven by passing @--sleep@ -> IO () shakeTest_ f g = shakeTest f [] (const g) 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 <- return $ delete "--forward" args cwd <- getCurrentDirectory let out = "output/" ++ name ++ "/" let obj x = if null x then "." else x 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 removeDirectoryRecursive now createDirectoryRecursive now unless reenter $ createDirectoryRecursive out case args of "test":extra -> do putStrLn $ "## TESTING " ++ name -- if the extra arguments are not --quiet/--loud it's probably going to go wrong -- as it is, they do go wrong for random, so disabling for now change $ test (\args -> withArgs (name:args {- ++ extra -}) $ shakenEx True options test rules sleeper) putStrLn $ "## FINISHED TESTING " ++ name "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=Quiet} $ rules [] args args -> do t <- tracker opts <- return $ shakeOptions {shakeFiles = obj "" ,shakeReport = [obj "report.html"]} opts <- return $ if forward then forwardOptions opts else opts {shakeLint = Just t ,shakeLintInside = [cwd] ,shakeLintIgnore = map (cwd ) [".cabal-sandbox//",".stack-work//"]} withArgs args $ do let optionsBuiltin = optionsEnumDesc [(Clean, "Clean before building.") ,(Sleep, "Pause before executing.") ,(UsePredicate, "Use &?> in preference to &%>")] change $ 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 <- return $ if UsePredicate `notElem` extra1 then so else so{shakeExtra = addShakeExtra UsePredicateYes $ shakeExtra so} if "clean" `elem` files then clean >> return Nothing else return $ Just $ (,) so $ do -- if you have passed sleep, supress the "no actions" warning when (Sleep `elem` extra1) $ action $ return () 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 root :: FilePath root = "../.." tracker :: IO Lint tracker = do fsatrace <- findExecutable $ "fsatrace" <.> exe return $ if isJust fsatrace then LintFSATrace else LintBasic hasTracker :: IO Bool hasTracker = do t <- tracker return $ t == LintFSATrace assertBool :: Bool -> String -> IO () assertBool b msg = unless b $ error $ "ASSERTION FAILED: " ++ 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 () -> IO () assertWithin n act = do t <- timeout n act when (isNothing t) $ assertBool False $ "Expected to complete within " ++ show n ++ " seconds, but did not" assertContents :: FilePath -> String -> IO () assertContents file want = do got <- IO.readFile' file assertBool (want == got) $ "File contents are wrong: " ++ file ++ "\nWANT: " ++ 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) assertException :: [String] -> IO () -> IO () assertException parts act = do res <- try_ act case res of Left err -> let s = 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" noTest :: ([String] -> IO ()) -> IO () noTest build = do build ["--abbrev=output=$OUT","-j3"] build ["--no-build","--report=-"] build [] -- | Sleep long enough for the modification time resolution to catch up sleepFileTime :: IO () sleepFileTime = sleep 1 sleepFileTimeCalibrate :: IO (IO ()) sleepFileTimeCalibrate = do let file = "output/calibrate" 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 $ fileNameFromString file t1 <- time flip loopM 0 $ \j -> do writeFile file $ show (i,j) t2 <- time return $ if t1 == t2 then Left $ j+1 else Right () putStrLn $ "Longest file modification time lag was " ++ show (ceiling (maximum' mtimes * 1000)) ++ "ms" return $ 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 return 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 return $ 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 copyFileChanged from to copyFileChanged :: FilePath -> FilePath -> IO () copyFileChanged old new = do good <- IO.doesFileExist new good <- if not good then return False else liftM2 (==) (BS.readFile old) (BS.readFile new) unless good $ 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 x) = put $ show (typeRep (Proxy :: Proxy a)) get = do x <- get let want = show (typeRep (Proxy :: Proxy a)) if x == want then return $ BinarySentinel () else error $ "BinarySentinel failed, got " ++ show x ++ " but wanted " ++ show want newtype RandomType = RandomType (BinarySentinel ()) deriving (Eq,Show,NFData,Typeable,Hashable,Binary)