1
2module Main(main) where
3
4import System.Environment
5import TagSoup.Sample
6import TagSoup.Test
7import TagSoup.Benchmark
8import Data.Char(toLower)
9
10
11helpMsg :: IO ()
12helpMsg = putStr $ unlines $
13    ["TagSoup, (C) Neil Mitchell 2006-2009"
14    ,""
15    ,"  tagsoup arguments"
16    ,""
17    ,"<url> may either be a local file, or a http[s]:// page"
18    ,""
19    ] ++ map f res
20    where
21        width = maximum $ map (length . fst) res
22        res = map g actions
23
24        g (nam,msg,Left  _) = (nam,msg)
25        g (nam,msg,Right _) = (nam ++ " <url>",msg)
26
27        f (lhs,rhs) = "  " ++ lhs ++ replicate (4 + width - length lhs) ' ' ++ rhs
28
29
30actions :: [(String, String, Either (IO ()) (String -> IO ()))]
31actions = [("test","Run the test suite",Left test)
32          ,("grab","Grab a web page",Right grab)
33          ,("parse","Parse a web page",Right parse)
34          ,("bench","Benchmark the parsing",Left time)
35          ,("benchfile","Benchmark the parsing of a file",Right timefile)
36          ,("validate","Validate a page",Right validate)
37          ,("lastmodifieddate","Get the wiki.haskell.org last modified date",Left haskellLastModifiedDateTime)
38          ,("spj","Simon Peyton Jones' papers",Left spjPapers)
39          ,("ndm","Neil Mitchell's papers",Left ndmPapers)
40          ,("time","Current time",Left currentTime)
41          ,("google","Google Tech News",Left googleTechNews)
42          ,("sequence","Creators on sequence.complete.org",Left rssCreators)
43          ,("table","Parse a table",Left $ print parseTable)
44          ,("help","This help message",Left helpMsg)
45          ]
46
47main :: IO ()
48main = do
49    args <- getArgs
50    case (args, lookup (map toLower $ head args) $ map (\(a,_,c) -> (a,c)) actions) of
51        ([],_) -> do
52            putStrLn "No arguments specifying, defaulting to test"
53            helpMsg
54            putStrLn $ replicate 70 '-'
55            test
56        (x:_,Nothing) -> putStrLn ("Error: unknown command " ++ x) >> helpMsg
57        ([_],Just (Left a)) -> a
58        (x:xs,Just (Left a)) -> do
59            putStrLn $ "Warning: expected no arguments to " ++ x ++ " but got: " ++ unwords xs
60            a
61        ([_,y],Just (Right a)) -> a y
62        (x:xs,Just (Right _)) -> do
63            putStrLn $ "Error: expected exactly one argument to " ++ x ++ " but got: " ++ unwords xs
64            helpMsg
65