CompilerOpts.hs 18.7 KB
Newer Older
Björn Peemöller 's avatar
Björn Peemöller committed
1
2
3
{- |
    Module      :  $Header$
    Description :  Compiler options
Björn Peemöller 's avatar
Björn Peemöller committed
4
5
    Copyright   :  (c) 2005        Martin Engelke
                       2007        Sebastian Fischer
6
                       2011 - 2014 Björn Peemöller
Björn Peemöller 's avatar
Björn Peemöller committed
7
    License     :  OtherLicense
8

Björn Peemöller 's avatar
Björn Peemöller committed
9
10
11
12
    Maintainer  :  bjp@informatik.uni-kiel.de
    Stability   :  experimental
    Portability :  portable

Björn Peemöller 's avatar
Björn Peemöller committed
13
14
    This module defines data structures holding options for the
    compilation of Curry programs, and utility functions for printing
15
    help information as well as parsing the command line arguments.
16
17
-}
module CompilerOpts
18
19
20
21
  ( Options (..), PrepOpts (..), WarnOpts (..), DebugOpts (..)
  , CymakeMode (..), Verbosity (..), TargetType (..)
  , WarnFlag (..), KnownExtension (..), DumpLevel (..), dumpLevel
  , defaultOptions, defaultPrepOpts, defaultWarnOpts, defaultDebugOpts
22
  , getCompilerOpts, updateOpts, usage
23
24
  ) where

Björn Peemöller 's avatar
Björn Peemöller committed
25
import Data.List             (intercalate, nub)
26
import Data.Maybe            (isJust)
27
import System.Console.GetOpt
Björn Peemöller 's avatar
Björn Peemöller committed
28
import System.Environment    (getArgs, getProgName)
29
30
import System.FilePath
  (addTrailingPathSeparator, normalise, splitSearchPath)
31
32

import Curry.Files.Filenames (currySubdir)
33
import Curry.Syntax.Extension
34

35
36
37
38
-- -----------------------------------------------------------------------------
-- Option data structures
-- -----------------------------------------------------------------------------

39
-- |Compiler options
40
41
data Options = Options
  -- general
42
43
  { optMode         :: CymakeMode       -- ^ modus operandi
  , optVerbosity    :: Verbosity        -- ^ verbosity level
44
  -- compilation
45
  , optForce        :: Bool             -- ^ force (re-)compilation of target
46
47
48
49
  , optLibraryPaths :: [FilePath]       -- ^ directories to search in
                                        --   for libraries
  , optImportPaths  :: [FilePath]       -- ^ directories to search in
                                        --   for imports
50
  , optHtmlDir      :: Maybe FilePath   -- ^ output directory for HTML
51
52
  , optUseSubdir    :: Bool             -- ^ use subdir for output?
  , optInterface    :: Bool             -- ^ create a FlatCurry interface file?
53
54
  , optPrepOpts     :: PrepOpts         -- ^ preprocessor options
  , optWarnOpts     :: WarnOpts         -- ^ warning options
55
56
  , optTargetTypes  :: [TargetType]     -- ^ what to generate
  , optExtensions   :: [KnownExtension] -- ^ enabled language extensions
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
  , optDebugOpts    :: DebugOpts        -- ^ debug options
  } deriving Show

-- |Preprocessor options
data PrepOpts = PrepOpts
  { ppPreprocess :: Bool      -- ^ apply custom preprocessor
  , ppCmd        :: String    -- ^ preprocessor command
  , ppOpts       :: [String]  -- ^ preprocessor options
  } deriving Show

-- |Warning options
data WarnOpts = WarnOpts
  { wnWarn         :: Bool       -- ^ show warnings? (legacy option)
  , wnWarnFlags    :: [WarnFlag] -- ^ Warnings flags (see below)
  , wnWarnAsError  :: Bool       -- ^ Should warnings be treated as errors?
  } deriving Show

