content: {-# LANGUAGE LambdaCase #-}
  
  -- | A test of the FSATrace program
  module Utils(
      Env(..), ShellMode(..), SpaceMode(..),
      Prop,
      Path(..), Arg(..),
      Act(..), FSATest(..), showAct,
      cased, valid,
      command, yields, yieldsPrepare,
      systemStdout, systemStderr,
      no32to64
    ) where
  
  import           Parse
  
  import           Control.Monad
  import           Control.Monad.IO.Class
  import           Control.Monad.Trans.Reader
  import           Data.Char
  import           Data.List.Extra
  import           System.Exit
  import           System.IO
  import           System.Process
  import           System.FilePath
  import           System.Info.Extra
  import           Test.QuickCheck
  import           Test.QuickCheck.Monadic
  --import           Debug.Trace
  
  data Env = Env
      { shellMode :: ShellMode
      , tmpDir :: FilePath
      , pwdDir :: FilePath
      }
  
  type Prop = Reader Env Property
  
  newtype Arg = Arg { unarg :: String } deriving (Show, Eq)
  
  instance Arbitrary Arg where
    arbitrary = Arg <$> listOf1 validChars
      where validChars = arbitrary `suchThat` \x -> isLatin1 x && x `notElem` "\0>|"
    shrink (Arg x) = map Arg $ shrink x
  
  newtype Path = Path { unpath :: FilePath }
  
  instance Eq Path where
    (==) (Path a) (Path b) = equalFilePath a b
  
  instance Show Path where
    show (Path p) = show p
  
  instance Ord Path where
    compare (Path x) (Path y) = compare (cased x) (cased y)
  
  
  data ShellMode = Unshelled | Shelled deriving (Show, Eq, Enum, Bounded)
  data SpaceMode = Unspaced | Spaced deriving (Show, Eq, Enum, Bounded)
  
  cased :: String -> String
  cased | isWindows = map toLower
        | otherwise = id
  
  
  
  valid :: FilePath -> Access Path -> Bool
  valid t (R p) = inTmp t p
  valid t (Q p) = inTmp t p
  valid t (W p) | isWindows = inTmp t p
                | otherwise = not $ "/dev/" `isPrefixOf` unpath p
  valid t (D p) = inTmp t p
  valid t (T p) = inTmp t p
  valid t (M p _) = inTmp t p
  valid _ (RW _) = False -- sort on Windows produces this
  valid _ _ = True
  
  inTmp :: FilePath -> Path -> Bool
  inTmp t = isPrefixOf (cased t) . cased . unpath
  
  yields :: Reader Env [String] -> [Access Path] -> Prop
  yields = yieldsPrepare True $ return ()
  
  yieldsPrepare :: Bool -> IO () -> Reader Env [String] -> [Access Path] -> Prop
  yieldsPrepare fatal prepare eargs res = do
    e <- ask
    return $ monadicIO $ do
      liftIO prepare
      let cmd = runReader eargs e
      if length (unwords cmd) > 2000 then
        fail "Excessively long command line"
      else do
        out <- liftIO $ if fatal then systemStdout cmd else Just <$> systemStdoutPass cmd
        let cleanup = nubSort . filter (valid $ tmpDir e)
        let r = fmap (cleanup . map (fmap Path) . parseFSATrace) out
        let ok = fmap cleanup r == Just (cleanup res)
        unless ok $ liftIO $ do
          putStrLn $ "Expecting " ++ show (cleanup res)
          putStrLn $ "Got       " ++ show r
        assert ok
  
  
  command :: String -> [String] -> Reader Env [String]
  command flags args = do
    e <- ask
    return $ [pwdDir e </> ".." </> "fsatrace", flags, "-", "--"] ++ cmd (shellMode e)
    where cmd :: ShellMode -> [String]
          cmd Unshelled = args
          cmd Shelled | isWindows = "cmd.exe" : "/C" : args
                      | otherwise = ["sh", "-c", unwords (map quoted args)]
          quoted :: String -> String
          quoted "|" = "|"
          quoted ">" = ">"
          quoted x = "\"" ++ x ++ "\""
  
  
  systemStderr :: [String] -> IO (Maybe String)
  systemStderr ~(cmd:args) = do
      (res,_out,err) <- readProcessWithExitCode cmd args ""
      return $ if res == ExitSuccess then Just err else Nothing
  
  systemStdout :: [String] -> IO (Maybe String)
  systemStdout ~(cmd:args) = do
      (res,out,err) <- readProcessWithExitCode cmd args ""
      when (err /= "") $ hPutStrLn stderr err
      return $ if res == ExitSuccess then Just out else Nothing
  
  systemStdoutPass :: [String] -> IO String
  systemStdoutPass ~(cmd:args) = do
      (_,out,err) <- readProcessWithExitCode cmd args ""
      when (err /= "") $ hPutStrLn stderr err
      return out
  
  data FSATest = FSATest | FSATest32
      deriving Eq
  
  instance Show FSATest where
    show FSATest = "fsatest"
    show FSATest32 = "fsatest32"
  
  instance Arbitrary FSATest where
    arbitrary = elements [FSATest, FSATest32]
    shrink x = [FSATest | x /= FSATest]
  
  data Act = ActR FilePath
           | ActW FilePath
           | ActE FSATest [Act]
           | ActF
             deriving Show
  
  instance Arbitrary Act where
    arbitrary = sized $ \sz -> frequency
        [(8, ActR <$> name)
        ,(8, ActW <$> name)
        ,(1, return ActF)
        ,(if sz > 10 then 1 else 0, resize (min 20 $ sz-10) $ ActE <$> arbitrary <*> arbitrary)]
      where name = vectorOf 2 $ choose ('a', 'z')
  
    shrink (ActE a b) = (flip ActE b <$> (shrink a)) ++ (ActE a <$> shrink b) ++ b
    shrink _ = []
  
  showAct :: Env -> [Act] -> [String]
  showAct e = map f
    where
      f (ActR x) = "r" ++ tmpDir e </> x
      f (ActW x) = "w" ++ tmpDir e </> x
      f ActF = "f"
      f (ActE p xs) = "e" ++ escape (unwords $ (pwdDir e </> ".." </> show p) : showAct e xs)
  
      escape = concatMap $ \case
        '#' -> "##"
        ' ' -> "#"
        x   -> [x]
  
  no32to64 :: FSATest -> Act -> Act
  no32to64 FSATest32 (ActE _ xs) = ActE FSATest32 $ map (no32to64 FSATest32) xs
  no32to64 _ (ActE p xs) = ActE p $ map (no32to64 p) xs
  no32to64 _ x = x
  