Optparse-applicative

src/GHCMod/Options.hs

@@ -0,0 +1,185 @@
+module GHCMod.Options (
+  parseArgs,
+  parseCommandsFromList,
+  GhcModCommands(..)
+) where
+
+import Options.Applicative
+import Options.Applicative.Types
+import Language.Haskell.GhcMod.Types
+import Control.Arrow
+import GHCMod.Options.Commands
+import GHCMod.Version
+
+parseArgs :: IO (Options, GhcModCommands)
+parseArgs =
+  execParser opts
+  where
+    opts = info (argAndCmdSpec <**> helpVersion)
+      ( fullDesc
+     <> header "ghc-mod: Happy Haskell Programming" )
+
+parseCommandsFromList :: [String] -> Either String GhcModCommands
+parseCommandsFromList args =
+  case execParserPure (prefs idm) (info commandsSpec idm) args of
+    Success a -> Right a
+    Failure h -> Left $ show h
+    CompletionInvoked _ -> error "WTF"
+
+helpVersion :: Parser (a -> a)
+helpVersion =
+  helper <*>
+  abortOption (InfoMsg ghcModVersion)
+    (long "version" <> help "Print the version of the program.") <*>
+  argument r (value id <> metavar "")
+  where
+    r :: ReadM (a -> a)
+    r = do
+      v <- readerAsk
+      case v of
+        "help" -> readerAbort ShowHelpText
+        "version" -> readerAbort $ InfoMsg ghcModVersion
+        _ -> return id
+
+argAndCmdSpec :: Parser (Options, GhcModCommands)
+argAndCmdSpec = (,) <$> globalArgSpec <*> commandsSpec
+
+splitOn :: Eq a => a -> [a] -> ([a], [a])
+splitOn c = second (drop 1) . break (==c)
+
+getLogLevel :: Int -> GmLogLevel
+getLogLevel = toEnum . min 7
+
+logLevelParser :: Parser GmLogLevel
+logLevelParser =
+  getLogLevel <$>
+    (
+    silentSwitch <|> logLevelSwitch <|> logLevelOption
+    )
+  where
+    logLevelOption =
+      option int (
+        long "verbose" <>
+        short 'v' <>
+        metavar "LEVEL" <>
+        value 4 <>
+        showDefault <>
+        help "Set log level. (0-7)"
+      )
+    logLevelSwitch =
+      (4+) . length <$> many (flag' () (
+        long "verbose" <>
+        short 'v' <>
+        help "Increase log level"
+      ))
+    silentSwitch = (\v -> if v then 0 else 4) <$>
+      switch (
+        long "silent" <>
+        short 's' <>
+        help "Be silent, set log level to 0"
+      )
+
+outputOptsSpec :: Parser OutputOpts
+outputOptsSpec = OutputOpts <$>
+      logLevelParser <*>
+      flag PlainStyle LispStyle (
+        long "tolisp" <>
+        short 'l' <>
+        help "Format output as an S-Expression"
+      ) <*>
+      (LineSeparator <$> strOption (
+        long "boundary" <>
+        long "line-separator" <>
+        short 'b' <>
+        metavar "SEP" <>
+        value "\0" <>
+        showDefault <>
+        help "Output line separator"
+      )) <*>
+      optional (splitOn ',' <$> strOption (
+        long "line-prefix" <>
+        metavar "OUT,ERR" <>
+        help "Output prefixes"
+      ))
+
+programsArgSpec :: Parser Programs
+programsArgSpec = Programs <$>
+      strOption (
+        long "with-ghc" <>
+        value "ghc" <>
+        showDefault <>
+        help "GHC executable to use"
+      ) <*>
+      strOption (
+        long "with-ghc-pkg" <>
+        value "ghc-pkg" <>
+        showDefault <>
+        help "ghc-pkg executable to use (only needed when guessing from GHC path fails)"
+      ) <*>
+      strOption (
+        long "with-cabal" <>
+        value "cabal" <>
+        showDefault <>
+        help "cabal-install executable to use"
+      ) <*>
+      strOption (
+        long "with-stack" <>
+        value "stack" <>
+        showDefault <>
+        help "stack executable to use"
+      )
+
+globalArgSpec :: Parser Options
+globalArgSpec = Options <$>
+      outputOptsSpec <*> -- optOutput
+      programsArgSpec <*> -- optPrograms
+      many (strOption ( -- optGhcUserOptions
+        long "ghcOpt" <>
+        long "ghc-option" <>
+        short 'g' <>
+        metavar "OPT" <>
+        help "Option to be passed to GHC"
+      )) <*>
+      many fileMappingSpec -- optFileMappings   = []
+  where
+    {-
+    File map docs:
+
+    CLI options:
+    * `--map-file "file1.hs=file2.hs"` can be used to tell
+        ghc-mod that it should take source code for `file1.hs` from `file2.hs`.
+        `file1.hs` can be either full path, or path relative to project root.
+        `file2.hs` has to be either relative to project root,
+        or full path (preferred).
+    * `--map-file "file.hs"` can be used to tell ghc-mod that it should take
+        source code for `file.hs` from stdin. File end marker is `\EOT\n`,
+        i.e. `\x04\x0A`. `file.hs` may or may not exist, and should be
+        either full path, or relative to project root.
+
+    Interactive commands:
+    * `map-file file.hs` -- tells ghc-modi to read `file.hs` source from stdin.
+        Works the same as second form of `--map-file` CLI option.
+    * `unmap-file file.hs` -- unloads previously mapped file, so that it's
+        no longer mapped. `file.hs` can be full path or relative to
+        project root, either will work.
+
+    Exposed functions:
+    * `loadMappedFile :: FilePath -> FilePath -> GhcModT m ()` -- maps `FilePath`,
+        given as first argument to take source from `FilePath` given as second
+        argument. Works exactly the same as first form of `--map-file`
+        CLI option.
+    * `loadMappedFileSource :: FilePath -> String -> GhcModT m ()` -- maps
+        `FilePath`, given as first argument to have source as given
+        by second argument. Works exactly the same as second form of `--map-file`
+        CLI option, sans reading from stdin.
+    * `unloadMappedFile :: FilePath -> GhcModT m ()` -- unmaps `FilePath`, given as
+        first argument, and removes any temporary files created when file was
+        mapped. Works exactly the same as `unmap-file` interactive command
+    -}
+    fileMappingSpec =
+      getFileMapping . splitOn '=' <$> strOption (
+        long "map-file" <>
+        metavar "MAPPING" <>
+        help "Redirect one file to another, --map-file \"file1.hs=file2.hs\""
+      )
+    getFileMapping = second (\i -> if null i then Nothing else Just i)

