backstop-1.3.0.354: tests/RunTests.hs
module Main(main) where
import Control.Monad (unless)
import Data.List (sort,nub,intersect)
import System.Exit (exitWith,ExitCode(..))
import System.IO (hPutStrLn,hFlush,stdout,stderr)
import System.FilePath ((</>),pathSeparator,isAbsolute,isRelative,joinPath)
import System.Process (runCommand,waitForProcess)
import Test.HUnit hiding (Testable)
import Test.QuickCheck (Testable(..),Property(..),(==>),Result(..),quickCheckResult)
import Utils (putOrPageStrLn,anObject,aSymbolicLink,aDirectory,subdirectories
,subdirectory,root,reduceFilePath,compElems,pairs,unpairs,dot,dotdot
,relativeLink,absoluteLink)
-- Section 0 ------------------------------------------------------------------------
main :: IO ()
main = do putMessage "Unit test reduceFilePath:"
runTestTT checks4reduceFilePath >>= checkCounts
putMessage "Property test reduceFilePath:"
mapM_ runTest props4reduceFilePath
mapM_ runTest props4reduceFilePath_
putMessage "Unit test absoluteLink:"
runTestTT checks4absoluteLink >>= checkCounts
putMessage "Property test absoluteLink:"
mapM_ runTest props4absoluteLink
putMessage "Unit test relativeLink:"
runTestTT checks4relativeLink >>= checkCounts
putMessage "Property test relativeLink:"
mapM_ runTest props4relativeLink
putMessage "Unit test pairs:"
runTestTT checks4pairs >>= checkCounts
putMessage "Unit test unpairs . pairs == id:"
runTestTT checks4unpairsPairs >>= checkCounts
putMessage "Property test unpairs . pairs == id:"
mapM_ runTest props4unpairsPairs
putMessage "Unit test compElems:"
runTestTT check4compElems >>= checkCounts
putMessage "Property test compElems:"
mapM_ runTest props4check4compElems
putMessage "Unit test subdirectory:"
runTestTT checks4subdirectory >>= checkCounts
putMessage "Unit test subdirectories:"
runTestTT checks4subdirectories >>= checkCounts
putMessage "Property test subdirectory and subdirectories:"
mapM_ runTest props4Subdirectories
putMessage "Unit test aDirectory:"
runTestTT checks4aDirectory >>= checkCounts
putMessage "Unit test aSymbolicLink:"
runTestTT checks4aSymbolicLink >>= checkCounts
putMessage "Unit test anObject:"
runTestTT checks4anObject >>= checkCounts
putMessage "Unit test putOrPageStrLn:"
runTestTT checks4putOrPageStrLn >>= checkCounts
putMessage "Running black box tests:"
runTests >>= exitWith
checkCounts :: Counts -> IO ()
checkCounts cnts = let errs = errors cnts + failures cnts
in if errs > 0
then exitWith $ ExitFailure (if errs < 256 then errs else 255)
else putStrLn ""
runTest :: Testable t => (String, t) -> IO ()
runTest (s, t) = do putStrLn s
verify t
putStrLn ""
putMessage :: String -> IO ()
putMessage s = let l = length s
in do putStrLn s
(putStrLn . replicate l) '='
hFlush stdout
-- Section 1 ------------------------------------------------------------------------
checks4reduceFilePath :: Test
checks4reduceFilePath =
let checkReduceFilePath p1 p2
= TestCase (assertEqual "reduceFilePath" p2 (reduceFilePath p1))
in TestList
[
-- The special case of null arguments
checkReduceFilePath "" "."
-- The special case of dot
, checkReduceFilePath "." "."
-- The special case of double dot
, checkReduceFilePath ".." ".."
-- Only slashes
, checkReduceFilePath "/" "/"
, checkReduceFilePath "//" "/"
, checkReduceFilePath "///" "/"
-- Only dots and slashes
, checkReduceFilePath "./" "."
, checkReduceFilePath ".//" "."
, checkReduceFilePath ".///" "."
, checkReduceFilePath "./." "."
, checkReduceFilePath ".//." "."
, checkReduceFilePath ".///." "."
, checkReduceFilePath "././" "."
, checkReduceFilePath ".//./././///." "."
, checkReduceFilePath "././././././././" "."
-- Only slashes and dots
, checkReduceFilePath "/." "/"
, checkReduceFilePath "//." "/"
, checkReduceFilePath "/./" "/"
, checkReduceFilePath "///.///" "/"
, checkReduceFilePath "/./././." "/"
, checkReduceFilePath "//.//.//.//." "/"
-- Only slashes and double dots
, checkReduceFilePath "/.." "/"
, checkReduceFilePath "/../" "/"
, checkReduceFilePath "///..///" "/"
, checkReduceFilePath "/../../../../" "/"
-- Only double dots and slashes
, checkReduceFilePath "../" ".."
, checkReduceFilePath "..///" ".."
, checkReduceFilePath "..///.." "../.."
, checkReduceFilePath "../../../../" "../../../.."
, checkReduceFilePath "..///..///..///..///" "../../../.."
-- Absolute paths with only slahses
, checkReduceFilePath "/a" "/a"
, checkReduceFilePath "/a/b" "/a/b"
, checkReduceFilePath "//a" "/a"
, checkReduceFilePath "//a//b" "/a/b"
, checkReduceFilePath "//a///" "/a"
, checkReduceFilePath "//a//b///" "/a/b"
-- Relative paths with only slahses
, checkReduceFilePath "a" "a"
, checkReduceFilePath "a/b" "a/b"
, checkReduceFilePath "a" "a"
, checkReduceFilePath "a//b" "a/b"
, checkReduceFilePath "a///" "a"
, checkReduceFilePath "a//b///" "a/b"
-- Absolute paths with dots
, checkReduceFilePath "/a/." "/a"
, checkReduceFilePath "/a/./." "/a"
, checkReduceFilePath "/./a" "/a"
, checkReduceFilePath "/./a/./." "/a"
-- Relative paths with dots
, checkReduceFilePath "a/." "a"
, checkReduceFilePath "a/./." "a"
, checkReduceFilePath "./a" "a"
, checkReduceFilePath "./a/./." "a"
-- Absolute paths with double dots
, checkReduceFilePath "/.." "/"
, checkReduceFilePath "/a/.." "/"
, checkReduceFilePath "/a/b/.." "/a"
, checkReduceFilePath "/a/b/c/.." "/a/b"
, checkReduceFilePath "/a/../b" "/b"
, checkReduceFilePath "/a/b/../c" "/a/c"
, checkReduceFilePath "/a/b/c/../.." "/a"
, checkReduceFilePath "/a/b/c/../../.." "/"
, checkReduceFilePath "/a/b/c/../../../.." "/"
, checkReduceFilePath "/a/b/c/../x/y/../z" "/a/b/x/z"
-- Relative paths with double dots
, checkReduceFilePath "a/.." "."
, checkReduceFilePath "a/b/.." "a"
, checkReduceFilePath "a/b/c/.." "a/b"
, checkReduceFilePath "a/../b" "b"
, checkReduceFilePath "a/b/../c" "a/c"
, checkReduceFilePath "a/b/c/../.." "a"
, checkReduceFilePath "a/b/c/../../.." "."
, checkReduceFilePath "a/b/c/../../../.." ".."
, checkReduceFilePath "a/b/c/../../../../.." "../.."
, checkReduceFilePath "a/b/c/../x/y/../z" "a/b/x/z"
-- General abosulte paths
, checkReduceFilePath "/a/b/./x/y/z/../." "/a/b/x/y"
, checkReduceFilePath "/./a/.." "/"
, checkReduceFilePath "/a/./b/c/../x/y/./.." "/a/b/x"
, checkReduceFilePath "/a/b/c/d/e/f/g/h/../../../../../e/f/g/h/i" "/a/b/c/e/f/g/h/i"
-- General reltative paths
, checkReduceFilePath "a/b/./x/y/z/../." "a/b/x/y"
, checkReduceFilePath "./a/.." "."
, checkReduceFilePath "a/./b/c/../x/y/./.." "a/b/x"
, checkReduceFilePath "./../../../a/b/c/./x/y/z" "../../../a/b/c/x/y/z"
, checkReduceFilePath "a/b/c/d/e/f/g/h/../../../../../e/f/g/h/i" "a/b/c/e/f/g/h/i"
]
-- Section 2 ------------------------------------------------------------------------
props4reduceFilePath :: [(String, FilePath -> Property)]
props4reduceFilePath = [ ("propReduceFilePathIdempotent", propReduceFilePathIdempotent)
, ("propReduceFilePathStaysAbsolute", propReduceFilePathStaysAbsolute)
, ("propReduceFilePathStaysRelative", propReduceFilePathStaysRelative)
]
props4reduceFilePath_ :: [(String, FilePath -> FilePath -> Property)]
props4reduceFilePath_ = [ ("propReduceFilePathAssociativity", propReduceFilePathAssociativity)
]
propReduceFilePathIdempotent :: FilePath -> Property
propReduceFilePathIdempotent p =
property $ (reduceFilePath . reduceFilePath) p == reduceFilePath p
propReduceFilePathStaysAbsolute :: FilePath -> Property
propReduceFilePathStaysAbsolute p =
let p' = root </> p
in property $ (isAbsolute . reduceFilePath) p' == isAbsolute p'
propReduceFilePathStaysRelative :: FilePath -> Property
propReduceFilePathStaysRelative p =
(not (null p) && (head p /= pathSeparator)) ==>
(isRelative . reduceFilePath) p == isRelative p
propReduceFilePathAssociativity :: FilePath -> FilePath -> Property
propReduceFilePathAssociativity p1 p2 =
property (reduceFilePath (p1 </> p2) == reduceFilePath (reduceFilePath p1 </> reduceFilePath p2))
-- Section 3 ------------------------------------------------------------------------
checks4absoluteLink :: Test
checks4absoluteLink =
let
checkAbsoluteLink wd p1 p2 p =
TestCase (assertEqual "absoluteLink" p (absoluteLink wd p1 p2))
in TestList
[ checkAbsoluteLink "" "" "" root
, checkAbsoluteLink "" "" "." root
, checkAbsoluteLink "" "" ".." root
, checkAbsoluteLink "" "X" "" root
, checkAbsoluteLink "" "X" "." root
, checkAbsoluteLink "" "X" ".." root
, checkAbsoluteLink root "" "" root
, checkAbsoluteLink root "" "." root
, checkAbsoluteLink root "" ".." root
, checkAbsoluteLink root "X" "" root
, checkAbsoluteLink root "X" "." root
, checkAbsoluteLink root "X" ".." root
, checkAbsoluteLink "/xx/yy/zz" "" "" "/xx/yy/zz"
, checkAbsoluteLink "/xx/yy/zz" "" "." "/xx/yy/zz"
, checkAbsoluteLink "/xx/yy/zz" "" ".." "/xx/yy"
, checkAbsoluteLink "/xx/yy/zz" "X" "" "/xx/yy/zz"
, checkAbsoluteLink "/xx/yy/zz" "X" "." "/xx/yy/zz"
, checkAbsoluteLink "/xx/yy/zz" "X" ".." "/xx/yy"
, checkAbsoluteLink "xx/yy/zz" "" "" "/xx/yy/zz"
, checkAbsoluteLink "xx/yy/zz" "" "." "/xx/yy/zz"
, checkAbsoluteLink "xx/yy/zz" "" ".." "/xx/yy"
, checkAbsoluteLink "xx/yy/zz" "X" "" "/xx/yy/zz"
, checkAbsoluteLink "xx/yy/zz" "X" "." "/xx/yy/zz"
, checkAbsoluteLink "xx/yy/zz" "X" ".." "/xx/yy"
, checkAbsoluteLink "" "" "aa/bb/cc" "/aa/bb/cc"
, checkAbsoluteLink "" "" "aa/bb/cc/." "/aa/bb/cc"
, checkAbsoluteLink "" "" "aa/bb/cc/.." "/aa/bb"
, checkAbsoluteLink "" "X" "aa/bb/cc/" "/aa/bb/cc"
, checkAbsoluteLink "" "X" "aa/bb/cc/." "/aa/bb/cc"
, checkAbsoluteLink "" "X" "aa/bb/cc/.." "/aa/bb"
, checkAbsoluteLink root "" "aa/bb/cc/" "/aa/bb/cc"
, checkAbsoluteLink root "" "aa/bb/cc/." "/aa/bb/cc"
, checkAbsoluteLink root "" "aa/bb/cc/.." "/aa/bb"
, checkAbsoluteLink root "X" "aa/bb/cc/" "/aa/bb/cc"
, checkAbsoluteLink root "X" "aa/bb/cc/." "/aa/bb/cc"
, checkAbsoluteLink root "X" "aa/bb/cc/.." "/aa/bb"
, checkAbsoluteLink "/xx/yy/zz" "" "aa/bb/cc/" "/xx/yy/zz/aa/bb/cc"
, checkAbsoluteLink "/xx/yy/zz" "" "aa/bb/cc/." "/xx/yy/zz/aa/bb/cc"
, checkAbsoluteLink "/xx/yy/zz" "" "aa/bb/cc/.." "/xx/yy/zz/aa/bb"
, checkAbsoluteLink "/xx/yy/zz" "X" "aa/bb/cc/" "/xx/yy/zz/aa/bb/cc"
, checkAbsoluteLink "/xx/yy/zz" "X" "aa/bb/cc/." "/xx/yy/zz/aa/bb/cc"
, checkAbsoluteLink "/xx/yy/zz" "X" "aa/bb/cc/.." "/xx/yy/zz/aa/bb"
, checkAbsoluteLink "xx/yy/zz" "" "aa/bb/cc/" "/xx/yy/zz/aa/bb/cc"
, checkAbsoluteLink "xx/yy/zz" "" "aa/bb/cc/." "/xx/yy/zz/aa/bb/cc"
, checkAbsoluteLink "xx/yy/zz" "" "aa/bb/cc/.." "/xx/yy/zz/aa/bb"
, checkAbsoluteLink "xx/yy/zz" "X" "aa/bb/cc/" "/xx/yy/zz/aa/bb/cc"
, checkAbsoluteLink "xx/yy/zz" "X" "aa/bb/cc/." "/xx/yy/zz/aa/bb/cc"
, checkAbsoluteLink "xx/yy/zz" "X" "aa/bb/cc/.." "/xx/yy/zz/aa/bb"
]
-- Section 4 ------------------------------------------------------------------------
wd :: FilePath
wd = joinPath $ map show [0..9]
props4absoluteLink :: [(String, FilePath -> FilePath -> Property)]
props4absoluteLink = [ ("propAbsoluteLinkIdempotent root", propAbsoluteLinkIdempotent root)
, ("propAbsoluteLinkIdempotent wd", propAbsoluteLinkIdempotent wd)
, ("propAbsoluteLinkStaysAbsolute root", propAbsoluteLinkStaysAbsolute root)
, ("propAbsoluteLinkStaysAbsolute wd", propAbsoluteLinkStaysAbsolute wd)
, ("propAbsoluteLinkIsNotRelative root", propAbsoluteLinkIsNotRelative root)
, ("propAbsoluteLinkIsNotRelative wd", propAbsoluteLinkIsNotRelative wd)
]
propAbsoluteLinkIdempotent :: FilePath -> FilePath -> FilePath -> Property
propAbsoluteLinkIdempotent wd p1 p2 =
property $ (absoluteLink wd p1 . absoluteLink wd p1) p2 == absoluteLink wd p1 p2
propAbsoluteLinkStaysAbsolute :: FilePath -> FilePath -> FilePath -> Property
propAbsoluteLinkStaysAbsolute wd p1 =
property . isAbsolute . absoluteLink wd p1
propAbsoluteLinkIsNotRelative :: FilePath -> FilePath -> FilePath -> Property
propAbsoluteLinkIsNotRelative wd p1 =
property . not. isRelative . absoluteLink wd p1
-- Section 5 ------------------------------------------------------------------------
checks4relativeLink :: Test
checks4relativeLink =
let
checkRelativeLink wd p1 p2 p =
TestCase (assertEqual "relativeLink" p (relativeLink wd p1 p2))
in TestList
[ checkRelativeLink "" "" "" dot
, checkRelativeLink "" "" "." dot
, checkRelativeLink "" "" ".." dot
, checkRelativeLink "" "X" "" dot
, checkRelativeLink "" "X" "." dot
, checkRelativeLink "" "X" ".." dot
, checkRelativeLink root "" "" dot
, checkRelativeLink root "" "." dot
, checkRelativeLink root "" ".." dot
, checkRelativeLink root "X" "" dot
, checkRelativeLink root "X" "." dot
, checkRelativeLink root "X" ".." dot
, checkRelativeLink "/xx/yy/zz" "" "" dot
, checkRelativeLink "/xx/yy/zz" "" "." dot
, checkRelativeLink "/xx/yy/zz" "" ".." dot
, checkRelativeLink "/xx/yy/zz" "X" "" dot
, checkRelativeLink "/xx/yy/zz" "X" "." dot
, checkRelativeLink "/xx/yy/zz" "X" ".." dotdot
, checkRelativeLink "xx/yy/zz" "" "" dot
, checkRelativeLink "xx/yy/zz" "" "." dot
, checkRelativeLink "xx/yy/zz" "" ".." dot
, checkRelativeLink "xx/yy/zz" "X" "" dot
, checkRelativeLink "xx/yy/zz" "X" "." dot
, checkRelativeLink "xx/yy/zz" "X" ".." dotdot
, checkRelativeLink "" "" "aa/bb/cc" "aa/bb/cc"
, checkRelativeLink "" "" "aa/bb/cc/." "aa/bb/cc"
, checkRelativeLink "" "" "aa/bb/cc/.." "aa/bb"
, checkRelativeLink "" "X" "aa/bb/cc/" "aa/bb/cc"
, checkRelativeLink "" "X" "aa/bb/cc/." "aa/bb/cc"
, checkRelativeLink "" "X" "aa/bb/cc/.." "aa/bb"
, checkRelativeLink root "" "aa/bb/cc/" "aa/bb/cc"
, checkRelativeLink root "" "aa/bb/cc/." "aa/bb/cc"
, checkRelativeLink root "" "aa/bb/cc/.." "aa/bb"
, checkRelativeLink root "X" "aa/bb/cc/" "aa/bb/cc"
, checkRelativeLink root "X" "aa/bb/cc/." "aa/bb/cc"
, checkRelativeLink root "X" "aa/bb/cc/.." "aa/bb"
, checkRelativeLink "/xx/yy/zz" "" "aa/bb/cc/" "aa/bb/cc"
, checkRelativeLink "/xx/yy/zz" "" "aa/bb/cc/." "aa/bb/cc"
, checkRelativeLink "/xx/yy/zz" "" "aa/bb/cc/.." "aa/bb"
, checkRelativeLink "/xx/yy/zz" "X" "aa/bb/cc/" "aa/bb/cc"
, checkRelativeLink "/xx/yy/zz" "X" "aa/bb/cc/." "aa/bb/cc"
, checkRelativeLink "/xx/yy/zz" "X" "aa/bb/cc/.." "aa/bb"
, checkRelativeLink "xx/yy/zz" "" "aa/bb/cc/" "aa/bb/cc"
, checkRelativeLink "xx/yy/zz" "" "aa/bb/cc/." "aa/bb/cc"
, checkRelativeLink "xx/yy/zz" "" "aa/bb/cc/.." "aa/bb"
, checkRelativeLink "xx/yy/zz" "X" "aa/bb/cc/" "aa/bb/cc"
, checkRelativeLink "xx/yy/zz" "X" "aa/bb/cc/." "aa/bb/cc"
, checkRelativeLink "xx/yy/zz" "X" "aa/bb/cc/.." "aa/bb"
, checkRelativeLink "xx/yy/zz" "a" "a/bb/cc" "bb/cc"
, checkRelativeLink "xx/yy" "a/b" "a/b/cc" "cc"
]
-- Section 6 ------------------------------------------------------------------------
props4relativeLink :: [(String, FilePath -> FilePath -> Property)]
props4relativeLink = [ ("propRelativeLinkStaysRelative root", propRelativeLinkStaysRelative root)
, ("propRelativeLinkStaysRelative wd", propRelativeLinkStaysRelative wd)
, ("propRelativeLinkIsNotAbsolute root", propRelativeLinkIsNotAbsolute root)
, ("propRelativeLinkIsNotAbsolute wd", propRelativeLinkIsNotAbsolute wd)
, ("propSubRelativeLinkIsTarget root", propSubRelativeLinkIsTarget root)
, ("propSubRelativeLinkIsTarget wd", propSubRelativeLinkIsTarget wd)
]
propRelativeLinkStaysRelative :: FilePath -> FilePath -> FilePath -> Property
propRelativeLinkStaysRelative wd p1 = property . isRelative . relativeLink wd p1
propRelativeLinkIsNotAbsolute :: FilePath -> FilePath -> FilePath -> Property
propRelativeLinkIsNotAbsolute wd p1 = property . not. isAbsolute . relativeLink wd p1
propSubRelativeLinkIsTarget :: FilePath -> FilePath -> FilePath -> Property
propSubRelativeLinkIsTarget wd p1 p2 =
let rl = relativeLink wd (p1 </> "symlink") p2
abs p = if isAbsolute p then p else (pathSeparator:wd) </> p
in property (reduceFilePath (abs p2) == reduceFilePath (abs p1 </> rl))
-- Section 7 ------------------------------------------------------------------------
checks4pairs :: Test
checks4pairs =
let checkPairs xs ps = TestCase (assertEqual "pairs" ps (pairs xs))
in TestList
[
-- Null and one element
checkPairs [] ([] :: [(Int,Int)])
, checkPairs [0] []
-- One pair
, checkPairs [0,0] [(0,0)]
, checkPairs [0,1] [(0,1)]
, checkPairs [1,0] [(1,0)]
-- Three pairs
, checkPairs [0,0,0] [(0,0),(0,0),(0,0)]
, checkPairs [0,0,2] [(0,0),(0,2),(0,2)]
, checkPairs [0,1,0] [(0,1),(0,0),(1,0)]
, checkPairs [0,1,1] [(0,1),(0,1),(1,1)]
, checkPairs [0,1,2] [(0,1),(0,2),(1,2)]
, checkPairs [1,0,2] [(1,0),(1,2),(0,2)]
, checkPairs [2,1,0] [(2,1),(2,0),(1,0)]
, checkPairs [0,2,1] [(0,2),(0,1),(2,1)]
]
-- Section 8 ------------------------------------------------------------------------
checks4unpairsPairs :: Test
checks4unpairsPairs =
let l = [[],[0,0],[0,1],[1,0],[0,0,0],[0,0,2],[0,1,0],[0,1,1],[0,1,2],[1,0,2],[2,1,0],[0,2,1]]
in TestCase (assertEqual "unpairs/pairs" l (map (unpairs.pairs) l))
props4unpairsPairs :: [(String, [Int] -> Property)]
props4unpairsPairs = [("propUnpairsPairsId", propUnpairsPairsId)]
propUnpairsPairsId :: [Int] -> Property
propUnpairsPairsId xs = length xs /= 1 ==> xs == (unpairs.pairs) xs
-- Section 9 ------------------------------------------------------------------------
check4compElems :: Test
check4compElems =
let checkCompElems xs ys ts = TestCase (assertEqual "compElems" ts (compElems xs ys))
in TestList
[ checkCompElems ([]::[Int]) [] ([],[],[])
, checkCompElems [0..9] [] ([],[0..9],[])
, checkCompElems [] [0..9] ([],[],[0..9])
, checkCompElems [0..9] [0..9] ([0..9],[],[])
, checkCompElems [0..9] [10..19] ([],[0..9],[10..19])
, checkCompElems [0..9] [0..19] ([0..9],[],[10..19])
, checkCompElems [0..19] [0..9] ([0..9],[10..19],[])
, checkCompElems [0..19] [-9..9] ([0..9],[10..19],[-9..(-1)])
]
props4check4compElems :: [(String,[Int] -> [Int] -> Property)]
props4check4compElems = [("propCompElemsDisjoint",propCompElemsDisjoint)
,("propCompElemsComplete",propCompElemsComplete)
]
propCompElemsDisjoint :: [Int] -> [Int] -> Property
propCompElemsDisjoint xs ys = let (same, unique1, unique2) = compElems xs ys
in property (
null (same `intersect` unique1) &&
null (same `intersect` unique2) &&
null (unique1 `intersect` unique2)
)
propCompElemsComplete :: [Int] -> [Int] -> Property
propCompElemsComplete xs ys = let (same, unique1, unique2) = compElems xs ys
in property (
sort (nub xs) == sort (same++unique1) &&
sort (nub ys) == sort (same++unique2)
)
-- Section 10 -----------------------------------------------------------------------
checks4subdirectory :: Test
checks4subdirectory =
let checkSubdirectory d1 d2 b = TestCase (assertEqual "subdirectory" b (d1 `subdirectory` d2))
in TestList
[ checkSubdirectory "/" "/" True
, checkSubdirectory "/" "/." True
, checkSubdirectory "/." "/" True
, checkSubdirectory "/." "/." True
, checkSubdirectory "/" "/.." True
, checkSubdirectory "/.." "/" True
, checkSubdirectory "/.." "/.." True
, checkSubdirectory "/.." "/." True
, checkSubdirectory "/." "/.." True
, checkSubdirectory "/a/b/c" "/x/y/z" False
, checkSubdirectory "/x/y/z" "/a/b/c" False
, checkSubdirectory "/x/y/z" "/x/y/z" True
, checkSubdirectory "/x/y/z" "/x/y" True
, checkSubdirectory "/x/y" "/x/y/z" False
]
checks4subdirectories :: Test
checks4subdirectories =
let checkSubdirectories d2 d1 b = TestCase (assertEqual "subdirectories" b (d2 `subdirectories` d1))
in TestList
[ checkSubdirectories "/" "/" True
, checkSubdirectories "/" "/." True
, checkSubdirectories "/." "/" True
, checkSubdirectories "/." "/." True
, checkSubdirectories "/" "/.." True
, checkSubdirectories "/.." "/" True
, checkSubdirectories "/.." "/.." True
, checkSubdirectories "/.." "/." True
, checkSubdirectories "/." "/.." True
, checkSubdirectories "/a/b/c" "/x/y/z" False
, checkSubdirectories "/x/y/z" "/a/b/c" False
, checkSubdirectories "/x/y/z" "/x/y/z" True
, checkSubdirectories "/x/y/z" "/x/y" True
, checkSubdirectories "/x/y" "/x/y/z" True
]
props4Subdirectories :: [(String, FilePath -> FilePath -> Property)]
props4Subdirectories = [ ("propSubdirectory",propSubdirectory)
, ("propSubdirectories",propSubdirectories)
]
propSubdirectory :: FilePath -> FilePath -> Property
propSubdirectory d1 d2 =
let d1_ = root </> d1
d2_ = root </> d2
in property (
if reduceFilePath d1_ == reduceFilePath d2_
then d1_ `subdirectory` d2_
else if d1_ `subdirectory` d2_
then not (d2_ `subdirectory` d1_)
else if d2_ `subdirectory` d1_
then not (d1_ `subdirectory` d2_)
else not (d1_ `subdirectory` d2_) && not (d2_ `subdirectory` d1_)
)
propSubdirectories :: FilePath -> FilePath -> Property
propSubdirectories d1 d2 =
let d1_ = root </> d1
d2_ = root </> d2
in property (
(subdirectories d1_ d2_ && subdirectories d2_ d1_) ||
(not (subdirectories d1_ d2_) && not (subdirectories d2_ d1_))
)
-- Section 11 -----------------------------------------------------------------------
checks4aDirectory :: Test
checks4aDirectory =
let check4aDirectory p expected =
TestCase (aDirectory p >>= assertBool "aDirectory" . (expected==))
in TestList
[ check4aDirectory "/" True
, check4aDirectory "." True
, check4aDirectory ".." True
, check4aDirectory "/etc/passwd" False
, check4aDirectory "/var/run" False
, check4aDirectory "RaNdOmJuNk" False
]
checks4aSymbolicLink :: Test
checks4aSymbolicLink =
let check4aSymbolicLink p expected =
TestCase (aSymbolicLink p >>= assertBool "aSymbolicLink" . (expected==))
in TestList
[ check4aSymbolicLink "/" False
, check4aSymbolicLink "." False
, check4aSymbolicLink ".." False
, check4aSymbolicLink "/etc/passwd" False
, check4aSymbolicLink "/var/run" True
, check4aSymbolicLink "RaNdOmJuNk" False
]
checks4anObject :: Test
checks4anObject =
let check4anObject p expected =
TestCase (anObject p >>= assertBool "anObject" . (expected==))
in TestList
[ check4anObject "/" True
, check4anObject "." True
, check4anObject ".." True
, check4anObject "/etc/passwd" True
, check4anObject "RaNdOmJuNk" False
, check4anObject "/cdrom" True
]
-- Section 12 -----------------------------------------------------------------------
checks4putOrPageStrLn :: Test
checks4putOrPageStrLn =
let check4putOrPageStrLn s =
TestCase $ assert (putOrPageStrLn s >>= \e -> unless (e == ExitSuccess) $ exitWith e)
in TestList
[ check4putOrPageStrLn ""
, check4putOrPageStrLn "."
]
-- Section 13 ------------------------------------------------------------------------
runTests :: IO ExitCode
runTests =
let command = "./tests/run-tests.sh"
backstops = "dist*/build/*/ghc-*/backstop-*/x/backstop/build/backstop/backstop"
++ " "
++ "dist/build/backstop/backstop"
++ " "
++ ".stack-work/install/*/*/8.6.5/bin/backstop"
in runCommand (command ++ " " ++ backstops) >>= waitForProcess
-- Section Last ---------------------------------------------------------------------
verify :: Testable a => a -> IO ()
verify t =
do result <- quickCheckResult t
case result of
Success{} -> return ()
GaveUp ntest _ _ _ _ _ -> do hPutStrLn stderr ("Gave up after "++show ntest++" tests")
exitWith (ExitFailure (if ntest < 255 then ntest else 255))
Failure _ _ _ _ _ _ _ reason _ _ _ _ _ -> do hPutStrLn stderr ("Failure: "++reason)
exitWith (ExitFailure 255)
_ -> do hPutStrLn stderr "Not a success"
exitWith (ExitFailure 255)