Monadic pretty opt desc builder

ghc-mod.cabal

@@ -193,6 +193,7 @@ Executable ghc-mod
                       , 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/Commands.hs

@@ -13,14 +13,18 @@
 --
 -- 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 GHCMod.Options.Commands where
 
 import Options.Applicative
 import Options.Applicative.Types
 import Options.Applicative.Builder.Internal
 import Language.Haskell.GhcMod.Types
-import GHCMod.Options.DocUtils
 import Language.Haskell.GhcMod.Read
+import GHCMod.Options.DocUtils
+import GHCMod.Options.Help
 
 type Symbol = String
 type Expr = String
@@ -71,12 +75,14 @@ commands =
           $$  progDesc "List GHC -f<foo> flags"
     <> command "debug"
           $$  info (pure CmdDebug)
-          $$  progDesc
+          $$  progDesc' $$$ do
-              "Print debugging information. Please include the output in any bug\
+              "Print debugging information. Please include"
-              \ reports you submit"
+                \\ "the output in any bug reports you submit"
     <> command "debug-component"
           $$  info debugComponentArgSpec
-          $$  progDesc "Debugging information related to cabal component resolution"
+          $$  progDesc' $$$ do
+              "Debugging information related to cabal component"
+                \\ "resolution"
     <> command "boot"
           $$  info (pure CmdBoot)
           $$  progDesc "Internal command used by the emacs frontend"
@@ -84,12 +90,14 @@ commands =
     --       $$  info (pure CmdNukeCaches) idm
     <> command "root"
           $$  info (pure CmdRoot)
-          $$  progDesc
+          $$  progDesc'
-              "Try to find the project directory. For Cabal projects this is the\
+              "Try to find the project directory."
-              \ directory containing the cabal file, for projects that use a cabal\
+          <=> desc $$$ do
-              \ sandbox but have no cabal file this is the directory containing the\
+              "For Cabal projects this is the"
-              \ cabal.sandbox.config file and otherwise this is the current\
+                \\ "directory containing the cabal file, for projects"
-              \ directory"
+                \\ "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 legacyInteractiveArgSpec
           $$  progDesc "ghc-modi compatibility mode"
@@ -106,7 +114,9 @@ commands =
           $$  progDesc "List all modules that define SYMBOL"
     <> command "doc"
           $$  info docArgSpec
-          $$  progDesc "Try finding the html documentation directory for the given MODULE"
+          $$  progDesc' $$$ do
+              "Try finding the html documentation directory"
+                \\ "for the given MODULE"
     <> command "lint"
           $$  info lintArgSpec
           $$  progDesc "Check files using `hlint'"
@@ -115,18 +125,17 @@ commands =
           $$  progDesc "List symbols in a module"
     <> command "check"
           $$  info checkArgSpec
-          $$  progDesc
+          $$  progDesc' $$$ do
-              "Load the given files using GHC and report errors/warnings,\
+              "Load the given files using GHC and report errors/warnings,"
-              \ but don't produce output files"
+                \\ "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
+          $$  progDesc' $$$ do
-              "Look up an identifier in the context of FILE (like ghci's `:info')\
+              "Look up an identifier in the context"
-              \ MODULE is completely ignored and only allowed for backwards\
+                \\ "of FILE (like ghci's `:info')"
-              \ compatibility"
     <> command "type"
           $$  info typeArgSpec
           $$  progDesc "Get the type of the expression under (LINE,COL)"
@@ -134,50 +143,44 @@ commands =
           $$  info splitArgSpec
           $$  progDesc
                   "Split a function case by examining a type's constructors"
-          <=> desc [
+          <=> desc $$$ do
-                text "For example given the following code snippet:"
+                "For example given the following code snippet:"
-              , code [
+                code $ do
-                 "f :: [a] -> a"
+                  "f :: [a] -> a"
-               , "f x = _body"
+                  "f x = _body"
-               ]
+                "would be replaced by:"
-              , text "would be replaced by:"
+                code $ do
-              , code [
+                  "f :: [a] -> a"
-                 "f :: [a] -> a"
+                  "f [] = _body"
-               , "f [] = _body"
+                  "f (x:xs) = _body"
-               , "f (x:xs) = _body"
+                "(See https://github.com/kazu-yamamoto/ghc-mod/pull/274)"
-               ]
-              , text "(See https://github.com/kazu-yamamoto/ghc-mod/pull/274)"
-              ]
     <> command "sig"
           $$  info sigArgSpec
           $$  progDesc "Generate initial code given a signature"
