1{-# LANGUAGE PatternGuards #-}
2
3module System.Console.CmdArgs.Test.Implicit.Util(
4    module System.Console.CmdArgs.Test.Implicit.Util,
5    Complete(..)
6    ) where
7
8import System.Console.CmdArgs.Implicit
9import System.Console.CmdArgs.Explicit
10import System.Console.CmdArgs.Test.Util
11import Control.Exception
12import Data.Char
13import Data.List
14import Data.Maybe
15
16toDemo :: (Typeable a, Show a) => Mode (CmdArgs a) -> Mode Demo
17toDemo = newDemo $ \x -> cmdArgsApply x >>= print
18
19
20invalid :: Data a => (() -> a) -> IO ()
21invalid a = do
22    res <- try $ evaluate $ length $ show $ cmdArgsMode $ a ()
23    case res of
24        Left (ErrorCall _) -> success
25        Right _ -> failure "Expected exception" []
26
27
28data Tester a = Tester
29    {(===) :: [String] -> a -> IO ()
30    ,fails :: [String] -> IO ()
31    ,isHelp :: [String] -> [String] -> IO ()
32    ,isHelpNot :: [String] -> [String] -> IO ()
33    ,isVersion :: [String] -> String -> IO ()
34    ,isVerbosity :: [String] -> Verbosity -> IO ()
35    ,completion :: [String] -> (Int,Int) -> [Complete] -> IO ()
36    }
37
38testers :: (Show a, Eq a) => String -> [Mode (CmdArgs a)] -> Tester a
39testers name = foldr1 f . map (tester name)
40    where
41        f (Tester x1 x2 x3 x4 x5 x6 x7) (Tester y1 y2 y3 y4 y5 y6 y7) =
42            Tester (f2 x1 y1) (f1 x2 y2) (f2 x3 y3) (f2 x4 y4) (f2 x5 y5) (f2 x6 y6) (f3 x7 y7)
43        f1 x y a = x a >> y a
44        f2 x y a b = x a b >> y a b
45        f3 x y a b c = x a b c >> y a b c
46
47
48tester :: (Show a, Eq a) => String -> Mode (CmdArgs a) -> Tester a
49tester name m = Tester (===) fails isHelp isHelpNot isVersion isVerbosity completion
50    where
51        failed msg args xs = failure msg $ ("Name","Implicit "++name):("Args",show args):xs
52
53        f args cont = case process m args of
54            Left x -> cont $ Left x
55            Right x -> cont $ Right x
56{-
57            o@(Right x)
58                | x2 == Right x -> cont $ Right x
59                | otherwise -> do
60                    failed "Reform failed" args [("Reformed",show args2),("Expected",show o),("Got",show x2)]
61                    error "failure!"
62                    cont $ Right x
63                where args2 = cmdArgsReform m x
64                      x2 = process m args2
65-}
66
67        (===) args v = f args $ \x -> case x of
68            Left x -> failed "Failed when should have succeeded" args [("Error",x)]
69            Right x | cmdArgsValue x /= v -> failed "Wrong parse" args [("Expected",show v),("Got",show x)]
70                    | otherwise -> success
71
72        fails args = f args $ \x -> case x of
73            Left x -> success
74            Right x -> failed "Succeeded 52 should have failed" args [("Result",show x)]
75
76        showGot sel x = [("Got",show got) | Right x <- [x], Just got <- [sel x]]
77
78        isHelp args want = f args $ \x -> case x of
79            Right x | Just got <- cmdArgsHelp x, match want (lines got) -> success
80            _ -> failed "Failed on isHelp" args $
81                ("Want",show want) : showGot cmdArgsHelp x
82
83        isHelpNot args want = f args $ \x -> case x of
84            Right x | Just got <- cmdArgsHelp x, not $ match want (lines got) -> success
85            _ -> failed "Failed on isHelpNot" args []
86
87        isVersion args want = f args $ \x -> case x of
88            Right x | Just got <- cmdArgsVersion x, (want ++ "\n") == got -> success
89            _ -> failed "Failed on isVersion" args $
90                ("Want",show $ want ++ "\n") : showGot cmdArgsVersion x
91
92        isVerbosity args v = f args $ \x -> case x of
93            Right x | fromMaybe Normal (cmdArgsVerbosity x) == v -> success
94            _ -> failed "Failed on isVerbosity" args []
95
96        completion args pos res
97            | res == ans = success
98            | otherwise = failed "Failed on completion" args [("Position",show pos),("Want",shw res),("Got",shw ans)]
99            where ans = complete m args pos
100                  shw = intercalate ", " . lines . show
101
102
103match :: [String] -> [String] -> Bool
104match want got = any f $ tails got
105    where f xs = length xs >= length want && and (zipWith matchLine want xs)
106
107
108matchLine :: String -> String -> Bool
109matchLine (' ':' ':x) (' ':' ':y) = matchLine (dropWhile isSpace x) (dropWhile isSpace y)
110matchLine (x:xs) (y:ys) | x == y = matchLine xs ys
111matchLine [] [] = True
112matchLine _ _ = False
113
114