-- |Debug options
data DebugOpts = DebugOpts
  { dbDumpLevels :: [DumpLevel] -- ^ dump levels
  , dbDumpEnv :: Bool           -- ^ dump compilation environment
  , dbDumpRaw :: Bool           -- ^ dump data structure
79
  } deriving Show
80
81
82
83

-- | Default compiler options
defaultOptions :: Options
defaultOptions = Options
84
85
86
87
88
  { optMode         = ModeMake
  , optVerbosity    = VerbStatus
  , optForce        = False
  , optLibraryPaths = []
  , optImportPaths  = []
89
  , optHtmlDir      = Nothing
90
91
  , optUseSubdir    = True
  , optInterface    = True
92
93
  , optPrepOpts     = defaultPrepOpts
  , optWarnOpts     = defaultWarnOpts
94
95
  , optTargetTypes  = []
  , optExtensions   = []
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
  , optDebugOpts    = defaultDebugOpts
  }

-- | Default preprocessor options
defaultPrepOpts :: PrepOpts
defaultPrepOpts = PrepOpts
  { ppPreprocess = False
  , ppCmd        = ""
  , ppOpts       = []
  }

-- | Default warning options
defaultWarnOpts :: WarnOpts
defaultWarnOpts = WarnOpts
  { wnWarn        = True
  , wnWarnFlags   = stdWarnFlags
  , wnWarnAsError = False
  }

-- | Default dump options
defaultDebugOpts :: DebugOpts
defaultDebugOpts = DebugOpts
  { dbDumpLevels = []
  , dbDumpEnv    = False
  , dbDumpRaw    = False
121
122
  }

123
-- |Modus operandi of the program
124
data CymakeMode
125
126
127
  = ModeHelp           -- ^ Show help information and exit
  | ModeVersion        -- ^ Show version and exit
  | ModeNumericVersion -- ^ Show numeric version, suitable for later processing
Björn Peemöller 's avatar
Björn Peemöller committed
128
129
  | ModeHtml           -- ^ Create HTML documentation
  | ModeMake           -- ^ Compile with dependencies
130
  deriving (Eq, Show)
131

132
-- |Verbosity level
133
134
135
data Verbosity
  = VerbQuiet  -- ^ be quiet
  | VerbStatus -- ^ show status of compilation
136
  deriving (Eq, Ord, Show)
137

138
139
140
141
142
143
-- |Description and flag of verbosities
verbosities :: [(Verbosity, String, String)]
verbosities = [ ( VerbQuiet , "0", "quiet" )
              , ( VerbStatus, "1", "status")
              ]

Björn Peemöller 's avatar
Björn Peemöller committed
144
-- |Type of the target file
145
data TargetType
Björn Peemöller 's avatar
Björn Peemöller committed
146
147
148
149
  = Parsed                -- ^ Parsed source code
  | FlatCurry             -- ^ FlatCurry
  | ExtendedFlatCurry     -- ^ Extended FlatCurry
  | AbstractCurry         -- ^ AbstractCurry
150
  | UntypedAbstractCurry  -- ^ Untyped AbstractCurry
151
    deriving (Eq, Show)
152

153
154
155
156
157
158
159
160
-- |Warnings flags
data WarnFlag
  = WarnMultipleImports    -- ^ Warn for multiple imports
  | WarnDisjoinedRules     -- ^ Warn for disjoined function rules
  | WarnUnusedBindings     -- ^ Warn for unused bindings
  | WarnNameShadowing      -- ^ Warn for name shadowing
  | WarnOverlapping        -- ^ Warn for overlapping rules/alternatives
  | WarnIncompletePatterns -- ^ Warn for incomplete pattern matching
161
  | WarnMissingSignatures  -- ^ Warn for missing type signatures
162
    deriving (Eq, Bounded, Enum, Show)
163

164
165
-- |Warning flags enabled by default
stdWarnFlags :: [WarnFlag]
166
stdWarnFlags =
167
168
169
  [ WarnMultipleImports  , WarnDisjoinedRules, WarnUnusedBindings
  , WarnNameShadowing    , WarnOverlapping   , WarnIncompletePatterns
  , WarnMissingSignatures
170
  ]
