Implement whitespace_ok option

Author: jbransen

haskell_edsl/src-main/Test.hs

@@ -2,6 +2,7 @@ module Main ( main ) where
 
 import Checktestdata
 import Checktestdata.Script
+import Checktestdata.Options
 
 import Control.Monad
 import Control.Exception
@@ -19,61 +20,72 @@ main = do
   -- Read the tests directory
   allfiles <- listDirectory testsdir
 
-  -- Go over all regular test programs
-  let isProg f = "testprog" `isPrefixOf` f && ".in" `isSuffixOf` f
-  r1 <- forM (filter isProg allfiles) $ \prog -> do
-    -- Get the test num
-    let testnum = takeWhile (/='.') $ drop (length "testprog") prog
+  -- Generic function we can run for both whitespace and non-whitespace
+  let tests opts progf datf = do
+        -- Go over all regular test programs
+        let isProg f = progf `isPrefixOf` f && ".in" `isSuffixOf` f
+        r1 <- forM (filter isProg allfiles) $ \prog -> do
+          -- Get the test num
+          let testnum = takeWhile (/='.') $ drop (length progf) prog
 
-    -- Go over the correct testdata files
-    let isCorrect f = ("testdata"++ testnum ++ ".in") `isPrefixOf` f
-    r2 <- forM (filter isCorrect allfiles) $ \dataf -> checkSuccess prog dataf
+          -- Go over the correct testdata files
+          let isCorrect f = (datf ++ testnum ++ ".in") `isPrefixOf` f
+          r2 <- forM (filter isCorrect allfiles) $ \dataf -> checkSuccess opts prog dataf
 
-    -- Go over the failure testdata files
-    let isFailure f = ("testdata"++ testnum ++ ".err") `isPrefixOf` f
-    r3 <- forM (filter isFailure allfiles) $ \dataf -> checkFailure prog dataf
+          -- Go over the failure testdata files
+          let isFailure f = (datf ++ testnum ++ ".err") `isPrefixOf` f
+          r3 <- forM (filter isFailure allfiles) $ \dataf -> checkFailure opts prog dataf
 
-    return $ r2 ++ r3
+          return $ r2 ++ r3
 
-  -- Go over all test programs that should fail
-  let isErrProg f = "testprog" `isPrefixOf` f && ".err" `isSuffixOf` f
-  r4 <- forM (filter isErrProg allfiles) $ \prog -> do
-    -- Get the test num
-    let testnum = takeWhile (/='.') $ drop (length "testprog") prog
+        -- Go over all test programs that should fail
+        let isErrProg f = progf `isPrefixOf` f && ".err" `isSuffixOf` f
+        r4 <- forM (filter isErrProg allfiles) $ \prog -> do
+          -- Get the test num
+          let testnum = takeWhile (/='.') $ drop (length "testprog") prog
 
-    -- Go over the correct testdata files
-    let isCorrect f = ("testdata"++ testnum ++ ".in") `isPrefixOf` f
-    forM (filter isCorrect allfiles) $ \dataf -> checkFailure prog dataf
+          -- Go over the correct testdata files
+          let isCorrect f = (datf ++ testnum ++ ".in") `isPrefixOf` f
+          forM (filter isCorrect allfiles) $ \dataf -> checkFailure opts prog dataf
+
+        -- Return all results
+        return $ concat $ r1 ++ r4
+
+  -- Run tests for normal progs
+  r1 <- tests defaultOptions "testprog" "testdata"
+
+  -- Run tests with -w options
+  r2 <- tests (defaultOptions { whitespace_ok = True }) "testwsprog" "testwsdata"
 
   -- Check that all tests succeeded
-  when (not $ and $ concat $ r1 ++ r4) $ exitFailure
+  when (not $ and $ r1 ++ r2) $ exitFailure
 
 -- | Run the prog on the given data file and ensure that it succeeded.
