Use Reader for tests
diff --git a/test/Test.hs b/test/Test.hs
index d93412c..9ca654c 100644
--- a/test/Test.hs
+++ b/test/Test.hs
@@ -1,6 +1,7 @@
module Main where
import Control.Monad
+import Control.Monad.Reader
import Data.List
import Data.Char
import Data.Maybe
@@ -16,6 +17,14 @@
import Test.QuickCheck.Test
--import Debug.Trace
+data Env = Env { shellMode :: ShellMode
+ , traceMode :: TraceMode
+ , spaceMode :: SpaceMode
+ , tmpDir :: FilePath
+ }
+
+type Prop = Reader Env Property
+
newtype Arg = Arg { unarg :: String } deriving (Show, Eq)
instance Arbitrary Arg where
@@ -37,18 +46,21 @@
isWindows :: Bool
isWindows = os == "mingw32"
-chkargs :: [Arg] -> String -> PropertyM IO ()
-chkargs args out = assert $ args == (Arg <$> read (head $ lines out))
+chkargs :: [Arg] -> IO String -> Property
+chkargs args kout = monadicIO $ do
+ out <- run kout
+ assert $ args == (Arg <$> read (head $ lines out))
prop_rawargs :: [Arg] -> Property
-prop_rawargs args = monadicIO $ run (readProcess "dumpargs" (map unarg args) "") >>= chkargs args
+prop_rawargs args = chkargs args $ readProcess "dumpargs" (map unarg args) ""
prop_args :: [Arg] -> Property
-prop_args args = monadicIO $ run (outputFrom $ fsatrace "x" ++ "dumpargs" : map unarg args) >>= chkargs args
+prop_args args = chkargs args $ outputFrom $ fsatrace "x" ++ "dumpargs" : map unarg args
outputFrom :: [String] -> IO String
outputFrom (cmd:args) = do
- (_,out,_) <- readProcessWithExitCode cmd args ""
+ (_,out,err) <- readProcessWithExitCode cmd args ""
+ when (err /= "") $ putStrLn err
return out
outputFrom _ = undefined
@@ -63,13 +75,17 @@
fsatrace flags = [cd </> ".." </> "fsatrace", flags, "-", "--"]
parsedOutputFrom :: [String] -> IO [Access]
-parsedOutputFrom x = outputFrom x >>= return . filter valid . parse
+parsedOutputFrom x = outputFrom x >>= return . parse
toStandard :: FilePath -> FilePath
toStandard = if isWindows then map (\x -> if x == '\\' then '/' else x) else id
parseDeps :: String -> [FilePath]
-parseDeps = filter (/= "\\") . words . drop 1 . dropWhile (/= ':')
+parseDeps = filter (/= " ") . map unhack . words . hack . drop 1 . dropWhile (/= ':')
+ where hack ('\\':_:xs) = '^':hack xs
+ hack (x:xs) = x:hack xs
+ hack [] = []
+ unhack = map (\x -> if x == '^' then ' ' else x)
parseClDeps :: String -> [FilePath]
parseClDeps = mapMaybe parseLine . lines
@@ -77,72 +93,89 @@
parseLine _ = Nothing
skip c = drop 1 . dropWhile (/= c)
-yields :: [String] -> [Access] -> Property
-yields args res = monadicIO $ do
- r <- run $ parsedOutputFrom args
- let sr = nub $ sort r
- ok = sr == res
- unless ok $ do
- run $ putStrLn $ "Expecting " ++ show res
- run $ putStrLn $ "Got " ++ show sr
- assert ok
+yields :: Reader Env [String] -> Reader Env [Access] -> Prop
+yields eargs eres = do
+ e <- ask
+ return $ monadicIO $ do
+ let args = runReader eargs e
+ res = runReader eres e
+ r <- run $ parsedOutputFrom args
+ let sr = nub $ sort $ filter (valid $ tmpDir e) r
+ ok = sr == res
+ unless ok $ run $ do
+ putStrLn $ "Expecting " ++ show res
+ putStrLn $ "Got " ++ show sr
+ assert ok
-data ShellMode = Unshelled | Shelled deriving (Show, Enum, Bounded)
-data TraceMode = Untraced | Traced deriving (Show, Enum, Bounded)
-data SpaceMode = Unspaced | Spaced deriving (Show, Enum, Bounded)
+data ShellMode = Unshelled | Shelled deriving (Show, Eq, Enum, Bounded)
+data TraceMode = Untraced | Traced deriving (Show, Eq, Enum, Bounded)
+data SpaceMode = Unspaced | Spaced deriving (Show, Eq, Enum, Bounded)
-cp :: ShellMode -> String
-cp Shelled | isWindows = "copy"
-cp _ = "cp"
-
-rm :: ShellMode -> String
-rm Shelled | isWindows = "del"
-rm _ = "rm"
+isShelled :: Reader Env Bool
+isShelled = do
+ sm <- ask
+ return $ shellMode sm == Shelled
quoted :: String -> String
quoted x = "\"" ++ x ++ "\""
+command :: String -> [String] -> Reader Env [String]
+command flags args = do
+ e <- ask
+ return $ cmd (shellMode e) (traceMode e)
+ where cmd :: ShellMode -> TraceMode -> [String]
+ cmd sm Traced = fsatrace flags ++ cmd sm Untraced
+ cmd Unshelled _ = args
+ cmd Shelled _ | isWindows = "cmd.exe" : "/c" : args
+ | otherwise = ["sh", "-c", unwords (map quoted args)]
-command :: ShellMode -> TraceMode -> String -> [String] -> [String]
-command sm Traced flags args = fsatrace flags ++ command sm Untraced flags args
-command Unshelled _ _ args = args
-command Shelled _ _ args | isWindows = "cmd.exe" : "/c" : args
- | otherwise = ["sh", "-c", unwords (map quoted args)]
+whenTracing :: [a] -> Reader Env [a]
+whenTracing x = do
+ e <- ask
+ return $ if traceMode e == Traced then x else []
-whenTracing :: TraceMode -> [a] -> [a]
-whenTracing Traced x = x
-whenTracing _ _ = []
+prop_echo :: Path -> Prop
+prop_echo src = command "rwmd" ["echo", unpath src] `yields` return []
-prop_echo :: ShellMode -> TraceMode -> Path -> Property
-prop_echo sm tm src = command sm tm "rwmd" ["echo", unpath src] `yields` []
+prop_cp :: Path -> Path -> Prop
+prop_cp src dst = do
+ cmd <- cp
+ command "rwmd" [cmd, unpath src, unpath dst] `yields` whenTracing [R src, W dst]
+ where cp :: Reader Env String
+ cp = do
+ s <- isShelled
+ return $ if isWindows && s then "copy" else "cp"
-prop_cp :: ShellMode -> TraceMode -> Path -> Path -> Property
-prop_cp sm tm src dst = command sm tm "rwmd" [cp sm, unpath src, unpath dst] `yields` whenTracing tm [R src, W dst]
+prop_mv :: Path -> Path -> Prop
+prop_mv src dst = command "rwmd" ["mv", unpath src, unpath dst] `yields` whenTracing [M dst src]
-prop_mv :: ShellMode -> TraceMode -> Path -> Path -> Property
-prop_mv sm tm src dst = command sm tm "rwmd" ["mv", unpath src, unpath dst] `yields` whenTracing tm [M dst src]
+prop_touch :: Path -> Prop
+prop_touch dst = command "t" ["touch", unpath dst] `yields` whenTracing [T dst]
-prop_touch :: ShellMode -> TraceMode -> Path -> Property
-prop_touch sm tm dst = command sm tm "t" ["touch", unpath dst] `yields` whenTracing tm [T dst]
+prop_rm :: Path -> Prop
+prop_rm dst = do
+ cmd <- rm
+ command "rwmd" [cmd, unpath dst] `yields` whenTracing [D dst]
+ where rm :: Reader Env String
+ rm = do
+ s <- isShelled
+ return $ if isWindows && s then "del" else "rm"
-prop_rm :: ShellMode -> TraceMode -> Path -> Property
-prop_rm sm tm dst = command sm tm "rwmd" [rm sm, unpath dst] `yields` whenTracing tm [D dst]
+prop_gcc :: Path -> [Access] -> Prop
+prop_gcc src deps = command "r" ["gcc", "-E", unpath src] `yields` whenTracing deps
-prop_gcc :: ShellMode -> TraceMode -> Path -> [Access] -> Property
-prop_gcc sm tm src deps = command sm tm "r" ["gcc", "-E", unpath src] `yields` whenTracing tm deps
-
-prop_cl :: ShellMode -> TraceMode -> Path -> [Access] -> Property
-prop_cl sm tm src deps = command sm tm "r" ["cl", "/nologo", "/E", unpath src] `yields` whenTracing tm deps
+prop_cl :: Path -> [Access] -> Prop
+prop_cl src deps = command "r" ["cl", "/nologo", "/E", unpath src] `yields` whenTracing deps
shelled :: [String] -> [String]
shelled args | isWindows = "cmd.exe" : "/c" : args
| otherwise = ["sh", "-c", unwords args]
main :: IO ()
-main = sequence [allTests sp sm tm | sp <- allValues, sm <- allValues, tm <- allValues]
+main = do
+ sequence [allTests sp sm tm | sp <- allValues, sm <- allValues, tm <- allValues]
>>= mapM_ (mapM_ chk)
- where qc n s p = noisy s >> quickCheckWithResult stdArgs {maxSuccess=n} p
- chk x = unless (isSuccess x) exitFailure
+ where chk x = unless (isSuccess x) exitFailure
noisy s = putStrLn ("Testing " ++ s)
banner x = putStrLn $ "================ " ++ x ++ " ================"
dirname Unspaced = "fsatrace"
@@ -150,31 +183,35 @@
allValues :: (Enum a, Bounded a) => [a]
allValues = enumFrom minBound
allTests :: SpaceMode -> ShellMode -> TraceMode -> IO [Result]
- allTests sp sm tm = withSystemTempDirectory (dirname sp) $ \tmp -> do
+ allTests sp sm tm = withSystemTempDirectory (dirname sp) $ \utmp -> do
+ t <- canonicalizePath utmp
banner $ show sp ++ " " ++ show sm ++ " " ++ show tm
- lic <- canonicalizePath $ ".." </> "LICENSE"
- ctmp <- canonicalizePath tmp
- csrc <- canonicalizePath $ ".." </> "src" </> "emit.c"
- deps <- outputFrom ["gcc", "-MM", csrc]
- ndeps <- mapM canonicalizePath (parseDeps deps)
- cl <- findExecutable "cl"
+ src <- canonicalizePath $ ".." </> "src"
+ cl <- findExecutable "cl.exe"
let hascl = isJust cl
- clcsrc <- if hascl then canonicalizePath $ ".." </> "src" </> "win" </> "handle.c" else return ""
- cldeps <- if hascl then errorFrom ["cl", "/nologo", "/showIncludes", "/E", "/DPATH_MAX=4096", clcsrc] else return []
- ncldeps <- mapM canonicalizePath (clcsrc : parseClDeps cldeps)
- let tls = Path $ ctmp </> "LICENSE"
- tfoo = Path $ ctmp </> "foo"
- rvalid = sort . filter valid . map (R . Path)
+ tsrc = t </> "src"
+ emitc = Path $ tsrc </> "emit.c"
+ srcc = Path $ tsrc </> "src.c"
+ clcsrc = Path $ tsrc </> "win" </> "handle.c"
+ rvalid = sort . filter (valid t) . map (R . Path)
+ e = Env {shellMode = sm, traceMode = tm, spaceMode = sp, tmpDir = t}
+ qc1 s p = noisy s >> quickCheckWithResult (stdArgs {maxSuccess=1}) (runReader p e)
+ qc n s p = noisy s >> quickCheckWithResult (stdArgs {maxSuccess=n}) p
+ _ <- outputFrom ["cp", "-R", src, tsrc]
+ deps <- outputFrom ["gcc", "-MM", unpath emitc]
+ ndeps <- mapM canonicalizePath (parseDeps deps)
+ cldeps <- if hascl then errorFrom ["cl", "/nologo", "/showIncludes", "/E", "/DPATH_MAX=4096", unpath clcsrc] else return []
+ ncldeps <- if hascl then mapM canonicalizePath (unpath clcsrc : parseClDeps cldeps) else return []
sequence $
[ qc 10 "rawargs" prop_rawargs
, qc 10 "args" prop_args
- , qc 1 "echo" $ prop_echo sm tm tls
- , qc 1 "cp" $ prop_cp sm tm (Path lic) tls
- , qc 1 "mv" $ prop_mv sm tm tls tfoo
- , qc 1 "touch" $ prop_touch sm tm tfoo
- , qc 1 "rm" $ prop_rm sm tm tfoo
- , qc 1 "gcc" $ prop_gcc sm tm (Path csrc) (rvalid ndeps)
- ] ++ if hascl then [ qc 1 "cl" $ prop_cl sm tm (Path clcsrc) (rvalid ncldeps) ] else []
+ , qc1 "echo" $ prop_echo emitc
+ , qc1 "cp" $ prop_cp emitc srcc
+ , qc1 "touch" $ prop_touch srcc
+ , qc1 "gcc" $ prop_gcc emitc (rvalid ndeps)
+ , qc1 "mv" $ prop_mv emitc srcc
+ , qc1 "rm" $ prop_rm srcc
+ ] ++ if hascl then [ qc1 "cl" $ prop_cl clcsrc (rvalid ncldeps) ] else []
data Access = R Path
| W Path
@@ -206,18 +243,18 @@
f ('M':'|':xs) | (xs','|':ys) <- break (== '|') xs = Just $ RM (Path xs') (Path ys)
f _ = Nothing
-valid :: Access -> Bool
-valid (R p) = inParent p
-valid (Q p) = inParent p
-valid (W p) = not $ "/dev/" `isPrefixOf` (unpath p)
-valid _ = True
-
-inParent :: Path -> Bool
-inParent = isPrefixOf (takeDirectory $ cased cd) . cased . unpath
-
cased :: String -> String
cased | isWindows = map toLower
| otherwise = id
cd :: FilePath
-cd = unsafePerformIO $ (getCurrentDirectory >>= canonicalizePath)
+cd = unsafePerformIO (getCurrentDirectory >>= canonicalizePath)
+
+valid :: FilePath -> Access -> Bool
+valid t (R p) = inTmp t p
+valid t (Q p) = inTmp t p
+valid _ (W p) = not $ "/dev/" `isPrefixOf` (unpath p)
+valid _ _ = True
+
+inTmp :: FilePath -> Path -> Bool
+inTmp t = isPrefixOf (cased t) . cased . unpath
diff --git a/test/fsatracetest.cabal b/test/fsatracetest.cabal
index d2ec9a4..df543f0 100644
--- a/test/fsatracetest.cabal
+++ b/test/fsatracetest.cabal
@@ -21,5 +21,6 @@
, directory
, temporary
, process
+ , mtl
hs-source-dirs: .
default-language: Haskell2010
