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