{-# LANGUAGE LambdaCase, TupleSections #-} import Text.Parsec import Text.Parsec.String import Control.Arrow ( second ) -- Bounds (N, +N, -N) data Bound = Bound Ordering Int -- EQ = exactly N, LT = -N, GT = +N deriving (Eq, Show) -- File name patterns type Pattern = [PatternAtom] data PatternAtom = Ch Char | AnyChar -- ? | AnyString -- * deriving (Eq, Show) -- Times data TimeField = AccessTime | ModificationTime deriving (Eq, Show) data TimeUnit = Day | Minute deriving (Eq, Show) -- Misc. parameters of predicates data PathPredType = OnlyName | WholePath deriving (Eq, Show) data PermissionType = RPerm | WPerm | XPerm deriving (Eq, Show) data FileType = Regular | Directory | Symlink -- parameters f, d and l of -type deriving (Eq, Show) data SizeUnit = Byte | Word | Block | Kibi | Mebi | Gibi deriving (Eq, Show, Ord) -- Expressions data Expression = PathPred PathPredType Pattern | TimePred TimeField TimeUnit Bound | PermPred PermissionType | SizePred Bound SizeUnit | TypePred FileType | Prune | Print | Not Expression | And [Expression] | Or [Expression] deriving (Eq, Show) -- All options data Options = Options { rootPaths :: [FilePath] , depthFlag :: Bool , minDepth :: Maybe Int , maxDepth :: Maybe Int , fileExpr :: Expression } deriving (Eq, Show) -- The top-level parser for you to implement. optionsParser :: Parser Options optionsParser = undefined -- ------------------------------------------------------------------------- -- -- TESTS -- -- ------------------------------------------------------------------------- -- -- Set the boolean to False to skip testing these cases. It's better than -- commenting it out, because the test runner will remind you that you have -- skipped the test, so that you don't forget to re-enable it once you've -- implemented the functionality. t_enabledTests :: [TGroup] t_enabledTests = [ (t_basic True) , (t_extra True) , (t_recursive True) , (t_wrong True) , (t_global True) ] -- Feel free to use this during your own interactive testing spacesToNulls :: String -> String spacesToNulls = map (\c -> if c == ' ' then '\NUL' else c) . (\xs -> if null xs then [] else xs ++ " ") -- Test cases are a list of pairs (input value, expected result). Do add your -- own! It is much more comfortable than putting it in the interpreter all over -- again and checking whether the result is alright. t_basic, t_extra, t_recursive, t_wrong, t_global :: Bool -> TGroup t_basic = t_parse "basic" fileExpr $ second Just <$> [ ( "", And [] ) , ( "-print", Print ) , ( "-prune", Prune ) , ( "-readable", PermPred RPerm ) , ( "-writable", PermPred WPerm ) , ( "-executable", PermPred XPerm ) , ( "-type f", TypePred Regular ) , ( "-atime 20", TimePred AccessTime Day (Bound EQ 20) ) , ( "-amin +20", TimePred AccessTime Minute (Bound GT 20) ) , ( "-mtime 20", TimePred ModificationTime Day (Bound EQ 20) ) , ( "-mmin -20", TimePred ModificationTime Minute (Bound LT 20) ) , ( "-size 20", SizePred (Bound EQ 20) Block ) , ( "-name ", PathPred OnlyName [] ) , ( "-path ", PathPred WholePath [] ) ] t_extra = t_parse "extra" fileExpr $ second Just <$> [ ( "-type l,d,f", Or [TypePred Symlink, TypePred Directory, TypePred Regular] ) , ( "-size 1c", SizePred (Bound EQ 1) Byte ) , ( "-size +40w", SizePred (Bound GT 40) Word ) , ( "-size 0b", SizePred (Bound EQ 0) Block ) , ( "-size -30k", SizePred (Bound LT 30) Kibi ) , ( "-size 099M", SizePred (Bound EQ 99) Mebi ) , ( "-size 030G", SizePred (Bound EQ 30) Gibi ) , ( "-name *.?s", PathPred OnlyName [AnyString, Ch '.', AnyChar, Ch 's'] ) , ( "-name a??b", PathPred OnlyName [Ch 'a', AnyChar, AnyChar, Ch 'b'] ) , ( "-name a**b", PathPred OnlyName [Ch 'a', AnyString, Ch 'b'] ) , ( "-name *??*", PathPred OnlyName [AnyString, AnyChar, AnyChar, AnyString] ) , ( "-path -and", PathPred WholePath [Ch '-', Ch 'a', Ch 'n', Ch 'd'] ) , ( "-path \\\\", PathPred WholePath [Ch '\\'] ) , ( "-path \\**", PathPred WholePath [Ch '*', AnyString] ) , ( "-path \\??", PathPred WholePath [Ch '?', AnyChar] ) ] t_recursive = t_parse "recursive" fileExpr $ second Just <$> [ ( "! -prune", Not Prune ) , ( "-not -prune", Not Prune ) , ( "-not -not -prune", Prune ) , ( "-prune -print", And [Prune, Print] ) , ( "-prune -a -print", And [Prune, Print] ) , ( "-prune -and -print", And [Prune, Print] ) , ( "-prune -o -print", Or [Prune, Print]) , ( "-type f -or -type f", Or [TypePred Regular, TypePred Regular]) , ( "-not -prune -print", And [Not Prune, Print] ) , ( "( -print )", Print ) , ( "( ( -print ) )", Print ) , ( "( -print ) -a -prune", And [Print, Prune] ) , ( "( -print ) -o -prune", Or [Print, Prune] ) , ( "( -print -prune ) -a -print", And [Print, Prune, Print] ) , ( "-prune -o ( -print -o -prune ) -o -print", Or [Prune, Print, Prune, Print] ) , ( "-prune -a ( -print -o -prune ) -print", And [Prune, Or [Print, Prune], Print] ) , ( "-prune -o -print ! -prune -or -print", Or [Prune, And [Print, Not Prune], Print] ) , ( "-print -prune -o ! -print ! -prune", Or [And [Print, Prune], And[Not Print, Not Prune]] ) ] t_wrong = t_parse "incorrect" id $ (, Nothing) <$> [ "--print", "-no-print", "-prunes", "-print foo", "-prune " , "-type f,", "-type ,f", "-type f,d,f", "-type " , "-size 30m", "-size 30g", "-size 30K", "-size 2W", "-size 2B", "-size 1C" , "-size ", "-size", "-size M", "-size -M", "-size +M", "-size foo" , "-name \\", "-name a\\bc", "-path a\\ b", "-name a b", "-prune !! -print" , "( -print", "-print )", "-prune (-print)", "( )", "-print ( ) -print" , "-print -prune", "( -prune ( ) -print )", "-print (", ") -print" , "!", "-not", "-a", "-and", "-o", "-or", "-print -a", "-a -print" , "-print -o", "-o -print", " -o -print", "-print -o ", "-", "--" ] t_global = t_parse "global" id $ second Just <$> [ ( "!! -print", Options ["!!"] False Nothing Nothing Print ) , ( "*\\*", Options ["*\\*"] False Nothing Nothing (And []) ) , ( "", Options ["."] False Nothing Nothing (And []) ) , ( " a -print", Options ["", "a"] False Nothing Nothing Print ) , ( "./-depth -prune", Options ["./-depth"] False Nothing Nothing Prune ) , ( "-depth -depth", Options ["."] True Nothing Nothing (And []) ) , ( "-mindepth 6 -maxdepth 07 -mindepth 08", Options ["."] False (Just 8) (Just 7) (And []) ) , ( "-maxdepth 6 -mindepth 07 -maxdepth 08 -prune -print", Options ["."] False (Just 7) (Just 8) (And [Prune, Print]) ) , ( "a b (file) -depth -print", Options ["a", "b", "(file)"] True Nothing Nothing Print ) ] -- ------------------------------------------------------------------------- -- -- MAGIC -- -- ------------------------------------------------------------------------- -- -- You can safely ignore the rest of the file. type TGroup = IO () t_parse :: (Eq a, Show a) => String -> (Options -> a) -> [(String, Maybe a)] -> Bool -> IO () t_parse name extractor cases enabled = putStr (name ++ ": ") >> go' where go' = if enabled then go 0 cases else putStrLn "SKIPPED!" go n [] = putStrLn . unwords $ ["all", show n, "tests passed."] go n ((c,e):cs) = let r' = parse optionsParser name (spacesToNulls c) r = either (const Nothing) (Just . extractor) r' in if r == e then go (n + 1) cs else putStrLn . unlines $ ["FAILED!" ,"Input: " ++ show c ,"Expected: " ++ case e of Just e -> show e _ -> "an error" ,"But got: " ++ either show (show . extractor) r' ] main :: IO () main = sequence_ t_enabledTests