diff options
| -rw-r--r-- | driver-test/Main.hs | 12 | ||||
| -rw-r--r-- | driver-test/ResponseFileSpec.hs | 80 | ||||
| -rw-r--r-- | driver/Main.hs | 23 | ||||
| -rw-r--r-- | driver/ResponseFile.hs | 110 | ||||
| -rw-r--r-- | haddock.cabal | 7 |
5 files changed, 210 insertions, 22 deletions
diff --git a/driver-test/Main.hs b/driver-test/Main.hs new file mode 100644 index 00000000..d3f636e9 --- /dev/null +++ b/driver-test/Main.hs @@ -0,0 +1,12 @@ +module Main where + +import Test.Hspec (describe, hspec, Spec) +import qualified ResponseFileSpec (spec) + + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "ResponseFile" ResponseFileSpec.spec diff --git a/driver-test/ResponseFileSpec.hs b/driver-test/ResponseFileSpec.hs new file mode 100644 index 00000000..997adac4 --- /dev/null +++ b/driver-test/ResponseFileSpec.hs @@ -0,0 +1,80 @@ +module ResponseFileSpec where + +import Test.Hspec (context, describe, it, shouldBe, Spec) +import ResponseFile (escapeArgs, unescapeArgs) + +-- The first two elements are +-- 1) a list of 'args' to encode and +-- 2) a single string of the encoded args +-- The 3rd element is just a description for the tests. +testStrs :: [(([String], String), String)] +testStrs = + [ ((["a simple command line"], + "a\\ simple\\ command\\ line\n"), + "the white-space, end with newline") + + , ((["arg 'foo' is single quoted"], + "arg\\ \\'foo\\'\\ is\\ single\\ quoted\n"), + "the single quotes as well") + + , ((["arg \"bar\" is double quoted"], + "arg\\ \\\"bar\\\"\\ is\\ double\\ quoted\n"), + "the double quotes as well" ) + + , ((["arg \"foo bar\" has embedded whitespace"], + "arg\\ \\\"foo\\ bar\\\"\\ has\\ embedded\\ whitespace\n"), + "the quote-embedded whitespace") + + , ((["arg 'Jack said \\'hi\\'' has single quotes"], + "arg\\ \\'Jack\\ said\\ \\\\\\'hi\\\\\\'\\'\\ has\\ single\\ quotes\n"), + "the escaped single quotes") + + , ((["arg 'Jack said \\\"hi\\\"' has double quotes"], + "arg\\ \\'Jack\\ said\\ \\\\\\\"hi\\\\\\\"\\'\\ has\\ double\\ quotes\n"), + "the escaped double quotes") + + , ((["arg 'Jack said\\r\\n\\t \\\"hi\\\"' has other whitespace"], + "arg\\ \\'Jack\\ said\\\\r\\\\n\\\\t\\ \\\\\\\"hi\\\\\\\"\\'\\ has\\ \ + \other\\ whitespace\n"), + "the other whitespace") + + , (([ "--prologue=.\\dist\\.\\haddock-prologue3239114604.txt" + , "--title=HaddockNewline-0.1.0.0: This has a\n\ + \newline yo." + , "-BC:\\Program Files\\Haskell Platform\\lib"], + "--prologue=.\\\\dist\\\\.\\\\haddock-prologue3239114604.txt\n\ + \--title=HaddockNewline-0.1.0.0:\\ This\\ has\\ a\\\n\ + \newline\\ yo.\n\ + \-BC:\\\\Program\\ Files\\\\Haskell\\ Platform\\\\lib\n"), + "an actual haddock response file snippet with embedded newlines") + ] + +spec :: Spec +spec = do + describe "escapeArgs" $ do + mapM_ (\((ss1,s2),des) -> do + context ("given " ++ (show ss1)) $ do + it ("should escape " ++ des) $ do + escapeArgs ss1 `shouldBe` s2 + ) testStrs + describe "unescapeArgs" $ do + mapM_ (\((ss1,s2),des) -> do + context ("given " ++ (show s2)) $ do + it ("should unescape " ++ des) $ do + unescapeArgs s2 `shouldBe` ss1 + ) testStrs + describe "unescapeArgs" $ do + context "given unescaped single quotes" $ do + it "should pass-through, without escaping, everything inside" $ do + -- backslash *always* is escaped anywhere it appears + (filter (not . null) $ + unescapeArgs "this\\ is\\ 'not escape\\d \"inside\"'\\ yo\n") + `shouldBe` + ["this is not escaped \"inside\" yo"] + context "given unescaped double quotes" $ do + it "should pass-through, without escaping, everything inside" $ do + -- backslash *always* is escaped anywhere it appears + (filter (not . null) $ + unescapeArgs "this\\ is\\ \"not escape\\d 'inside'\"\\ yo\n") + `shouldBe` + ["this is not escaped 'inside' yo"] diff --git a/driver/Main.hs b/driver/Main.hs index ccbb8b7d..852f44c7 100644 --- a/driver/Main.hs +++ b/driver/Main.hs @@ -1,29 +1,8 @@ -{-# LANGUAGE ScopedTypeVariables #-} module Main where -import Control.Exception import Documentation.Haddock (haddock) +import ResponseFile (expandResponse) import System.Environment (getArgs) -import System.Exit (exitFailure) -import System.IO main :: IO () main = getArgs >>= expandResponse >>= haddock - - --- | Arguments which look like '@foo' will be replaced with the --- contents of file @foo@. The contents will be passed through 'words' --- and blanks filtered out first. --- --- We quit if the file is not found or reading somehow fails. -expandResponse :: [String] -> IO [String] -expandResponse = fmap concat . mapM expand - where - expand :: String -> IO [String] - expand ('@':f) = readFileExc f >>= return . filter (not . null) . lines - expand x = return [x] - - readFileExc f = - readFile f `catch` \(e :: IOException) -> do - hPutStrLn stderr $ "Error while expanding response file: " ++ show e - exitFailure diff --git a/driver/ResponseFile.hs b/driver/ResponseFile.hs new file mode 100644 index 00000000..253c6004 --- /dev/null +++ b/driver/ResponseFile.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module ResponseFile ( + unescapeArgs, + escapeArgs, + expandResponse + ) where + +import Control.Exception +import Data.Char (isSpace) +import Data.Foldable (foldl') +import System.Exit (exitFailure) +import System.IO + + +-- | Given a string of concatenated strings, separate each by removing +-- a layer of /quoting/ and\/or /escaping/ of certain characters. +-- +-- These characters are: any whitespace, single quote, double quote, +-- and the backslash character. The backslash character always +-- escapes (i.e., passes through without further consideration) the +-- character which follows. Characters can also be escaped in blocks +-- by quoting (i.e., surrounding the blocks with matching pairs of +-- either single- or double-quotes which are not themselves escaped). +-- +-- Any whitespace which appears outside of either of the quoting and +-- escaping mechanisms, is interpreted as having been added by this +-- special concatenation process to designate where the boundaries +-- are between the original, un-concatenated list of strings. These +-- added whitespace characters are removed from the output. +-- +-- > unescapeArgs "hello\\ \\\"world\\\"\n" == escapeArgs "hello \"world\"" +unescapeArgs :: String -> [String] +unescapeArgs = filter (not . null) . unescape + +-- | Given a list of strings, concatenate them into a single string +-- with escaping of certain characters, and the addition of a newline +-- between each string. The escaping is done by adding a single +-- backslash character before any whitespace, single quote, double +-- quote, or backslash character, so this escaping character must be +-- removed. Unescaped whitespace (in this case, newline) is part +-- of this "transport" format to indicate the end of the previous +-- string and the start of a new string. +-- +-- While 'unescapeArgs' allows using quoting (i.e., convenient +-- escaping of many characters) by having matching sets of single- or +-- double-quotes,'escapeArgs' does not use the quoting mechasnism, +-- and thus will always escape any whitespace, quotes, and +-- backslashes. +-- +-- > unescapeArgs "hello\\ \\\"world\\\"\\n" == escapeArgs "hello \"world\"" +escapeArgs :: [String] -> String +escapeArgs = unlines . map escapeArg + +-- | Arguments which look like '@foo' will be replaced with the +-- contents of file @foo@. A gcc-like syntax for response files arguments +-- is expected. This must re-constitute the argument list by doing an +-- inverse of the escaping mechanism done by the calling-program side. +-- +-- We quit if the file is not found or reading somehow fails. +-- (A convenience routine for haddock or possibly other clients) +expandResponse :: [String] -> IO [String] +expandResponse = fmap concat . mapM expand + where + expand :: String -> IO [String] + expand ('@':f) = readFileExc f >>= return . unescapeArgs + expand x = return [x] + + readFileExc f = + readFile f `catch` \(e :: IOException) -> do + hPutStrLn stderr $ "Error while expanding response file: " ++ show e + exitFailure + +data Quoting = NoneQ | SngQ | DblQ + +unescape :: String -> [String] +unescape args = reverse . map reverse $ go args NoneQ False [] [] + where + -- n.b., the order of these cases matters; these are cribbed from gcc + -- case 1: end of input + go [] _q _bs a as = a:as + -- case 2: back-slash escape in progress + go (c:cs) q True a as = go cs q False (c:a) as + -- case 3: no back-slash escape in progress, but got a back-slash + go (c:cs) q False a as + | '\\' == c = go cs q True a as + -- case 4: single-quote escaping in progress + go (c:cs) SngQ False a as + | '\'' == c = go cs NoneQ False a as + | otherwise = go cs SngQ False (c:a) as + -- case 5: double-quote escaping in progress + go (c:cs) DblQ False a as + | '"' == c = go cs NoneQ False a as + | otherwise = go cs DblQ False (c:a) as + -- case 6: no escaping is in progress + go (c:cs) NoneQ False a as + | isSpace c = go cs NoneQ False [] (a:as) + | '\'' == c = go cs SngQ False a as + | '"' == c = go cs DblQ False a as + | otherwise = go cs NoneQ False (c:a) as + +escapeArg :: String -> String +escapeArg = reverse . foldl' escape [] + +escape :: String -> Char -> String +escape cs c + | isSpace c + || '\\' == c + || '\'' == c + || '"' == c = c:'\\':cs -- n.b., our caller must reverse the result + | otherwise = c:cs diff --git a/haddock.cabal b/haddock.cabal index 71b78347..5fbfa3a0 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -122,6 +122,13 @@ executable haddock else build-depends: haddock-api == 2.16.* +test-suite driver-test + type: exitcode-stdio-1.0 + default-language: Haskell2010 + main-is: Main.hs + hs-source-dirs: driver-test, driver + build-depends: base, hspec + test-suite html-test type: exitcode-stdio-1.0 default-language: Haskell2010 |