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