CompilerOpts.hs 18.3 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
29
import System.Environment    (getArgs, getProgName)
import System.FilePath       (splitSearchPath)
30
31

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

34
35
36
37
-- -----------------------------------------------------------------------------
-- Option data structures
-- -----------------------------------------------------------------------------

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

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

122
-- |Modus operandi of the program
123
data CymakeMode
124
125
126
  = 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
127
128
  | ModeHtml           -- ^ Create HTML documentation
  | ModeMake           -- ^ Compile with dependencies
129
  deriving (Eq, Show)
130

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

137
138
139
140
141
142
-- |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
143
-- |Type of the target file
144
data TargetType
Björn Peemöller 's avatar
Björn Peemöller committed
145
146
147
148
  = Parsed                -- ^ Parsed source code
  | FlatCurry             -- ^ FlatCurry
  | ExtendedFlatCurry     -- ^ Extended FlatCurry
  | AbstractCurry         -- ^ AbstractCurry
149
  | UntypedAbstractCurry  -- ^ Untyped AbstractCurry
150
    deriving (Eq, Show)
151

152
153
154
155
156
157
158
159
-- |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
160
  | WarnNondetPatterns     -- ^ Warn for non-deterministic pattern matching
161
    deriving (Eq, Bounded, Enum, Show)
162

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

-- |Description and flag of warnings flags
171
172
warnFlags :: [(WarnFlag, String, String)]
warnFlags =
173
174
175
176
177
178
179
180
181
182
183
184
  [ ( 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")
185
186
  , ( WarnNondetPatterns    , "nondet-patterns"
    , "Nondeterministic patterns"  )
187
  ]
188

189
-- |Dump level
190
data DumpLevel
191
192
193
194
195
  = 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
Björn Peemöller 's avatar
Björn Peemöller committed
196
  | DumpQualified     -- ^ dump source  after qualification
197
198
199
200
201
  | 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
202
203
    deriving (Eq, Bounded, Enum, Show)

204
-- |Description and flag of dump levels
205
dumpLevel :: [(DumpLevel, String, String)]
206
207
208
209
210
211
212
213
214
215
216
dumpLevel = [ (DumpParsed       , "dump-parse", "parse tree"               )
            , (DumpKindChecked  , "dump-kc"   , "kind checker output"      )
            , (DumpSyntaxChecked, "dump-sc"   , "syntax checker output"    )
            , (DumpPrecChecked  , "dump-pc"   , "precedence checker output")
            , (DumpTypeChecked  , "dump-tc"   , "type checker output"      )
            , (DumpQualified    , "dump-qual" , "qualifier output"         )
            , (DumpDesugared    , "dump-ds"   , "desugarer output"         )
            , (DumpSimplified   , "dump-simpl", "simplifier output"        )
            , (DumpLifted       , "dump-lift" , "lifting output"           )
            , (DumpTranslated   , "dump-trans", "translated output"        )
            , (DumpCaseCompleted, "dump-cc"   , "case completed output"    )
217
            ]
218

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

234
235
236
237
238
239
240
-- -----------------------------------------------------------------------------
-- 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.
-- -----------------------------------------------------------------------------

241
242
-- |Instead of just returning the resulting 'Options' structure, we also
-- collect errors from arguments passed to specific options.
243
244
type OptErr = (Options, [String])

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

252
253
254
onOpts :: (Options -> Options) -> OptErr -> OptErr
onOpts f (opts, errs) = (f opts, errs)

255
256
257
onPrepOpts :: (PrepOpts -> PrepOpts) -> OptErr -> OptErr
onPrepOpts f (opts, errs) = (opts { optPrepOpts = f (optPrepOpts opts) }, errs)

258
259
260
261
262
263
264
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)

265
266
267
withArg :: ((opt -> opt) -> OptErr -> OptErr)
        -> (String -> opt -> opt) -> String -> OptErr -> OptErr
withArg lift f arg = lift (f arg)
268
269
270

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

272
273
274
275
276
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)
277
278
279
  ("set " ++ what ++ " `" ++ arg ++ "', where `" ++ arg ++ "' is one of\n"
    ++ renderOptErrTable tbl)

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

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

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

391
verbDescriptions :: OptErrTable Options
392
verbDescriptions = map toDescr verbosities
393
  where
394
395
  toDescr (flag, name, desc)
    = (name, desc, \ opts -> opts { optVerbosity = flag })
396

397
extDescriptions :: OptErrTable Options
398
extDescriptions = map toDescr extensions
399
  where
400
401
402
  toDescr (flag, name, desc)
    = (name, desc,
        \ opts -> opts { optExtensions = addFlag flag (optExtensions opts)})
403

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

421
debugDescriptions :: OptErrTable DebugOpts
422
423
debugDescriptions =
  [ ( "dump-all", "dump everything"
424
    , \ opts -> opts { dbDumpLevels = [minBound .. maxBound] })
425
  , ( "dump-none", "dump nothing"
426
    , \ opts -> opts { dbDumpLevels = []                     })
427
  , ( "dump-env" , "additionally dump compiler environment"
428
    , \ opts -> opts { dbDumpEnv = True                 })
429
  , ( "dump-raw" , "dump as raw AST (instead of pretty printed)"
430
    , \ opts -> opts { dbDumpRaw = True                 })
431
432
433
434
  ] ++ map toDescr dumpLevel
  where
  toDescr (flag, name, desc)
    = (name , "dump " ++ desc
435
        , \ opts -> opts { dbDumpLevels = addFlag flag (dbDumpLevels opts)})
436
437
438
439
440
441
442

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

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

443
444
updateOpts :: Options -> [String] -> (Options, [String], [String])
updateOpts opts args = (opts', files, errs ++ errs2 ++ checkOpts opts files)
445
  where
446
  (opts', errs2) = foldl (flip ($)) (opts, []) optErrs
447
  (optErrs, files, errs) = getOpt Permute options args
448

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

453
454
455
456
457
458
459
-- |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 = []

460
461
462
-- |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
463
  where header = "usage: " ++ prog ++ " [OPTION] ... MODULES ..."
464
465

-- |Retrieve the compiler 'Options'
Björn Peemöller 's avatar
Björn Peemöller committed
466
467
getCompilerOpts :: IO (String, Options, [String], [String])
getCompilerOpts = do
468
469
470
  args <- getArgs
  prog <- getProgName
  let (opts, files, errs) = parseOpts args
471
  return (prog, opts, files, errs)