171
172

-- |Description and flag of warnings flags
173
174
warnFlags :: [(WarnFlag, String, String)]
warnFlags =
175
176
177
178
179
180
181
182
183
184
185
186
  [ ( WarnMultipleImports   , "multiple-imports"
    , "multiple imports"           )
  , ( WarnDisjoinedRules    , "disjoined-rules"
    , "disjoined function rules"   )
  , ( WarnUnusedBindings    , "unused-bindings"
    , "unused bindings"            )
  , ( WarnNameShadowing     , "name-shadowing"
    , "name shadowing"             )
  , ( WarnOverlapping       , "overlapping"
    , "overlapping function rules" )
  , ( WarnIncompletePatterns, "incomplete-patterns"
    , "incomplete pattern matching")
187
188
  , ( WarnMissingSignatures , "missing-signatures"
    , "missing type signatures"    )
189
  ]
190

191
-- |Dump level
192
data DumpLevel
193
194
195
196
197
  = DumpParsed        -- ^ dump source code after parsing
  | DumpKindChecked   -- ^ dump source code after kind checking
  | DumpSyntaxChecked -- ^ dump source code after syntax checking
  | DumpPrecChecked   -- ^ dump source code after precedence checking
  | DumpTypeChecked   -- ^ dump source code after type checking
198
  | DumpExportChecked -- ^ dump source code after export checking
Björn Peemöller 's avatar
Björn Peemöller committed
199
  | DumpQualified     -- ^ dump source  after qualification
200
201
202
203
204
  | DumpDesugared     -- ^ dump source  after desugaring
  | DumpSimplified    -- ^ dump source  after simplification
  | DumpLifted        -- ^ dump source  after lambda-lifting
  | DumpTranslated    -- ^ dump IL code after translation
  | DumpCaseCompleted -- ^ dump IL code after case completion
205
  | DumpFlatCurry     -- ^ dump FlatCurry code (pretty-printed)
206
207
    deriving (Eq, Bounded, Enum, Show)

208
-- |Description and flag of dump levels
209
dumpLevel :: [(DumpLevel, String, String)]
Björn Peemöller 's avatar
Björn Peemöller committed
210
211
212
213
214
215
216
217
218
219
220
221
222
dumpLevel = [ (DumpParsed       , "dump-parse", "parsing"                     )
            , (DumpKindChecked  , "dump-kc"   , "kind checking"               )
            , (DumpSyntaxChecked, "dump-sc"   , "syntax checking"             )
            , (DumpPrecChecked  , "dump-pc"   , "precedence checking"         )
            , (DumpTypeChecked  , "dump-tc"   , "type checking"               )
            , (DumpExportChecked, "dump-ec"   , "export checking"             )
            , (DumpQualified    , "dump-qual" , "qualification"               )
            , (DumpDesugared    , "dump-ds"   , "desugaring"                  )
            , (DumpLifted       , "dump-lift" , "lifting"                     )
            , (DumpSimplified   , "dump-simpl", "simplification"              )
            , (DumpTranslated   , "dump-trans", "pattern matching compilation")
            , (DumpCaseCompleted, "dump-cc"   , "case completion"             )
            , (DumpFlatCurry    , "dump-flat" , "translation into FlatCurry"  )
223
            ]
224

225
-- |Description and flag of language extensions
226
extensions :: [(KnownExtension, String, String)]
227
extensions =
228
229
  [ ( AnonFreeVars      , "AnonFreeVars"
    , "enable anonymous free variables"     )
230
231
  , ( FunctionalPatterns, "FunctionalPatterns"
    , "enable functional patterns"          )
232
233
  , ( NegativeLiterals  , "NegativeLiterals"
    , "desugar negated literals as negative literal")
234
235
236
  , ( NoImplicitPrelude , "NoImplicitPrelude"
    , "do not implicitly import the Prelude")
  ]
Björn Peemöller 's avatar
Björn Peemöller committed
237