-          <=> desc [
+          <=> desc $$$ do
-                text "For example when (LINE,COL) is on the signature in the following\
+              "For example when (LINE,COL) is on the"
-                \ code snippet:"
+                \\ "signature in the following code snippet:"
-              , code ["func :: [a] -> Maybe b -> (a -> b) -> (a,b)"]
+              code "func :: [a] -> Maybe b -> (a -> b) -> (a,b)"
-              , text "ghc-mod would add the following on the next line:"
+              "ghc-mod would add the following on the next line:"
-              , code ["func x y z f = _func_body"]
+              code "func x y z f = _func_body"
-              , text "(See: https://github.com/kazu-yamamoto/ghc-mod/pull/274)"
+              "(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 [
+          <=> desc $$$ do
-                text "For example if EXPR is `filter', which has type `(a -> Bool) -> [a]\
+              "For example if EXPR is `filter', which has type"
-                \ -> [a]' and (LINE,COL) is on the hole `_body' in the following\
+                \\ "`(a -> Bool) -> [a] -> [a]' and (LINE,COL) is on"
-                \ code snippet:"
+                \\ " the hole `_body' in the following code snippet:"
-              , code [
+              code $ do
-                   "filterNothing :: [Maybe a] -> [a]"
+                "filterNothing :: [Maybe a] -> [a]"
-                 , "filterNothing xs = _body"
+                "filterNothing xs = _body"
-                 ]
+              "ghc-mod changes the code to get a value of type"
-              , text "ghc-mod changes the code to get a value of type `[a]', which\
+                \\ " `[a]', which results in:"
-                \ results in:"
+              code "filterNothing xs = filter _body_1 _body_2"
-              , code [ "filterNothing xs = filter _body_1 _body_2" ]
+              "(See also: https://github.com/kazu-yamamoto/ghc-mod/issues/311)"
-              , text "(See also: https://github.com/kazu-yamamoto/ghc-mod/issues/311)"
-              ]
 
 interactiveCommandsSpec :: Parser GhcModCommands
 interactiveCommandsSpec =
@@ -186,14 +189,17 @@ interactiveCommandsSpec =
         <> command "map-file"
               $$  info (helper <*> mapArgSpec)
               $$  progDesc "tells ghc-modi to read `file.hs` source from stdin"
-              <=> footer "File end marker is `\\n\\EOT\\n`,\
+              <=> desc $$$ do
-              \ i.e. `\\x0A\\x04\\x0A`. `file.hs` may or may not exist, and should be\
+                "Works the same as second form of"
-              \ either full path, or relative to project root."
+                  \\ "`--map-file` CLI option."
         <> command "unmap-file"
               $$  info (helper <*> unmapArgSpec)
-              $$  progDesc "unloads previously mapped file, so that it's no longer mapped."
+              $$  progDesc' $$$ do
-              <=> footer "`file.hs` can be full path or relative to\
+                    "unloads previously mapped file,"
-              \ project root, either will work."
+                      \\ "so that it's no longer mapped."
+              <=> desc $$$ do
+                    "`file.hs` can be full path or relative"
+                      \\ "to project root, either will work."
         <> command "quit"
               $$ info (pure CmdQuit)
               $$ progDesc "Exit interactive mode"

src/GHCMod/Options/DocUtils.hs

@@ -15,10 +15,8 @@
 -- along with this program.  If not, see <http://www.gnu.org/licenses/>.
 
 module GHCMod.Options.DocUtils (
-  module PP,
-  desc,
-  code,
   ($$),
+  ($$$),
   (<=>),
   (<$$>),
   (<||>)
@@ -26,22 +24,19 @@ module GHCMod.Options.DocUtils (
 
 import Options.Applicative
 import Data.Monoid (Monoid) -- for ghc<7.10
-import Options.Applicative.Help.Pretty as PP hiding ((<$$>), int)
 
-desc :: [Doc] -> InfoMod a
+infixl 6 <||>
-desc = footerDoc . Just . indent 2 . vsep
+infixr 7 <$$>
-
+infixr 7 $$
-code :: [String] -> Doc
+infixr 8 <=>
-code x = vsep [line, indent 4 $ vsep $ map text x, line]
+infixr 9 $$$
-
-infixl 7 <||>
-infixr 8 <$$>
-infixr 8 $$
-infixr 9 <=>
 
 ($$) :: (a -> b) -> a -> b
 ($$) = ($)
 
+($$$) :: (a -> b) -> a -> b
+($$$) = ($)
+
 (<||>) :: Alternative a => a b -> a b -> a b
 (<||>) = (<|>)
 

src/GHCMod/Options/Help.hs

@@ -0,0 +1,67 @@
+-- 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, FlexibleInstances, GeneralizedNewtypeDeriving #-}
+
+module GHCMod.Options.Help where
+
+import Options.Applicative
+import Options.Applicative.Help.Pretty (Doc)
+import qualified Options.Applicative.Help.Pretty as PP
+import Control.Monad.State
+import GHC.Exts( IsString(..) )
+import Data.Maybe
+
+newtype MyDocM s a = MyDoc {unwrapState :: State s a}
+  deriving (Monad, Functor, Applicative, MonadState s)
+type MyDoc = MyDocM (Maybe Doc) ()
+
+instance IsString (MyDocM (Maybe Doc) a)  where
+    fromString = append . para
+
+para :: String -> Doc
+para = PP.fillSep . map PP.text . words
+
+append :: Doc -> MyDocM (Maybe Doc) a
+append s = modify' m >> return undefined
+  where
+    m :: Maybe Doc -> Maybe Doc
+    m Nothing = Just s
+    m (Just old) = Just $ old PP..$. s
+
+infixr 7 \\
+(\\) :: MyDoc -> MyDoc -> MyDoc
+(\\) a b = append $ doc a PP.<+> doc b
+
+doc :: MyDoc -> Doc
+doc = fromMaybe PP.empty . flip execState Nothing . unwrapState
+
+help' :: MyDoc -> Mod f a
+help' = helpDoc . Just . doc
+
+desc :: MyDoc -> InfoMod a
+desc = footerDoc . Just . doc . indent 2
+
+code :: MyDoc -> MyDoc
+code x = do
+  _ <- " "
+  indent 4 x
+  " "
+
+progDesc' :: MyDoc -> InfoMod a
+progDesc' = progDescDoc . Just . doc
+
+indent :: Int -> MyDoc -> MyDoc
+indent n = append . PP.indent n . doc