path: root/test/runTests.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Main where

import Data.Monoid
import Data.Char
import Data.List
--import Data.Either
import qualified Data.Map.Strict as Map
import Data.Time.Clock
import Data.Algorithm.Patience
import Control.Applicative
import Control.Arrow hiding ((<+>))
import Control.Concurrent
import Control.Concurrent.Async
import Control.Monad
import Control.Monad.Reader
--import Control.Monad.Except
import Control.Monad.Catch
import Control.Exception hiding (catch, bracket, finally, mask)
--import Control.Exception hiding (catch)
import Control.Monad.Trans.Control
import Control.DeepSeq
import System.Exit
import System.Directory
import System.FilePath
import System.IO
import Options.Applicative

import qualified Data.Text as T
import qualified Data.Text.IO as TIO
import Text.Printf

import qualified LambdaCube.IR as IR
import LambdaCube.Compiler
import LambdaCube.Compiler.Pretty hiding ((</>))

------------------------------------------ utils

(<&>) = flip (<$>)

readFileStrict :: FilePath -> IO String
readFileStrict = fmap T.unpack . TIO.readFile

getDirectoryContentsRecursive path = do
  l <- map (path </>) . filter (`notElem` [".",".."]) <$> getDirectoryContents path
  (++)
    <$> filterM doesFileExist l
    <*> (fmap mconcat . traverse getDirectoryContentsRecursive =<< filterM doesDirectoryExist l)

takeExtensions' :: FilePath -> [String]
takeExtensions' = snd . splitExtensions'