-checkSuccess :: FilePath -> FilePath -> IO Bool
-checkSuccess prog dataf = do
-  res <- checkRun prog dataf
+checkSuccess :: Options -> FilePath -> FilePath -> IO Bool
+checkSuccess opts prog dataf = do
+  res <- checkRun opts prog dataf
   case res of
     Right () -> return True
     Left _   -> do
       putStrLn $ "Running " ++ prog ++ " on " ++ dataf ++ " did not succeed"
       return False
 
 -- | Run the prog on the given data file and ensure that it failed
-checkFailure :: FilePath -> FilePath -> IO Bool
-checkFailure prog dataf = do
-  res <- checkRun prog dataf
+checkFailure :: Options -> FilePath -> FilePath -> IO Bool
+checkFailure opts prog dataf = do
+  res <- checkRun opts prog dataf
   case res of
     Left _   -> return True
     Right () -> do
       putStrLn $ "Running " ++ prog ++ " on " ++ dataf ++ " did not fail"
       return False
 
 -- | Run the prog on the given data file and return it's success or failure
-checkRun :: FilePath -> FilePath -> IO (Either String ())
-checkRun prog dataf = do
+checkRun :: Options -> FilePath -> FilePath -> IO (Either String ())
+checkRun opts prog dataf = do
   res <- try $ do
     ctd <- parseScript $ testsdir ++ prog
-    runCTDFile (interpret ctd) $ testsdir ++ dataf
+    runCTDFile opts (interpret ctd) $ testsdir ++ dataf
   case res of
     Left e -> return $ Left $ show (e :: SomeException)
     Right (Left e) -> return $ Left e

haskell_edsl/src/Checktestdata.hs

