{-# LANGUAGE NoImplicitPrelude #-}

-- | Args parser test suite.

module Stack.ArgsSpec where

import Control.Monad

import Data.Attoparsec.Args (EscapingMode(..), parseArgsFromString)

import Data.Attoparsec.Interpreter (interpreterArgsParser)

import qualified Data.Attoparsec.Text as P

import Data.Text (pack)

import Stack.Prelude

import Test.Hspec

import Prelude (head)

-- | Test spec.

spec :: Spec

spec = do

argsSpec

interpreterArgsSpec

argsSpec :: Spec

argsSpec = forM_ argsInputOutput

(\(input,output) -> it input (parseArgsFromString Escaping input == output))

-- | Fairly comprehensive checks.

argsInputOutput :: [(String, Either String [String])]

argsInputOutput =

[ ("x", Right ["x"])

, ("x y z", Right ["x", "y", "z"])

, ("aaa bbb ccc", Right ["aaa", "bbb", "ccc"])

, (" aaa bbb ccc ", Right ["aaa", "bbb", "ccc"])

, ("aaa\"", Left "unterminated string: endOfInput")

, ("\"", Left "unterminated string: endOfInput")

, ("\"\"", Right [""])

, ("\"aaa", Left "unterminated string: endOfInput")

, ("\"aaa\" bbb ccc \"ddd\"", Right ["aaa", "bbb", "ccc", "ddd"])

, ("\"aa\\\"a\" bbb ccc \"ddd\"", Right ["aa\"a", "bbb", "ccc", "ddd"])

, ("\"aa\\\"a\" bb\\b ccc \"ddd\"", Right ["aa\"a", "bb\\b", "ccc", "ddd"])

, ("\"\" \"\" c", Right ["","","c"])]

interpreterArgsSpec :: Spec

interpreterArgsSpec =

describe "Script interpreter parser" $ do

describe "Success cases" $ do

describe "Line comments" $ do

checkLines ""

checkLines " --x"

checkLines " --x --y"

describe "Literate line comments" $ do

checkLiterateLines ""

checkLiterateLines " --x"

checkLiterateLines " --x --y"

describe "Block comments" $ do

checkBlocks ""

checkBlocks "\n"

checkBlocks " --x"

checkBlocks "\n--x"

checkBlocks " --x --y"

checkBlocks "\n--x\n--y"

checkBlocks "\n\t--x\n\t--y"

describe "Literate block comments" $ do

checkLiterateBlocks "" ""

checkLiterateBlocks "\n>" ""

checkLiterateBlocks " --x" " --x"

checkLiterateBlocks "\n>--x" "--x"

checkLiterateBlocks " --x --y " "--x --y"

checkLiterateBlocks "\n>--x\n>--y" "--x --y"

checkLiterateBlocks "\n>\t--x\n>\t--y" "--x --y"

describe "Failure cases" $ do

checkFailures

describe "Bare directives in literate files" $ do

forM_ (interpreterGenValid lineComment []) $

testAndCheck (acceptFailure True) []

forM_ (interpreterGenValid blockComment []) $

testAndCheck (acceptFailure True) []

where

parse isLiterate s =

P.parseOnly (interpreterArgsParser isLiterate stackProgName) (pack s)

acceptSuccess :: Bool -> String -> String -> Bool

acceptSuccess isLiterate args s = case parse isLiterate s of

Right x | words x == words args -> True

_ -> False

acceptFailure isLiterate _ s = case parse isLiterate s of

Left _ -> True

Right _ -> False

showInput i = "BEGIN =>" ++ i ++ "<= END"

testAndCheck checker out inp = it (showInput inp) $ checker out inp

checkLines args = forM_

(interpreterGenValid lineComment args)

(testAndCheck (acceptSuccess False) args)

checkLiterateLines args = forM_

(interpreterGenValid literateLineComment args)

(testAndCheck (acceptSuccess True) args)

checkBlocks args = forM_

(interpreterGenValid blockComment args)

(testAndCheck (acceptSuccess False) args)

checkLiterateBlocks inp args = forM_

(interpreterGenValid literateBlockComment inp)

(testAndCheck (acceptSuccess True) args)

checkFailures = forM_

interpreterGenInvalid

(testAndCheck (acceptFailure False) "unused")

-- Generate a set of acceptable inputs for given format and args

interpreterGenValid fmt args = shebang <++> newLine <++> fmt args

interpreterGenInvalid :: [String]

-- Generate a set of Invalid inputs

interpreterGenInvalid =

["-stack\n"] -- random input

-- just the shebang

<|> shebang <++> ["\n"]

-- invalid shebang

<|> blockSpace <++> [head (interpreterGenValid lineComment args)]

-- something between shebang and stack comment

<|> shebang

<++> newLine

<++> blockSpace

<++> ([head (lineComment args)] <|> [head (blockComment args)])

-- unterminated block comment

-- just chop the closing chars from a valid block comment

<|> shebang

<++> ["\n"]

<++> let

c = head (blockComment args)

l = length c - 2

in [assert (drop l c == "-}") (take l c)]

-- nested block comment

<|> shebang

<++> ["\n"]

<++> [head (blockComment "--x {- nested -} --y")]

where args = " --x --y"

(<++>) = liftA2 (++)

-- Generative grammar for the interpreter comments

shebang = ["#!/usr/bin/env stack"]

newLine = ["\n"] <|> ["\r\n"]

-- A comment may be the last line or followed by something else

postComment = [""] <|> newLine

-- A command starts with zero or more whitespace followed by "stack"

makeComment maker space args =

let makePrefix s = (s <|> [""]) <++> [stackProgName]

in (maker <$> (makePrefix space <++> [args])) <++> postComment

lineSpace = [" "] <|> ["\t"]

lineComment = makeComment makeLine lineSpace

where makeLine s = "--" ++ s

literateLineComment = makeComment ("> --" ++) lineSpace

blockSpace = lineSpace <|> newLine

blockComment = makeComment makeBlock blockSpace

where makeBlock s = "{-" ++ s ++ "-}"

literateBlockComment = makeComment

(\s -> "> {-" ++ s ++ "-}")

(lineSpace <|> map (++ ">") newLine)