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
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
{- |
    Module      :  $Header$
    Description :  Casc options

    This module defines data structures holding options for casc
    and utility functions for parsing the command line arguments.
-}






module Opts where

import GetOpt
import List   (maximum, intercalate)
import System (getArgs, getProgName)


-- |Retrieve the 'Options'
getCheckOpts :: IO (Options, [String], [String])
getCheckOpts = do
  args <- getArgs
  let (opts, files, errs) = parseOpts args
  return (opts, files, errs)

-- -----------------------------------------------------------------------------
-- Options
-- -----------------------------------------------------------------------------

-- |Casc options
data Options = Options
  { optMode       :: Mode       -- ^ Modus operandi
  , optVerbosity  :: Verbosity  -- ^ Verbosity level
  , optRecursive  :: Bool       -- ^ Check hierarchical modules in subdirs?
  , optColor      :: ColMode
  }

data ColMode
  = ColOn
  | ColOff
  | ColAuto

-- |Modus operandi of the program
data Mode
  = ModeHelp    -- ^ Show help information and exit
  | ModeVersion -- ^ Show version and exit
  | ModeCheck   -- ^ Check files

-- |Verbosity level
data Verbosity
  = VerbQuiet  -- ^ be quiet
  | VerbStatus -- ^ show status of check
  | VerbDebug  -- ^ show debug options

-- |All available options
options :: [OptDescr (OptErr -> OptErr)]
options =
  [ Option "h" ["help"]
      (NoArg (onOpts $ \ opts -> opts { optMode = ModeHelp }))
      "display this help and exit"
  , Option "V" ["version"]
      (NoArg (onOpts $ \ opts -> opts { optMode = ModeVersion }))
      "show the version number and exit"
  , mkOptDescr onOpts "v" ["verbosity"] "n" "verbosity level" verbDescriptions
  , Option "q"  ["quiet"]
      (NoArg (onOpts $ \ opts -> opts { optVerbosity = VerbQuiet } ))
      "set verbosity level to quiet"
  , Option "d" ["debug"]
      (NoArg (onOpts $ \ opts -> opts { optVerbosity = VerbDebug } ))
      "set verbosity level to debug"
  , Option "r" ["recursive"]
      (NoArg (onOpts $ \ opts -> opts { optRecursive = True }))
      "recursively check hierarchical modules in subdirectories"
  , mkOptDescr onOpts "c" ["color"] "n" "color level" colDescriptions
  ]

colors :: [(ColMode, String, String)]
colors = [ ( ColOff,  "0", "off"  )
         , ( ColOn,   "1", "on"   )
         , ( ColAuto, "2", "auto" )
         ]

-- |Description and flag of verbosities
verbosities :: [(Verbosity, String, String)]
verbosities = [ ( VerbQuiet,  "0", "quiet" )
              , ( VerbStatus, "1", "status")
              , ( VerbDebug,  "2", "debug" )
              ]

-- |Default casc options
defaultOptions :: Options
defaultOptions = Options
  { optMode       = ModeCheck
  , optVerbosity  = VerbStatus
  , optRecursive  = False
  , optColor      = ColAuto
  }


-- -----------------------------------------------------------------------------
-- Parsing of the command line options
-- -----------------------------------------------------------------------------
-- |Option error
type OptErr = (Options, [String])

-- |An 'OptErrTable' consists of a list of entries of the following form:
--   * a flag to be recognized on the command line
--   * an explanation text for the usage information
--   * a modification funtion adjusting the options structure
-- The type is parametric about the option's type to adjust.
type OptErrTable opt = [(String, String, opt -> opt)]

-- |Use function on options
onOpts :: (Options -> Options) -> OptErr -> OptErr
onOpts f (opts, errs) = (f opts, errs)

-- |Add error
addErr :: String -> OptErr -> OptErr
addErr err (opts, errs) = (opts, errs ++ [err])

-- |Make option description
mkOptDescr :: ((opt -> opt) -> OptErr -> OptErr)
           -> String -> [String] -> String -> String -> OptErrTable opt
           -> OptDescr (OptErr -> OptErr)
mkOptDescr lift flags longFlags arg what tbl
  = Option flags
           longFlags
           (ReqArg (parseOptErr lift what tbl) arg)
           ("set " ++ what ++ " `" ++ arg ++ "', where `" ++ arg
                   ++ "' is one of\n" ++ renderOptErrTable tbl)

-- |Parse option errors
parseOptErr :: ((opt -> opt) -> OptErr -> OptErr)
            -> String -> OptErrTable opt -> String -> OptErr -> OptErr
parseOptErr lift what table opt
  = case lookup3 opt table of
      Just f  -> lift f
      Nothing -> addErr $ "unrecognized " ++ what ++ '`' : opt ++ "'\n"
    where
      lookup3 _ []                  = Nothing
      lookup3 k ((k', _, v2) : kvs)
        | k == k'                   = Just v2
        | otherwise                 = lookup3 k kvs

-- |Render option error table
renderOptErrTable :: OptErrTable opt -> String
renderOptErrTable ds
  = intercalate "\n" $ map (\(k, d, _) -> "  " ++ rpad maxLen k ++ ": " ++ d) ds
    where
      maxLen = maximum $ map (\(k, _, _) -> length k) ds
      rpad n x = x ++ replicate (n - length x) ' '

-- |Verbosity description
verbDescriptions :: OptErrTable Options
verbDescriptions = map toDescr verbosities
  where
  toDescr (flag, name, desc)
    = (name, desc, \ opts -> opts { optVerbosity = flag })

-- |Color description
colDescriptions :: OptErrTable Options
colDescriptions = map toDescr colors
  where
  toDescr (flag, name, desc)
    = (name, desc, \ opts -> opts { optColor = flag })

-- |Parse the command line arguments
parseOpts :: [String] -> (Options, [String], [String])
parseOpts = updateOpts defaultOptions

-- |Update options
updateOpts :: Options -> [String] -> (Options, [String], [String])
updateOpts opts args = (opts', files, errs ++ errs2)
  where
    (opts', errs2) = foldl (flip ($)) (opts, []) optErrs
    (optErrs, files, errs) = getOpt Permute options args

-- |Print the usage information of the command line tool.
usage :: String -> String
usage _ = usageInfo header options
 where
  header = "Usage: curry style [OPTIONS] ... MODULES ... DIRECTORIES ...\n"