238
239
240
241
242
243
244
-- -----------------------------------------------------------------------------
-- Parsing of the command line options.
--
-- Because some flags require additional arguments, the structure is slightly
-- more complicated to enable malformed arguments to be reported.
-- -----------------------------------------------------------------------------

245
246
-- |Instead of just returning the resulting 'Options' structure, we also
-- collect errors from arguments passed to specific options.
247
248
type OptErr = (Options, [String])

249
250
-- |An 'OptErrTable' consists of a list of entries of the following form:
--   * a flag to be recognized on the command line
251
--   * an explanation text for the usage information
252
253
254
--   * 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)]
255

256
257
258
onOpts :: (Options -> Options) -> OptErr -> OptErr
onOpts f (opts, errs) = (f opts, errs)

259
260
261
onPrepOpts :: (PrepOpts -> PrepOpts) -> OptErr -> OptErr
onPrepOpts f (opts, errs) = (opts { optPrepOpts = f (optPrepOpts opts) }, errs)

262
263
264
265
266
267
268
onWarnOpts :: (WarnOpts -> WarnOpts) -> OptErr -> OptErr
onWarnOpts f (opts, errs) = (opts { optWarnOpts = f (optWarnOpts opts) }, errs)

onDebugOpts :: (DebugOpts -> DebugOpts) -> OptErr -> OptErr
onDebugOpts f (opts, errs)
  = (opts { optDebugOpts = f (optDebugOpts opts) }, errs)

269
270
271
withArg :: ((opt -> opt) -> OptErr -> OptErr)
        -> (String -> opt -> opt) -> String -> OptErr -> OptErr
withArg lift f arg = lift (f arg)
272
273
274

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

276
277
278
279
280
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)
281
282
283
  ("set " ++ what ++ " `" ++ arg ++ "', where `" ++ arg ++ "' is one of\n"
    ++ renderOptErrTable tbl)