@@ -29,6 +29,7 @@ module Checktestdata (
 
 import Checktestdata.Core
 import Checktestdata.Derived
+import Checktestdata.Options
 
 import System.Environment ( getArgs, getProgName )
 import System.Exit        ( exitFailure, exitSuccess)
@@ -37,16 +38,17 @@ import System.IO          ( hPutStrLn, stderr)
 import qualified Data.ByteString.Char8 as BS
 
 -- | Run a checktestdata script on a file
-runCTDFile :: CTD a -> FilePath -> IO (Either String a)
-runCTDFile sc fp = do
+runCTDFile :: Options -> CTD a -> FilePath -> IO (Either String a)
+runCTDFile opts sc fp = do
   f <- BS.readFile fp
-  return $ runCTD sc f
+  return $ runCTD opts sc f
 
 -- | Main function that reads the commandline arguments
 --   and takes either a filename or reads from stdin.
 ctdMain :: CTD a -> IO ()
 ctdMain sc = do
   args <- getArgs
+  -- todo: add -w options to commandline arguments
   bs <- case args of
     []    -> BS.getContents
     ["-"] -> BS.getContents
@@ -57,7 +59,7 @@ ctdMain sc = do
       putStrLn $ "  " ++ nm ++ " data.in"
       putStrLn $ "  " ++ nm ++ " < data.in"
       exitFailure
-  case runCTD sc bs of
+  case runCTD defaultOptions sc bs of
     Left err -> do
       hPutStrLn stderr err
       exitFailure

haskell_edsl/src/Checktestdata/Core.hs

@@ -4,6 +4,7 @@ module Checktestdata.Core (
   -- * Core representation
   CTD,
   runCTD,
+  getOptions,
 
   -- * Primitives
   peekChar,
@@ -17,11 +18,15 @@ module Checktestdata.Core (
   regex,
   eof,
   isEOF,
+  greedyWhitespace,
+
+  -- * Helpers
+  isSpaceNoNewline
   ) where
 
-import Checktestdata.Options ( FloatOption (..) )
+import Checktestdata.Options ( FloatOption (..), Options (..) )
 
-import Data.Char             ( isDigit, toUpper )
+import Data.Char             ( isDigit, toUpper, isSpace )
 import Data.Maybe            ( fromMaybe, isJust )
 import Data.ByteString.Char8 ( ByteString )
 import qualified Data.ByteString.Char8          as BS
@@ -40,6 +45,8 @@ import Control.Monad.Trans.Either
 
 -- | Fields in the internal state
 data InternalState = InternalState {
+  -- | The options that were set
+  options :: Options,
   -- | The full input
   full_input :: ByteString,
   -- | The remaining part of the input
@@ -78,16 +85,22 @@ instance Monad CTD where
 -- | Run a checktestdata script on the given input and return either
 --   an error or the result of the script. The 'eof' combinator is appended
 --   to this script to ensure that the full input is consumed.
-runCTD :: CTD a -> ByteString -> Either String a
-runCTD sc inp = flip evalState initst $ runEitherT $ f $ sc <* eof where
+runCTD :: Options -> CTD a -> ByteString -> Either String a
+runCTD opts sc inp = flip evalState initst $ runEitherT $ f $ pr where
+  pr | whitespace_ok opts = greedyWhitespace *> sc <* greedyWhitespace <* eof
+     | otherwise          = sc <* eof
   initst :: InternalState
-  initst = InternalState inp inp 0
+  initst = InternalState opts inp inp 0
   f :: CTD a -> InternalMonad a
   f (Pure a)    = return a
   f (Apply a b) = f a <*> f b
   f (Bind a b)  = f a >>= f . b
   f (PrimOp g)  = g
 
+-- | Get the options that were set
+getOptions :: CTD Options
+getOptions = PrimOp $ get >>= return . options
+
 --------------------------------------------------------------------------------
 -- Error handling
 --------------------------------------------------------------------------------
@@ -302,3 +315,13 @@ getRemaining = do
   -- Update last_start, which we use for error messages
   put $ st { last_start = BS.length $ remaining st }
   return $ remaining st
+
+-- | Helper, check that the character is a space but not a newline
+isSpaceNoNewline :: Char -> Bool
+isSpaceNoNewline c = isSpace c && c /= '\n'
+
+-- | Greedily match all whitespace except newline characters
+greedyWhitespace :: CTD ()
+greedyWhitespace = PrimOp $ do
+  cs <- getRemaining
+  putRemaining $ BS.dropWhile isSpaceNoNewline cs

haskell_edsl/src/Checktestdata/Derived.hs

@@ -14,7 +14,7 @@ module Checktestdata.Derived (
   unique ) where
 
 import Checktestdata.Core
-import Checktestdata.Options ( FloatOption (..) )
+import Checktestdata.Options ( FloatOption (..), Options (..) )
 
 import Control.Monad      ( when )
 import qualified Data.Set as Set
@@ -73,16 +73,22 @@ showF x = show (fromRat x :: Double)
 -- | Check that the next character is a space.
 space :: CTD ()
 space = do
+  opts <- getOptions
   c <- nextChar
-  when (c /= ' ') $
+  when (c /= ' ' && (not (whitespace_ok opts && isSpaceNoNewline c))) $
     fail $ "Space expected"
+  when (whitespace_ok opts) $ greedyWhitespace
 
 -- | Check that the next character is a newline.
 newline :: CTD ()
 newline = do
+  opts <- getOptions
+  when (whitespace_ok opts) $ greedyWhitespace
   c <- nextChar
   when (c /= '\n') $
     fail $ "Newline expected"
+  when (whitespace_ok opts) $ greedyWhitespace
+
 
 -- | Match any of the given characters
 match :: String -> CTD Bool

haskell_edsl/src/Checktestdata/Options.hs

@@ -1,5 +1,7 @@
 module Checktestdata.Options (
   FloatOption (..),
+  Options (..),
+  defaultOptions
   ) where
 
 --------------------------------------------------------------------------------
@@ -13,3 +15,17 @@ data FloatOption
   | Scientific
   | Fixed
   deriving (Show)
+
+-- | The options the user can set via the commandline or programatically.
+data Options = Options {
+  -- | When set to 'True', whitespace changes are accepted, including heading
+  --   and training whitespace, but not newlines. Be careful: extra whitespace
+  --   matches greedily!
+  whitespace_ok :: Bool
+  }
+
+-- | The default values for 'Options'
+defaultOptions :: Options
+defaultOptions = Options {
+  whitespace_ok = False
+  }