splitExtensions' fn = case splitExtension fn of
    (a, "") -> (a, [])
    (fn', ext) -> second (ext:) $ splitExtensions' fn'

getYNChar = do
    c <- getChar
    case c of
        _ | c `elem` ("yY" :: String) -> putChar '\n' >> return True
          | c `elem` ("nN" :: String) -> putChar '\n' >> return False
          | otherwise -> getYNChar

showTime delta
    | t > 1e-1  = printf "%.3fs" t
    | t > 1e-3  = printf "%.1fms" (t/1e-3)
    | otherwise = printf "%.0fus" (t/1e-6)
  where
    t = realToFrac delta :: Double

timeOut :: forall m a . MonadBaseControl IO m => NominalDiffTime -> a -> m a -> m (NominalDiffTime, a)
timeOut dt d m =
  control $ \runInIO ->
    race' (runInIO $ timeDiff m)
          (runInIO $ timeDiff $ liftIO (threadDelay $ round $ dt * 1000000) >> return d)
  where
    liftIO :: IO b -> m b
    liftIO m = liftBaseWith (const m)
    race' a b = either id id <$> race a b
    timeDiff m = (\s x e -> (diffUTCTime e s, x))
      <$> liftIO getCurrentTime
      <*> m
      <*> liftIO getCurrentTime

catchErr :: (MonadCatch m, NFData a, MonadIO m) => (String -> m a) -> m a -> m a
catchErr er m = (force <$> m >>= liftIO . evaluate) `catch` getErr `catch` getPMatchFail
  where
    getErr (e :: ErrorCall) = catchErr er $ er $ show e
    getPMatchFail (e :: PatternMatchFail) = catchErr er $ er $ show e

------------------------------------------

testDataPath = "./testdata"

data Config
  = Config
  { cfgVerbose      :: Bool
  , cfgReject       :: Bool
  , cfgTimeout      :: NominalDiffTime
  , cfgIgnore       :: [String]
  , cfgOverallTime  :: Bool
  } deriving Show

arguments :: Parser (Config, [String])
arguments =
  (,) <$> (Config <$> switch (short 'v' <> long "verbose" <> help "Verbose output during test runs")
                  <*> switch (short 'r' <> long "reject" <> help "Reject test cases with missing, new or different .out files")
                  <*> option (realToFrac <$> (auto :: ReadM Double)) (value 60 <> short 't' <> long "timeout" <> help "Timeout for tests in seconds")
                  <*> many (option (eitherReader Right) (short 'i' <> long "ignore" <> help "Ignore test"))
                  <*> switch (long "overall-time" <> help "Writes overall time to overall-time.txt")
          )
      <*> many (strArgument idm)

data Res = Passed | Accepted | NewRes | TimedOut | Rejected | Failed | ErrorCatched
    deriving (Eq, Ord, Show)

showRes = \case
    ErrorCatched    -> "crashed test"
    Failed          -> "failed test"
    Rejected        -> "rejected result"
    TimedOut        -> "timed out test"
    NewRes          -> "new result"
    Accepted        -> "accepted result"
    Passed          -> "passed test"

instance NFData Res where
    rnf a = a `seq` ()

erroneous = (>= TimedOut)

isWip    = (".wip" `elem`) . takeExtensions'
isReject = (".reject" `elem`) . takeExtensions'

-- for the repl
parse srcName = do
    pplRes <- parseModule ["testdata"] (srcName ++ ".lc")
    case pplRes of
        Left err -> fail $ show err
        Right ppl -> putStrLn ppl

main :: IO ()
main = do
  hSetBuffering stdout NoBuffering
  hSetBuffering stdin NoBuffering
  (cfg@Config{..}, samplesToTest) <- execParser $
           info (helper <*> arguments)
                (fullDesc <> header "LambdaCube 3D compiler test suite")

  testData <- filter ((".lc" ==) . takeExtension) <$> getDirectoryContentsRecursive testDataPath
  -- select test set: all test or user selected
  let (ignoredTests, testSet) 
        = partition (\d -> any (`isInfixOf` d) cfgIgnore) 
        . map head . group . sort 
        $ [d | d <- testData, s <- if null samplesToTest then [""] else samplesToTest, s `isInfixOf` d]

  unless (null ignoredTests) $ do
    putStrLn $ "------------------------------------ Ignoring " ++ show (length ignoredTests) ++ " tests"
    forM_ ignoredTests putStrLn

  when (null testSet) $ do
    putStrLn $ "test files not found: " ++ show samplesToTest
    exitFailure

  putStrLn $ "------------------------------------ Running " ++ show (length testSet) ++ " tests"

  resultDiffs
    <- runMM (ioFetch [".", testDataPath])
    $ forM (zip [1..] testSet) $ doTest cfg

  let sh :: (FilePath -> Res -> Bool) -> String -> [String]
      sh p b = [ (if any (\(ty, s) -> erroneous ty && not (isWip s)) ss then "!" else "")
                 ++ show noOfResult ++ " "
                 ++ pad 10 (b ++ plural ++ ": ") ++ "\n"
                 ++ unlines (map snd ss)
               | not $ null ss ]
          where
            ss = [(ty, s) | ((_, ty), s) <- zip resultDiffs testSet, p s ty]
            noOfResult = length ss
            plural = ['s' | noOfResult > 1]

  putStrLn "------------------------------------ Summary"
  putStrLn $ unlines $ reverse $
      concat [ sh (\s ty -> ty == x && p s) (w ++ showRes x)
             | (w, p) <- [("", not . isWip), ("wip ", isWip)]
             , x <- [ErrorCatched, Failed, Rejected, TimedOut, NewRes, Accepted]
             ]
      ++ sh (\s ty -> ty == Passed && isWip s) "wip passed test"

  let overallTime = sum $ map fst resultDiffs
  putStrLn $ "Overall time: " ++ showTime overallTime
  when cfgOverallTime $ writeFile "overall-time.txt" $ show (realToFrac overallTime :: Double)

  when (or [erroneous r | ((_, r), f) <- zip resultDiffs testSet, not $ isWip f]) exitFailure
  putStrLn "All OK"
  when (or [erroneous r | ((_, r), f) <- zip resultDiffs testSet, isWip f]) $
        putStrLn "Only work in progress test cases are failing."

splitMPath fn = (joinPath $ reverse as, foldr1 (</>) $ reverse bs ++ [y], intercalate "." $ reverse bs ++ [y])
  where
    (bs, as) = span (\x -> not (null x) && isUpper (head x)) $ reverse xs
    (xs, y) = map takeDirectory . splitPath *** id $ splitFileName $ dropExtension fn

doTest Config{..} (i, fn) = do
    liftIO $ putStr $ pa ++ " " ++ mn ++ " " ++ concat exts ++ " "
    (runtime, res) <- mapMMT (timeOut cfgTimeout $ Left ("!Timed Out", TimedOut))
                    $ catchErr (\e -> return $ Left (tab "!Crashed" e, ErrorCatched))
                    $ liftIO . evaluate =<< (force . f <$> getMain)
    liftIO $ putStr $ "(" ++ showTime runtime ++ ")" ++ "    "
    (msg, result) <- case res of
        Left x -> return x
        Right (op, x) -> liftIO $ compareResult (pad 15 op) (dropExtension fn ++ ".out") x
    liftIO $ putStrLn msg
    return (runtime, result)
  where
    (splitMPath -> (pa, mn', mn), reverse -> exts) = splitExtensions' $ dropExtension fn

    getMain = do
        res <- local (const $ ioFetch [pa]) $ loadModule id Nothing (Left $ mn' ++ concat exts ++ ".lc") <&> \case
            Left err -> (mempty, Left (Nothing, err))
            Right (fname, (src, Left err)) -> (mempty, Left (Just fname, err))
            Right (fname, (src, Right (pm, infos, Left err))) -> (,) infos $ Left (Just fname, err)
            Right (fname, (src, Right (pm, infos, Right (_, ge)))) -> (,) infos $ Right
                ( fname
                , ge
                , case Map.lookup "main" ge of
                  Just (e, thy, si) -> Right (ET e thy)
                  Nothing -> Left $ text "main" <+> "is not found"
                )
        case res of
          (_, Right (fi, _, Right{})) -> removeFromCache $ filePath fi
          _ -> return ()
        return res

    --getDef :: MonadMask m => FilePath -> SName -> Maybe Exp -> MMT m (Infos, [Stmt]) ((Infos, [Stmt]), Either Doc (FilePath, Either Doc ExpType))
    clearPipelineInfo p = p {IR.info = ""}
    f ((i, desug), e) | not $ isReject fn = case e of
        Left (_, show -> e)      -> Left (unlines $ tab "!Failed" e: map show (listTraceInfos i), Failed)
        Right (fname, ge, Left (pShow -> e))
                                 -> Right ("typechecked module", simpleShow $ vcat $ e: showGE fname ge)
        Right (fname, ge, Right (ET e te))
            | te == outputType   -> Right ("compiled pipeline", prettyShowUnlines $ clearPipelineInfo $ compilePipeline OpenGL33 (ET e te))
            | e == trueExp       -> Right ("reducted main", de)
            | te == boolType     -> Left (tab "!Failed" $ "main should be True but it is \n" ++ simpleShow res, Failed)
            | otherwise          -> Right ("reduced main :: " ++ simpleShow (mkDoc (True, False) te), de)
          where
            de = simpleShow $ vcat $ (DAnn "main" $ pShow te) : (DLet "=" "main" res): showGE fname ge
            res = mkDoc (True, False) e
      | otherwise = case e of
        Left (fn, pShow -> e)    -> Right ("error message", simpleShow $ vcat $ e: listAllInfos fn i)
        Right _                  -> Left (tab "!Failed" "failed to catch error", Failed)
      where
        showGE fname ge =  "------------ desugared source code": intersperse "" (map pShow desug)
                        ++ "------------ core code": intersperse ""
                            [      DAnn (text n) (DResetFreshNames $ pShow t)
                              <$$> DLet "=" (text n) (DResetFreshNames $ mkDoc (False, True) e)
                            | (n, (e, t, RangeSI r)) <- Map.toList ge, rangeFile r == fname]
                        ++ listAllInfos' (Just fname) i

    tab msg
        | isWip fn && cfgReject = const msg
        | otherwise = ((msg ++ "\n") ++) . unlines . map ("  " ++) . lines

    compareResult msg ef e = doesFileExist ef >>= \b -> case b of
        False
            | cfgReject -> return ("!Missing .out file", Rejected)
            | otherwise -> writeFile ef e >> return ("New .out file", NewRes)
        True -> do
            e' <- lines <$> readFileStrict ef
            let d = diff e' $ lines e
            case d of
              _ | all (\case Both{} -> True; _ -> False) d -> return ("OK", Passed)
              rs -> do
                    mapM_ putStrLn $ printOldNew msg d
                    putStrLn $ ef ++ " has changed."
                    if cfgReject then return ("!Different .out file", Rejected) else do
                        putStr $ "Accept new " ++ msg ++ " (y/n)? "
                        c <- getYNChar
                        if c
                            then writeFile ef e >> return ("Accepted .out file", Accepted)
                            else return ("!Rejected .out file", Rejected)

printOldNew :: String -> [Item String] -> [String]
printOldNew msg d = (msg ++ " has changed.") : ff [] 0 d
  where
    ff acc n (x@(Both a b): ds) = [a' | n < 5] ++ ff (a':acc) (n+1) ds where a' = "  " ++ a
    ff acc n (Old a: ds)  = g acc n ++ (show (onred "< ") ++ a): ff [] 0 ds
    ff acc n (New b: ds)  = g acc n ++ (show (ongreen "> ") ++ b): ff [] 0 ds
    ff _ _ [] = []
    g acc n | n < 5 = []
    g acc n | n > 10 = "___________": reverse (take 5 acc)
    g acc n = reverse (take (n-5) acc)

pad n s = s ++ replicate (n - length s) ' '

limit :: String -> Int -> String -> String
limit msg n s = take n s ++ if null (drop n s) then "" else msg