284
285
286
287
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
288
289
290
291
292
293
294
  Nothing -> addErr $ "unrecognized " ++ what ++ '`' : opt ++ "'\n"
  where
  lookup3 _ []                  = Nothing
  lookup3 k ((k', _, v2) : kvs)
    | k == k'                   = Just v2
    | otherwise                 = lookup3 k kvs

295
renderOptErrTable :: OptErrTable opt -> String
296
renderOptErrTable ds
297
  = intercalate "\n" $ map (\(k, d, _) -> "  " ++ rpad maxLen k ++ ": " ++ d) ds
298
299
300
301
  where
  maxLen = maximum $ map (\(k, _, _) -> length k) ds
  rpad n x = x ++ replicate (n - length x) ' '

302
-- | All available compiler options
303
options :: [OptDescr (OptErr -> OptErr)]
304
options =
305
  -- modus operandi
306
  [ Option "h?" ["help"]
307
      (NoArg (onOpts $ \ opts -> opts { optMode = ModeHelp }))
308
309
      "display this help and exit"
  , Option "V"  ["version"]
310
      (NoArg (onOpts $ \ opts -> opts { optMode = ModeVersion }))
311
312
      "show the version number and exit"
  , Option ""   ["numeric-version"]
313
      (NoArg (onOpts $ \ opts -> opts { optMode = ModeNumericVersion }))
314
315
      "show the numeric version number and exit"
  -- verbosity
316
  , mkOptDescr onOpts "v" ["verbosity"] "n" "verbosity level" verbDescriptions
317
318
  , Option "q"  ["no-verb"]
      (NoArg (onOpts $ \ opts -> opts { optVerbosity = VerbQuiet } ))
319
      "set verbosity level to quiet"
320
321
  -- compilation
  , Option "f"  ["force"]
322
      (NoArg (onOpts $ \ opts -> opts { optForce = True }))
323
      "force compilation of target file"
324
  , Option "P"  ["lib-dir"]
325
      (ReqArg (withArg onOpts $ \ arg opts -> opts { optLibraryPaths =
326
327
        nub $ optLibraryPaths opts ++ splitSearchPath arg}) "dir[:dir]")
      "search for libraries in dir[:dir]"
328
  , Option "i"  ["import-dir"]
329
      (ReqArg (withArg onOpts $ \ arg opts -> opts { optImportPaths =
330
331
332
        nub $ optImportPaths opts ++
              map (normalise . addTrailingPathSeparator) (splitSearchPath arg)
              }) "dir[:dir]")
333
      "search for imports in dir[:dir]"
334
335
336
337
  , Option []  ["htmldir"]
      (ReqArg (withArg onOpts $ \ arg opts -> opts { optHtmlDir =
        Just arg }) "dir")
      "write HTML documentation into directory `dir'"
338
  , Option ""   ["no-subdir"]
339
340
      (NoArg (onOpts $ \ opts -> opts { optUseSubdir = False }))
      ("disable writing to `" ++ currySubdir ++ "' subdirectory")
341
  , Option ""   ["no-intf"]
342
      (NoArg (onOpts $ \ opts -> opts { optInterface = False }))
343
      "do not create an interface file"
344
    -- legacy warning flags
345
  , Option ""   ["no-warn"]
346
      (NoArg (onWarnOpts $ \ opts -> opts { wnWarn = False }))
347
348
      "do not print warnings"
  , Option ""   ["no-overlap-warn"]
349
350
      (NoArg (onWarnOpts $ \ opts -> opts {wnWarnFlags =
        addFlag WarnOverlapping (wnWarnFlags opts) }))
351
352
      "do not print warnings for overlapping rules"
  -- target types
353
354
355
  , Option ""   ["html"]
      (NoArg (onOpts $ \ opts -> opts { optMode = ModeHtml }))
      "generate html code and exit"
356
  , Option ""   ["parse-only"]
357
      (NoArg (onOpts $ \ opts -> opts { optTargetTypes =
358
        nub $ Parsed : optTargetTypes opts }))
359
360
      "generate source representation"
  , Option ""   ["flat"]
361
      (NoArg (onOpts $ \ opts -> opts { optTargetTypes =
362
        nub $ FlatCurry : optTargetTypes opts }))
363
364
      "generate FlatCurry code"
  , Option ""   ["extended-flat"]
365
      (NoArg (onOpts $ \ opts -> opts { optTargetTypes =
366
        nub $ ExtendedFlatCurry : optTargetTypes opts }))
367
368
      "generate FlatCurry code with source references"
  , Option ""   ["acy"]
369
      (NoArg (onOpts $ \ opts -> opts { optTargetTypes =
370
        nub $ AbstractCurry : optTargetTypes opts }))
371
      "generate (type infered) AbstractCurry code"
372
373
374
375
  , Option ""   ["uacy"]
      (NoArg (onOpts $ \ opts -> opts { optTargetTypes =
        nub $ UntypedAbstractCurry : optTargetTypes opts }))
      "generate untyped AbstractCurry code"
376
377
378
379
380
381
382
383
384
385
386
  , Option "F"  []
      (NoArg (onPrepOpts $ \ opts -> opts { ppPreprocess = True }))
      "use custom preprocessor"
  , Option ""   ["pgmF"]
      (ReqArg (withArg onPrepOpts $ \ arg opts -> opts { ppCmd = arg})
        "cmd")
      "execute preprocessor command <cmd>"
  , Option ""   ["optF"]
      (ReqArg (withArg onPrepOpts $ \ arg opts ->
        opts { ppOpts = ppOpts opts ++ [arg]}) "option")
      "execute preprocessor with option <option>"
387
388
  -- extensions
  , Option "e"  ["extended"]
389
      (NoArg (onOpts $ \ opts -> opts { optExtensions =
390
        nub $ kielExtensions ++ optExtensions opts }))
391
      "enable extended Curry functionalities"
392
393
394
  , mkOptDescr onOpts      "X" [] "ext" "language extension" extDescriptions
  , mkOptDescr onWarnOpts  "W" [] "opt" "warning option"     warnDescriptions
  , mkOptDescr onDebugOpts "d" [] "opt" "debug option"       debugDescriptions
395
396
  ]

397
verbDescriptions :: OptErrTable Options
398
verbDescriptions = map toDescr verbosities
399
  where
400
401
  toDescr (flag, name, desc)
    = (name, desc, \ opts -> opts { optVerbosity = flag })
402

403
extDescriptions :: OptErrTable Options
404
extDescriptions = map toDescr extensions
405
  where
406
407
408
  toDescr (flag, name, desc)
    = (name, desc,
        \ opts -> opts { optExtensions = addFlag flag (optExtensions opts)})
409

410
warnDescriptions :: OptErrTable WarnOpts
411
412
warnDescriptions
  = [ ( "all"  , "turn on all warnings"
413
        , \ opts -> opts { wnWarnFlags = [minBound .. maxBound] } )
414
    , ("none" , "turn off all warnings"
415
        , \ opts -> opts { wnWarnFlags = []                     } )
416
    , ("error", "treat warnings as errors"
417
        , \ opts -> opts { wnWarnAsError = True                 } )
418
419
420
421
    ] ++ map turnOn warnFlags ++ map turnOff warnFlags
  where
  turnOn (flag, name, desc)
    = (name, "warn for " ++ desc
422
      , \ opts -> opts { wnWarnFlags = addFlag flag (wnWarnFlags opts)})
423
424
  turnOff (flag, name, desc)
    = ("no-" ++ name, "do not warn for " ++ desc
425
      , \ opts -> opts { wnWarnFlags = removeFlag flag (wnWarnFlags opts)})
426

427
debugDescriptions :: OptErrTable DebugOpts
428
429
debugDescriptions =
  [ ( "dump-all", "dump everything"
430
    , \ opts -> opts { dbDumpLevels = [minBound .. maxBound] })
431
  , ( "dump-none", "dump nothing"
432
    , \ opts -> opts { dbDumpLevels = []                     })
433
  , ( "dump-env" , "additionally dump compiler environment"
434
    , \ opts -> opts { dbDumpEnv = True                 })
Björn Peemöller 's avatar
Björn Peemöller committed
435
  , ( "dump-raw" , "dump as raw AST (instead of pretty printing)"
436
    , \ opts -> opts { dbDumpRaw = True                 })
437
438
439
  ] ++ map toDescr dumpLevel
  where
  toDescr (flag, name, desc)
Björn Peemöller 's avatar
Björn Peemöller committed
440
    = (name , "dump code after " ++ desc
441
        , \ opts -> opts { dbDumpLevels = addFlag flag (dbDumpLevels opts)})
442
443
444
445
446
447
448

addFlag :: Eq a => a -> [a] -> [a]
addFlag o opts = nub $ o : opts

removeFlag :: Eq a => a -> [a] -> [a]
removeFlag o opts = filter (/= o) opts

449
450
updateOpts :: Options -> [String] -> (Options, [String], [String])
updateOpts opts args = (opts', files, errs ++ errs2 ++ checkOpts opts files)
451
  where
452
  (opts', errs2) = foldl (flip ($)) (opts, []) optErrs
453
  (optErrs, files, errs) = getOpt Permute options args
454

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

459
460
461
462
463
464
465
-- |Check options and files and return a list of error messages
checkOpts :: Options -> [String] -> [String]
checkOpts opts _
  | isJust (optHtmlDir opts) && (optMode opts) /= ModeHtml
  = ["The option '--htmldir' is only valid for HTML generation mode"]
  | otherwise = []

466
467
468
-- |Print the usage information of the command line tool.
usage :: String -> String
usage prog = usageInfo header options
Björn Peemöller 's avatar
Björn Peemöller committed
469
  where header = "usage: " ++ prog ++ " [OPTION] ... MODULES ..."
470
471

-- |Retrieve the compiler 'Options'
Björn Peemöller 's avatar
Björn Peemöller committed
472
473
getCompilerOpts :: IO (String, Options, [String], [String])
getCompilerOpts = do
474
475
476
  args <- getArgs
  prog <- getProgName
  let (opts, files, errs) = parseOpts args
477
  return (prog, opts, files, errs)