src/GHCMod/Options/Commands.hs

@@ -0,0 +1,231 @@
+module GHCMod.Options.Commands where
+
+import Options.Applicative
+import Options.Applicative.Types
+import Language.Haskell.GhcMod.Lint (LintOpts(..))
+import Language.Haskell.GhcMod.Browse (BrowseOpts(..))
+import Text.Read (readMaybe)
+import GHCMod.Options.DocUtils
+
+type Symbol = String
+type Expr = String
+type Module = String
+type Line = Int
+type Col = Int
+type Point = (Line, Col)
+
+data GhcModCommands =
+    CmdLang
+  | CmdFlag
+  | CmdDebug
+  | CmdBoot
+  | CmdNukeCaches
+  | CmdRoot
+  | CmdLegacyInteractive
+  | CmdModules Bool
+  | CmdDumpSym FilePath
+  | CmdFind Symbol
+  | CmdDoc Module
+  | CmdLint LintOpts FilePath
+  | CmdBrowse BrowseOpts [Module]
+  | CmdDebugComponent [String]
+  | CmdCheck [FilePath]
+  | CmdExpand [FilePath]
+  | CmdInfo FilePath Symbol
+  | CmdType FilePath Point
+  | CmdSplit FilePath Point
+  | CmdSig FilePath Point
+  | CmdAuto FilePath Point
+  | CmdRefine FilePath Point Expr
+
+int :: ReadM Int
+int = do
+  v <- readerAsk
+  maybe (readerError $ "Not a number \"" ++ v ++ "\"") return $ readMaybe v
+
+commandsSpec :: Parser GhcModCommands
+commandsSpec =
+  hsubparser (
+       command "lang" (
+          info (pure CmdLang)
+          (progDesc "List all known GHC language extensions"))
+    <> command "flag" (
+          info (pure CmdFlag)
+          (progDesc "List GHC -f<foo> flags"))
+    <> command "debug" (
+          info (pure CmdDebug)
+          (progDesc
+            "Print debugging information. Please include the output in any bug\
+            \ reports you submit"))
+    <> command "debug-component" (
+          info debugComponentArgSpec
+          (progDesc "Debugging information related to cabal component resolution"))
+    <> command "boot" (
+          info (pure CmdBoot)
+          (progDesc "Internal command used by the emacs frontend"))
+    -- <> command "nuke-caches" (
+    --       info (pure CmdNukeCaches) idm)
+    <> command "root" (
+          info (pure CmdRoot)
+          (progDesc
+            "Try to find the project directory. For Cabal projects this is the\
+            \ directory containing the cabal file, for projects that use a cabal\
+            \ sandbox but have no cabal file this is the directory containing the\
+            \ cabal.sandbox.config file and otherwise this is the current\
+            \ directory"
+          ))
+    <> command "legacy-interactive" (
+          info (pure CmdLegacyInteractive)
+          (progDesc "ghc-modi compatibility mode"))
+    <> command "list" (
+          info modulesArgSpec
+          (progDesc "List all visible modules"))
+    <> command "modules" (
+          info modulesArgSpec
+          (progDesc "List all visible modules"))
+    <> command "dumpsym" (
+          info dumpSymArgSpec idm)
+    <> command "find" (
+          info findArgSpec
+          (progDesc "List all modules that define SYMBOL"))
+    <> command "doc" (
+          info docArgSpec
+          (progDesc "Try finding the html documentation directory for the given MODULE"))
+    <> command "lint" (
+          info lintArgSpec
+          (progDesc "Check files using `hlint'"))
+    <> command "browse" (
+          info browseArgSpec
+          (progDesc "List symbols in a module"))
+    <> command "check" (
+          info checkArgSpec
+          (progDesc "Load the given files using GHC and report errors/warnings,\
+                    \ but don't produce output files"))
+    <> command "expand" (
+          info expandArgSpec
+          (progDesc "Like `check' but also pass `-ddump-splices' to GHC"))
+    <> command "info" (
+          info infoArgSpec
+          (progDesc
+            "Look up an identifier in the context of FILE (like ghci's `:info')\
+            \ MODULE is completely ignored and only allowed for backwards\
+            \ compatibility"))
+    <> command "type" (
+          info typeArgSpec
+          (progDesc "Get the type of the expression under (LINE,COL)"))
+    <> command "split" (
+          info splitArgSpec
+          (progDesc
+            "Split a function case by examining a type's constructors"
+          <> desc [
+            text "For example given the following code snippet:"
+          , code [
+              "f :: [a] -> a"
+            , "f x = _body"
+            ]
+          , text "would be replaced by:"
+          , code [
+              "f :: [a] -> a"
+            , "f [] = _body"
+            , "f (x:xs) = _body"
+            ]
+          , text "(See https://github.com/kazu-yamamoto/ghc-mod/pull/274)"
+          ]))
+    <> command "sig" (
+          info sigArgSpec
+          (progDesc
+            "Generate initial code given a signature"
+          <> desc [
+            text "For example when (LINE,COL) is on the signature in the following\
+            \ code snippet:"
+            , code ["func :: [a] -> Maybe b -> (a -> b) -> (a,b)"]
+            , text "ghc-mod would add the following on the next line:"
+            , code ["func x y z f = _func_body"]
+            , text "(See: https://github.com/kazu-yamamoto/ghc-mod/pull/274)"
+            ]
+          ))
+    <> command "auto" (
+          info autoArgSpec
+          (progDesc "Try to automatically fill the contents of a hole"))
+    <> command "refine" (
+          info refineArgSpec
+          (progDesc
+            "Refine the typed hole at (LINE,COL) given EXPR"
+          <> desc [
+            text "For example if EXPR is `filter', which has type `(a -> Bool) -> [a]\
+              \ -> [a]' and (LINE,COL) is on the hole `_body' in the following\
+              \ code snippet:"
+          , code [
+                "filterNothing :: [Maybe a] -> [a]"
+              , "filterNothing xs = _body"
+              ]
+          , text "ghc-mod changes the code to get a value of type `[a]', which\
+            \ results in:"
+          , code [ "filterNothing xs = filter _body_1 _body_2" ]
+          , text "(See also: https://github.com/kazu-yamamoto/ghc-mod/issues/311)"
+          ]
+          ))
+    )
+
+strArg :: String -> Parser String
+strArg = argument str . metavar
+
+filesArgsSpec :: ([String] -> b) -> Parser b
+filesArgsSpec x = x <$> some (strArg "FILES..")
+
+locArgSpec :: (String -> (Int, Int) -> b) -> Parser b
+locArgSpec x = x <$>
+  strArg "FILE" <*>
+  ( (,) <$>
+    argument int (metavar "LINE") <*>
+    argument int (metavar "COL")
+  )
+
+modulesArgSpec, dumpSymArgSpec, docArgSpec, findArgSpec,
+  lintArgSpec, browseArgSpec, checkArgSpec, expandArgSpec,
+  infoArgSpec, typeArgSpec, autoArgSpec, splitArgSpec,
+  sigArgSpec, refineArgSpec, debugComponentArgSpec :: Parser GhcModCommands
+
+modulesArgSpec = CmdModules <$>
+  switch (
+        long "detailed" <>
+        short 'd' <>
+        help "Print package modules belong to"
+      )
+dumpSymArgSpec = CmdDumpSym <$> strArg "TMPDIR"
+findArgSpec = CmdFind <$> strArg "SYMBOL"
+docArgSpec = CmdDoc <$> strArg "MODULE"
+lintArgSpec = CmdLint <$>
+  (LintOpts <$> many (strOption (
+    long "hlintOpt" <>
+    short 'h' <>
+    help "Option to be passed to hlint"
+  ))) <*> strArg "FILE"
+browseArgSpec = CmdBrowse <$>
+  (BrowseOpts <$>
+    switch (
+      long "operators" <>
+      short 'o' <>
+      help "Also print operators"
+    ) <*> -- optOperators      = False
+    switch (
+      long "detailed" <>
+      short 'd' <>
+      help "Print symbols with accompanying signature"
+    ) <*> -- optDetailed       = False
+    switch (
+      long "qualified" <>
+      short 'q' <>
+      help "Qualify symbols"
+    )) <*> some (strArg "MODULE")
+debugComponentArgSpec = filesArgsSpec CmdDebugComponent
+checkArgSpec = filesArgsSpec CmdCheck
+expandArgSpec = filesArgsSpec CmdExpand
+infoArgSpec = CmdInfo <$>
+    strArg "FILE" <*>
+    strArg "SYMBOL"
+typeArgSpec = locArgSpec CmdType
+autoArgSpec = locArgSpec CmdAuto
+splitArgSpec = locArgSpec CmdSplit
+sigArgSpec = locArgSpec CmdSig
+refineArgSpec = locArgSpec CmdRefine <*> strArg "SYMBOL"

src/GHCMod/Options/DocUtils.hs

@@ -0,0 +1,14 @@
+module GHCMod.Options.DocUtils (
+  module PP,
+  desc,
+  code
+) where
+
+import Options.Applicative
+import Text.PrettyPrint.ANSI.Leijen as PP hiding ((<>), (<$>), int)
+
+desc :: [Doc] -> InfoMod a
+desc = footerDoc . Just . indent 2 . vsep
+
+code :: [String] -> Doc
+code x = vsep [line, indent 4 $ vsep $ map text x, line]

src/GHCMod/Version.hs

@@ -0,0 +1,16 @@
+module GHCMod.Version where
+
+import Paths_ghc_mod
+import Data.Version (showVersion)
+import Config (cProjectVersion)
+
+progVersion :: String -> String
+progVersion pf =
+    "ghc-mod"++pf++" version " ++ showVersion version ++ " compiled by GHC "
+                               ++ cProjectVersion ++ "\n"
+
+ghcModVersion :: String
+ghcModVersion = progVersion ""
+
+ghcModiVersion :: String
+ghcModiVersion = progVersion "i"