-
Notifications
You must be signed in to change notification settings - Fork 12
/
Copy pathMain.hs
102 lines (83 loc) · 3.26 KB
/
Main.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
module Main(main) where
import System.Console.CmdArgs.Test.All
import qualified System.Console.CmdArgs.Test.Implicit.Diffy as D
import qualified System.Console.CmdArgs.Test.Implicit.HLint as H
import qualified System.Console.CmdArgs.Test.Implicit.Maker as M
import System.Console.CmdArgs.Implicit(CmdArgs(..))
import System.Console.CmdArgs.Explicit
import System.Console.CmdArgs.Text
import System.Console.CmdArgs.Default
import Control.Monad
import Data.List
import Data.Maybe
import System.IO
data Args = Test
| Generate
| Help HelpFormat TextFormat
| Version
| Demo Demo
args = (modes "cmdargs" (Help def def) "CmdArgs demo program" ms){modeGroupFlags = toGroup flags}
where
flags = [flagHelpFormat $ \a b _ -> Help a b
,flagVersion $ const Version
,flagNone ["test","t"] (const Test) "Run the tests"
,flagNone ["generate","g"] (const Generate) "Generate the manual"]
ms = map (remap Demo (\(Demo x) -> (x,Demo))) demo
main = do
x <- processArgs args
let ver = "CmdArgs demo program, (C) Neil Mitchell"
case x of
Version -> putStrLn ver
Help hlp txt -> do
let xs = showText txt $ helpText [ver] hlp args
putStrLn xs
when (hlp == HelpFormatBash) $ do
writeFileBinary "cmdargs.bash_comp" xs
putStrLn "# Output written to cmdargs.bash_comp"
Test -> test
Generate -> generateManual
Demo x -> runDemo x
writeFileBinary :: FilePath -> String -> IO ()
writeFileBinary file x = do
h <- openBinaryFile file WriteMode
hPutStr h x
hClose h
---------------------------------------------------------------------
-- GENERATE MANUAL
generateManual :: IO ()
generateManual = do
src <- readFile "cmdargs.htm"
() <- length src `seq` return ()
res <- fmap unlines $ f $ lines src
() <- length res `seq` return ()
h <- openBinaryFile "cmdargs.htm" WriteMode
hPutStr h res
hClose h
where
f (x:xs) | "<!-- BEGIN " `isPrefixOf` x = do
ys <- generateChunk $ init $ drop 2 $ words x
zs <- f $ tail $ dropWhile (not . isPrefixOf "<!-- END") xs
return $ x : ys ++ ["<!-- END -->"] ++ zs
f [] = return []
f (x:xs) = fmap (x:) $ f xs
generateChunk :: [String] -> IO [String]
generateChunk ["help",x] = return $ case x of
"hlint" -> f H.mode
"diffy" -> f D.mode
"maker" -> f M.mode
where f = lines . fromJust . cmdArgsHelp . flip processValue ["--help=html"]
generateChunk ["code",x] = do
src <- readFile $ "System/Console/CmdArgs/Test/Implicit/" ++ x ++ ".hs"
return $ ["<pre>"] ++ recode (lines src) ++ ["</pre>"]
recode :: [String] -> [String]
recode = concatMap f . blanks . takeWhile (/= "-- STOP MANUAL")
where
blanks ("":"":xs) = blanks ("":xs)
blanks [""] = []
blanks [] = []
blanks (x:xs) = x : blanks xs
f x | x == "import System.Console.CmdArgs.Test.Implicit.Util" = []
| "{-# OPTIONS_GHC " `isPrefixOf` x = []
| "{-# LANGUAGE " `isPrefixOf` x = ["{-# LANGUAGE DeriveDataTypeable #-}"]
| "module System.Console.CmdArgs.Test.Implicit." `isPrefixOf` x = ["module " ++ drop 44 x]
f x = [x]