docopt-0.7.0.8: test/LangAgnosticTests.hs

{-# LANGUAGE FlexibleInstances #-}

-- TODO: Remove orphan instances?
{-# OPTIONS_GHC -Wno-orphans #-}

import Control.Monad ( (>=>) )
import System.Exit
import System.Console.ANSI

import System.Console.Docopt
import System.Console.Docopt.Types
import System.Console.Docopt.ParseUtils
import System.Console.Docopt.UsageParse (pDocopt)
import System.Console.Docopt.OptParse (getArguments)

import           Data.Map (Map)
import qualified Data.Map as M

import Data.List.Split
import Data.Aeson
import qualified Data.ByteString.Lazy.Char8 as BS

import Test.HUnit
import Paths_docopt (getDataFileName)


instance ToJSON ArgValue where
  toJSON x = case x of
    MultiValue vs -> toJSON $ reverse vs
    Value v       -> toJSON v
    NoValue       -> toJSON Null
    Counted n     -> toJSON n
    Present       -> toJSON True
    NotPresent    -> toJSON False

instance {-# OVERLAPPING #-} ToJSON (Map Option ArgValue) where
  toJSON argmap =
    let argmap' = M.mapKeys humanize argmap
    in  toJSON argmap'

coloredString :: Color -> String -> String
coloredString c str = setSGRCode [SetColor Foreground Dull c]
                    ++ str
                    ++ setSGRCode [Reset]

green, red, yellow, blue, magenta :: String -> String
green   = coloredString Green
red     = coloredString Red
yellow  = coloredString Yellow
blue    = coloredString Blue
magenta = coloredString Magenta


main :: IO ()
main = do
  referenceTestsFile <- (getDataFileName >=> readFile) "test/testcases.docopt"
  referenceTests <- testsFromDocoptSpecFile "testcases.docopt" referenceTestsFile testcasesBlacklist

  regressionTestsFile <- (getDataFileName >=> readFile) "test/regressions.txt"
  regressionTests <- testsFromDocoptSpecFile "regressions.txt" regressionTestsFile regressionsBlacklist

  counts <- runTestTT $ TestList $ referenceTests ++ regressionTests
  exitWith $ if failures counts > 0
                then ExitFailure 1
                else ExitSuccess


testcasesBlacklist :: (Int, Int) -> Bool
-- Short/long option synonym equality (will fix)
testcasesBlacklist (4, 1) = True
testcasesBlacklist (4, 3) = True
testcasesBlacklist (7, 1) = True
testcasesBlacklist (8, 1) = True
testcasesBlacklist (8, 2) = True
testcasesBlacklist (35, 1) = True
testcasesBlacklist (64, 1) = True
-- Partial-option disambiguation
testcasesBlacklist (4, 2) = True
testcasesBlacklist (6, 3) = True
testcasesBlacklist (6, 4) = True
testcasesBlacklist (12, 4) = True
-- Stacked short options/flags disambiguation
testcasesBlacklist (14, 1) = True
testcasesBlacklist (70, 1) = True
-- Option order insensitivity
testcasesBlacklist (15, 2) = True
testcasesBlacklist (16, 2) = True
testcasesBlacklist (17, 2) = True
testcasesBlacklist (18, 2) = True
-- Weirdly broken (argument capture; should fix)
testcasesBlacklist (33, 2) = True
testcasesBlacklist (33, 3) = True
testcasesBlacklist (34, 3) = True
-- [options] expansion pruning (should fix)
testcasesBlacklist (67, 1) = True
testcasesBlacklist _ = False

regressionsBlacklist :: (Int, Int) -> Bool
-- Failing tests for issue #25, should investigate & fix
regressionsBlacklist (6, 1) = True
regressionsBlacklist (6, 2) = True
regressionsBlacklist _ = False


testsFromDocoptSpecFile :: String
                        -> String
                        -> ((Int, Int) -> Bool)
                        -> IO [Test]
testsFromDocoptSpecFile name testFile ignore =
  let notCommentLine x = case x of {[] -> True; (c:_) -> '#' /= c}
      testFileClean = unlines $ filter notCommentLine $ lines testFile
      caseGroups = filter (not . null) $ splitOn "r\"\"\"" testFileClean

  in
  return . (:[]) . TestLabel name . test $ zip caseGroups [(1 :: Int)..] >>= \(caseGroup, icg) -> do

    let (usage, rawCases) = case splitOn "\"\"\"" caseGroup of
          [u, r] -> (u, r)
          _ -> error $ "Unexpected format of 'caseGroup': " ++ caseGroup
        cases = filter (/= "\n") $ splitOn "$ " rawCases

    let (optFormat, docParseMsg) = case runParser pDocopt M.empty "Usage" usage of
          Left _e -> ((Sequence [], M.empty), "Couldn't parse usage text")
          Right o -> (o, "")

    let groupDescLines = [
            docParseMsg,
            "Docopt:",
            blue usage,
            "Pattern:",
            magenta (show optFormat)
          ]

    zip cases [(1::Int)..] >>= \(testcase, itc) -> do

      let (cmdline, rawTarget_) = break (== '\n') testcase
          rawTarget = filter (/= '\n') rawTarget_
          maybeTargetJSON = decode (BS.pack rawTarget) :: Maybe Value
          rawArgs = drop 1 (words cmdline)

      let (parsedArgs, _argParseMsg) = case getArguments optFormat rawArgs of
            Left e -> (M.empty, "Parse Error: " ++ red (show e) ++ "\n")
            Right a -> (a, "")

      let parsedArgsJSON = toJSON parsedArgs
          testCaseEquality = if rawTarget == "\"user-error\""
            then M.null parsedArgs
            else maybeTargetJSON == Just parsedArgsJSON
          blacklisted = ignore (icg, itc)
          testCaseSuccess = if blacklisted
            then not testCaseEquality
            else testCaseEquality

      let testDescLines = [
              "Cmd: " ++ yellow cmdline,
              "Target: " ++ (if testCaseSuccess then green else magenta) rawTarget
            ]

      let testMsg = unlines . filter (not . null) $
                      groupDescLines
                      ++ testDescLines
                      ++ ["(Blacklisted)" | blacklisted]
                      ++ ["Failure: " ++ red (BS.unpack $ encode parsedArgsJSON)]

      let ti = TestCase $ testCaseSuccess @? testMsg

      return $ TestLabel ("group-" ++ show icg ++ "-case-" ++ show itc) ti