Merge pull request #745 from alanz/opts-in-lib

Move globalArgsSpec to Library, to get a consistent way of parsing command line

Language/Haskell/GhcMod/Options/DocUtils.hs

@@ -14,7 +14,7 @@
 -- You should have received a copy of the GNU Affero General Public License
 -- along with this program.  If not, see <http://www.gnu.org/licenses/>.
 
-module GHCMod.Options.DocUtils (
+module Language.Haskell.GhcMod.Options.DocUtils (
   ($$),
   ($$$),
   (<=>),

Language/Haskell/GhcMod/Options/Help.hs

@@ -15,7 +15,7 @@
 -- along with this program.  If not, see <http://www.gnu.org/licenses/>.
 {-# LANGUAGE OverloadedStrings, FlexibleInstances, GeneralizedNewtypeDeriving #-}
 
-module GHCMod.Options.Help where
+module Language.Haskell.GhcMod.Options.Help where
 
 import Options.Applicative
 import Options.Applicative.Help.Pretty (Doc)

Language/Haskell/GhcMod/Options/Options.hs

@@ -0,0 +1,173 @@
+-- ghc-mod: Making Haskell development *more* fun
+-- Copyright (C) 2015  Nikolay Yakimov <root@livid.pp.ru>
+--
+-- This program is free software: you can redistribute it and/or modify
+-- it under the terms of the GNU Affero General Public License as published by
+-- the Free Software Foundation, either version 3 of the License, or
+-- (at your option) any later version.
+--
+-- This program is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of
+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+-- GNU Affero General Public License for more details.
+--
+-- You should have received a copy of the GNU Affero General Public License
+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
+
+module Language.Haskell.GhcMod.Options.Options (
+    globalArgSpec
+  , parseCmdLineOptions
+) where
+
+import Options.Applicative
+import Options.Applicative.Types
+import Language.Haskell.GhcMod.Types
+import Control.Arrow
+import Data.Char (toUpper, toLower)
+import Data.List (intercalate)
+import Language.Haskell.GhcMod.Read
+import Language.Haskell.GhcMod.Options.DocUtils
+import Language.Haskell.GhcMod.Options.Help
+import Data.Monoid
+import Prelude
+
+-- | Parse a set of arguments according to the ghc-mod CLI flag spec, producing
+-- @Options@ set accordingly.
+parseCmdLineOptions :: [String] -> Maybe Options
+parseCmdLineOptions = getParseResult . execParserPure (prefs mempty) (info globalArgSpec mempty)
+
+splitOn :: Eq a => a -> [a] -> ([a], [a])
+splitOn c = second (drop 1) . break (==c)
+
+logLevelParser :: Parser GmLogLevel
+logLevelParser =
+    logLevelSwitch <*>
+           logLevelOption
+      <||> silentSwitch
+  where
+    logLevelOption =
+      option parseLL
+        $$  long "verbose"
+        <=> metavar "LEVEL"
+        <=> value GmWarning
+        <=> showDefaultWith showLL
+        <=> help' $$$ do
+          "Set log level ("
+            <> int' (fromEnum (minBound :: GmLogLevel))
+            <> "-"
+            <> int' (fromEnum (maxBound :: GmLogLevel))
+            <> ")"
+          "You can also use strings (case-insensitive):"
+          para'
+            $ intercalate ", "
+            $ map showLL ([minBound..maxBound] :: [GmLogLevel])
+    logLevelSwitch =
+      repeatAp succ' . length <$> many $$ flag' ()
+        $$  short 'v'
+        <=> help "Increase log level"
+    silentSwitch = flag' GmSilent
+        $$  long "silent"
+        <=> short 's'
+        <=> help "Be silent, set log level to 'silent'"
+    showLL = drop 2 . map toLower . show
+    repeatAp f n = foldr (.) id (replicate n f)
+    succ' x | x == maxBound = x
+            | otherwise     = succ x
+    parseLL = do
+      v <- readerAsk
+      let
+        il'= toEnum . min maxBound <$> readMaybe v
+        ll' = readMaybe ("Gm" ++ capFirst v)
+      maybe (readerError $ "Not a log level \"" ++ v ++ "\"") return $ ll' <|> il'
+    capFirst (h:t) = toUpper h : map toLower t
+    capFirst [] = []
+
+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"
+
+-- | An optparse-applicative @Parser@ sepcification for @Options@ so that
+-- applications making use of the ghc-mod API can have a consistent way of
+-- parsing global options.
+globalArgSpec :: Parser Options
+globalArgSpec = Options
+      <$> outputOptsSpec
+      <*> programsArgSpec
+      <*> many $$ strOption
+          $$  long "ghcOpt"
+          <=> long "ghc-option"
+          <=> short 'g'
+          <=> metavar "OPT"
+          <=> help "Option to be passed to GHC"
+      <*> many fileMappingSpec
+      <*> strOption
+          $$  long "encoding"
+          <=> value "UTF-8"
+          <=> showDefault
+          <=> help "I/O encoding"
+  where
+    fileMappingSpec =
+      getFileMapping . splitOn '=' <$> strOption
+        $$  long "map-file"
+        <=> metavar "MAPPING"
+        <=> fileMappingHelp
+    fileMappingHelp = help' $ do
+        "Redirect one file to another"
+        "--map-file \"file1.hs=file2.hs\""
+        indent 4 $ do
+          "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\""
+        indent 4 $ do
+          "can be used to tell ghc-mod that it should take"
+            \\ "source code for `file.hs` from stdin. File end"
+            \\ "marker is `\\n\\EOT\\n`, i.e. `\\x0A\\x04\\x0A`."
+            \\ "`file.hs` may or may not exist, and should be"
+            \\ "either full path, or relative to project root."
+    getFileMapping = second (\i -> if null i then Nothing else Just i)

ghc-mod.cabal

@@ -153,6 +153,10 @@ Library
                         Language.Haskell.GhcMod.Types
                         Language.Haskell.GhcMod.Utils
                         Language.Haskell.GhcMod.World
+
+                        Language.Haskell.GhcMod.Options.Options
+                        Language.Haskell.GhcMod.Options.DocUtils
+                        Language.Haskell.GhcMod.Options.Help
   Other-Modules:        Paths_ghc_mod
                         Utils
                         Data.Binary.Generic
@@ -188,6 +192,7 @@ Library
                       , extra             == 1.4.*
                       , pipes             == 4.1.*
                       , safe              < 0.4 && >= 0.3.9
+                      , optparse-applicative >=0.11.0 && <0.13.0
                       , template-haskell
                       , syb
   if impl(ghc < 7.8)
@@ -200,9 +205,7 @@ Executable ghc-mod
                       , GHCMod.Options
                       , GHCMod.Options.Commands
                       , GHCMod.Version
-                      , GHCMod.Options.DocUtils
                       , GHCMod.Options.ShellParse
-                      , GHCMod.Options.Help
   GHC-Options:          -Wall -fno-warn-deprecations -threaded
   Default-Extensions:   ConstraintKinds, FlexibleContexts
   HS-Source-Dirs:       src

src/GHCMod/Options.hs

@@ -25,14 +25,10 @@ module GHCMod.Options (
 import Options.Applicative
 import Options.Applicative.Types
 import Language.Haskell.GhcMod.Types
-import Control.Arrow
-import Data.Char (toUpper, toLower)
-import Data.List (intercalate)
-import Language.Haskell.GhcMod.Read
 import GHCMod.Options.Commands
 import GHCMod.Version
-import GHCMod.Options.DocUtils
-import GHCMod.Options.Help
+import Language.Haskell.GhcMod.Options.DocUtils
+import Language.Haskell.GhcMod.Options.Options
 import GHCMod.Options.ShellParse
 
 parseArgs :: IO (Options, GhcModCommands)
@@ -74,133 +70,3 @@ helpVersion =
 argAndCmdSpec :: Parser (Options, GhcModCommands)
 argAndCmdSpec = (,) <$> globalArgSpec <*> commandsSpec
 
-splitOn :: Eq a => a -> [a] -> ([a], [a])
-splitOn c = second (drop 1) . break (==c)
-
-logLevelParser :: Parser GmLogLevel
-logLevelParser =
-    logLevelSwitch <*>
-           logLevelOption
-      <||> silentSwitch
-  where
-    logLevelOption =
-      option parseLL
-        $$  long "verbose"
-        <=> metavar "LEVEL"
-        <=> value GmWarning
-        <=> showDefaultWith showLL
-        <=> help' $$$ do
-          "Set log level ("
-            <> int' (fromEnum (minBound :: GmLogLevel))
-            <> "-"
-            <> int' (fromEnum (maxBound :: GmLogLevel))
-            <> ")"
-          "You can also use strings (case-insensitive):"
-          para'
-            $ intercalate ", "
-            $ map showLL ([minBound..maxBound] :: [GmLogLevel])
-    logLevelSwitch =
-      repeatAp succ' . length <$> many $$ flag' ()
-        $$  short 'v'
-        <=> help "Increase log level"
-    silentSwitch = flag' GmSilent
-        $$  long "silent"
-        <=> short 's'
-        <=> help "Be silent, set log level to 'silent'"
-    showLL = drop 2 . map toLower . show
-    repeatAp f n = foldr (.) id (replicate n f)
-    succ' x | x == maxBound = x
-            | otherwise     = succ x
-    parseLL = do
-      v <- readerAsk
-      let
-        il'= toEnum . min maxBound <$> readMaybe v
-        ll' = readMaybe ("Gm" ++ capFirst v)
-      maybe (readerError $ "Not a log level \"" ++ v ++ "\"") return $ ll' <|> il'
-    capFirst (h:t) = toUpper h : map toLower t
-    capFirst [] = []
-
-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
-      <*> programsArgSpec
-      <*> many $$ strOption
-          $$  long "ghcOpt"
-          <=> long "ghc-option"
-          <=> short 'g'
-          <=> metavar "OPT"
-          <=> help "Option to be passed to GHC"
-      <*> many fileMappingSpec
-      <*> strOption
-          $$  long "encoding"
-          <=> value "UTF-8"
-          <=> showDefault
-          <=> help "I/O encoding"
-  where
-    fileMappingSpec =
-      getFileMapping . splitOn '=' <$> strOption
-        $$  long "map-file"
-        <=> metavar "MAPPING"
-        <=> fileMappingHelp
-    fileMappingHelp = help' $ do
-        "Redirect one file to another"
-        "--map-file \"file1.hs=file2.hs\""
-        indent 4 $ do
-          "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\""
-        indent 4 $ do
-          "can be used to tell ghc-mod that it should take"
-            \\ "source code for `file.hs` from stdin. File end"
-            \\ "marker is `\\n\\EOT\\n`, i.e. `\\x0A\\x04\\x0A`."
-            \\ "`file.hs` may or may not exist, and should be"
-            \\ "either full path, or relative to project root."
-    getFileMapping = second (\i -> if null i then Nothing else Just i)

src/GHCMod/Options/Commands.hs

@@ -23,8 +23,8 @@ import Options.Applicative.Types
 import Options.Applicative.Builder.Internal
 import Language.Haskell.GhcMod.Types
 import Language.Haskell.GhcMod.Read
-import GHCMod.Options.DocUtils
-import GHCMod.Options.Help
+import Language.Haskell.GhcMod.Options.DocUtils
+import Language.Haskell.GhcMod.Options.Help
 
 type Symbol = String
 type Expr = String