1{-# LANGUAGE GeneralizedNewtypeDeriving #-} 2{-# LANGUAGE MonoLocalBinds #-} 3 4module Main where 5 6import Control.Applicative as App 7import Control.Monad 8import qualified Control.Monad.Fail as Fail 9import Data.Array 10import qualified Data.ByteString as BS 11import qualified Data.ByteString.UTF8 as UTF8 12import Data.List 13import Data.String 14import Data.Typeable 15import Data.Version () 16import System.Directory (getDirectoryContents) 17import System.Environment 18import System.Exit 19import System.FilePath ((</>)) 20import Text.Regex.Base 21 22import qualified Text.Regex.TDFA as TDFA 23 24default(Int) 25 26type RSource = String 27type RType = String -- can be changed to any Extract instance 28newtype RegexSource = RegexSource {unSource :: RSource} deriving Show 29newtype RegexStringOf a = RegexString {unString :: a} deriving Show 30type RegexString = RegexStringOf RType 31 32dictionary :: [Char] 33dictionary = ['a'..'c']++['A'..'C']++"_" 34 35 36type A = Array Int (Int,Int) 37 38maxItems :: Int 39maxItems=100 40 41testOne :: t -> (t -> t1 -> Array Int (Int, Int)) -> t1 -> String 42testOne s op r = 43 let foo :: String 44 foo = concatMap (\(o,l) -> show (o,(o+l))) (take maxItems $ elems (op s r :: Array Int (Int,Int))) 45 in if null foo then "NOMATCH" else foo 46 47testOne' :: A -> String 48testOne' input = 49 let foo :: String 50 foo = concatMap (\(o,l) -> show (o,(o+l))) (take maxItems $ elems input) 51 in if null foo then "NOMATCH" else foo 52 53toTest :: String -> (Int,String,String,String) 54toTest line = let [n,regex,input,output] = words line 55 noQ [] = [] 56 noQ ('?':xs) = '-':'1':noQ xs 57 noQ (x:xs) = x:noQ xs 58 input' = if input == "NULL" then "" else unN input 59 in (read n,regex,input',noQ output) 60 61toTest' :: String -> String -> (String,(Int,String,String,String)) 62toTest' oldRegex line = 63 let [n,regex,input,output] = words line 64 noQ [] = [] 65 noQ ('?':xs) = '-':'1':noQ xs 66 noQ (x:xs) = x:noQ xs 67 input' = if input == "NULL" then "" else input 68 regex' = if regex == "SAME" then oldRegex else regex 69 in (regex',(read n,regex',input',noQ output)) 70 71load,load' :: String -> [(Int, String, String, String)] 72load = map toTest . lines 73load' = snd . mapAccumL toTest' "X_X_X_" . lines 74 75checkTest :: PFT A -> (Int,String,String,String) -> IO [Int] 76checkTest opM (n,regex,input,output) = do 77 let Result output'e = opM input regex 78 p = putStrLn 79 p "" 80 case output'e of 81 Left msg -> do 82 p ("############################# Unexpected Error # "++show n ++ " #############################" ) 83 p ("Searched text: "++show input) 84 p ("Regex pattern: "++show regex) 85 p ("Expected output: "++show output) 86 p ("Error message: "++msg) 87 return [n] 88 Right output'a -> do 89 let output' = testOne' output'a 90 case (n<0 , output==output') of 91 (False,True) -> p ("Expected Pass #"++show n) 92 (False,False) -> p ("############################# Unexpected Fail # "++show n ++ " #############################" ) 93 (True,True) -> p ("############################# Unexpected Pass # "++show n ++ " #############################" ) 94 (True,False) -> p ("Expected Fail #"++show n) 95 if (output == output') 96 then do p ("text and pattern: "++show input) 97 p ("Regex pattern: "++show regex) 98 p ("Outputs agree: "++show output) 99 return (if n<0 then [n] else []) 100 else do p "" 101 p ("Searched text: "++show input) 102 p ("Regex pattern: "++show regex) 103 p ("Expected output: "++show output) 104 p ("Actual result : "++show output') 105 return (if n<0 then [] else [n]) 106 107checkFile :: (RType -> RSource -> Result A) -> (FilePath, String) -> IO (FilePath,[Int]) 108checkFile opM (filepath, contents) = do 109 putStrLn $ "\nUsing Tests from: "++filepath 110 vals <- liftM concat (mapM (checkTest opM) (load' contents)) 111 return (filepath,vals) 112 113checkTests :: (RType -> RSource -> Result A) -> [(FilePath,String)] -> IO [(String, [Int])] 114checkTests opM testCases = mapM (checkFile opM) testCases 115 116readTestCases :: FilePath -> IO [(String, String)] 117readTestCases folder = do 118 fns <- filter (isSuffixOf ".txt") <$> getDirectoryContents folder 119 when (null fns) $ 120 fail ("readTestCases: No test-cases found in " ++ show folder) 121 forM (sort fns) $ \fn -> do 122 bs <- BS.readFile (folder </> fn) 123 return (fn, UTF8.toString bs) 124 125newtype Result a = Result (Either String a) 126 deriving (Eq, Show, Functor, App.Applicative, Monad) 127 128instance Fail.MonadFail Result where 129 fail = Result . Left 130 131type PFT a = RegexContext TDFA.Regex RType a => RType -> RSource -> Result a 132 133posix :: PFT a 134posix x reg = 135 let q :: Result TDFA.Regex 136 q = makeRegexOptsM (defaultCompOpt { TDFA.caseSensitive = False}) defaultExecOpt reg 137 in q >>= \ s -> return (match s x) 138 139unN :: String -> String 140unN ('\\':'n':xs) = '\n':unN xs 141unN (x:xs) = x:unN xs 142unN [] = [] 143 144manual :: [String] -> IO () 145manual [sIn,rIn] = do 146 let s :: RType 147 r :: String 148 s = fromString (unN sIn) 149 r = (unN rIn) 150 -- first match 151 let r1 :: TDFA.Regex 152 r1 = makeRegex r 153 let b1u@(_,_b1s,_,_)=(match r1 s :: (RType,RType,RType,[RType])) 154 putStrLn ("Searched text: "++show s) 155 putStrLn ("Regex pattern: "++show r) 156 print b1u 157 -- multiple matches and counting 158 let b1 = (match r1 s :: [MatchArray]) 159 c1 = (match r1 s :: Int) 160 putStrLn $ "Count of matches = "++show c1 161 putStrLn $ "Matches found = "++show (length b1) 162 mapM_ (putStrLn . testOne') b1 163manual _ = error "wrong arguments to regex-posix-unittest's manual function" 164 165main :: IO () 166main = do 167 putStr "Testing Text.Regex.TDFA version: " 168 print TDFA.getVersion_Text_Regex_TDFA 169 a <- getArgs 170 if length a == 2 171 then manual a 172 else do 173 putStrLn $ "Explanation and discussion of these tests on the wiki at http://www.haskell.org/haskellwiki/Regex_Posix including comparing results from different operating systems" 174 putStrLn $ "Questions about this package to the author at email <TextRegexLazy@personal.mightyreason.com>" 175 putStrLn $ "The type of both the pattern and test is " ++ show (typeOf (undefined :: RType)) 176 putStrLn $ "Without extactly two arguments:" 177 putStrLn $ " This program runs all test files listed in test/data-dir/test-manifest.txt" 178 putStrLn $ " Lines with negative number are expected to fail, others are expected to pass." 179 putStrLn $ "With exactly two arguments:" 180 putStrLn $ " The first argument is the text to be searched." 181 putStrLn $ " The second argument is the regular expression pattern to search with." 182 vals <- checkTests posix =<< readTestCases ("test" </> "cases") 183 if null (concatMap snd vals) 184 then putStrLn "\nWow, all the tests passed!" 185 else do 186 putStrLn $ "\nBoo, tests failed!\n"++unlines (map show vals) 187 exitFailure 188 189{- 190-- for TRE 191posix x r = let q :: Posix.Regex 192 q = makeRegexOpts (defaultCompOpt .|. Posix.compRightAssoc .|. Posix.compIgnoreCase) defaultExecOpt r 193 in match q x 194 195tdfa x r = let q :: TDFA.Wrap.Regex 196 q = makeRegexOpts (defaultCompOpt { TDFA.Wrap.caseSensitive = False 197 , TDFA.Wrap.rightAssoc = True }) defaultExecOpt r 198 in match q x 199 200tdfa2 x r = let q :: TDFA2.Wrap.Regex 201 q = makeRegexOpts (defaultCompOpt { TDFA2.Wrap.caseSensitive = False 202 , TDFA2.Wrap.rightAssoc = True }) defaultExecOpt r 203 in match q x 204-} 205