From 92f53f7b3b188ed4921192205f9a5bdff02eb387 Mon Sep 17 00:00:00 2001 From: Nikolay Yakimov Date: Sun, 20 Dec 2015 13:48:47 +0300 Subject: [PATCH] Monadic pretty opt desc builder --- ghc-mod.cabal | 1 + src/GHCMod/Options/Commands.hs | 126 +++++++++++++++++---------------- src/GHCMod/Options/DocUtils.hs | 23 +++--- src/GHCMod/Options/Help.hs | 67 ++++++++++++++++++ 4 files changed, 143 insertions(+), 74 deletions(-) create mode 100644 src/GHCMod/Options/Help.hs diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 7c52d46..0f4c39e 100644 --- a/ghc-mod.cabal +++ b/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 diff --git a/src/GHCMod/Options/Commands.hs b/src/GHCMod/Options/Commands.hs index 1a774a6..0a6adb7 100644 --- a/src/GHCMod/Options/Commands.hs +++ b/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 . +{-# 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 flags" <> command "debug" $$ info (pure CmdDebug) - $$ progDesc - "Print debugging information. Please include the output in any bug\ - \ reports you submit" + $$ progDesc' $$$ do + "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" + $$ 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 - "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" + $$ progDesc' + "Try to find the project directory." + <=> desc $$$ do + "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 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 - "Load the given files using GHC and report errors/warnings,\ - \ but don't produce output files" + $$ progDesc' $$$ do + "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" + $$ progDesc' $$$ do + "Look up an identifier in the context" + \\ "of FILE (like ghci's `:info')" <> 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 [ - 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)" - ] + <=> desc $$$ do + "For example given the following code snippet:" + code $ do + "f :: [a] -> a" + "f x = _body" + "would be replaced by:" + code $ do + "f :: [a] -> a" + "f [] = _body" + "f (x:xs) = _body" + "(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)" - ] + <=> desc $$$ do + "For example when (LINE,COL) is on the" + \\ "signature in the following code snippet:" + code "func :: [a] -> Maybe b -> (a -> b) -> (a,b)" + "ghc-mod would add the following on the next line:" + code "func x y z f = _func_body" + "(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)" - ] + <=> desc $$$ do + "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 $ do + "filterNothing :: [Maybe a] -> [a]" + "filterNothing xs = _body" + "ghc-mod changes the code to get a value of type" + \\ " `[a]', which results in:" + code "filterNothing xs = filter _body_1 _body_2" + "(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`,\ - \ i.e. `\\x0A\\x04\\x0A`. `file.hs` may or may not exist, and should be\ - \ either full path, or relative to project root." + <=> desc $$$ do + "Works the same as second form of" + \\ "`--map-file` CLI option." <> command "unmap-file" $$ info (helper <*> unmapArgSpec) - $$ progDesc "unloads previously mapped file, so that it's no longer mapped." - <=> footer "`file.hs` can be full path or relative to\ - \ project root, either will work." + $$ progDesc' $$$ do + "unloads previously mapped file," + \\ "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" diff --git a/src/GHCMod/Options/DocUtils.hs b/src/GHCMod/Options/DocUtils.hs index dd5122d..4adcf2b 100644 --- a/src/GHCMod/Options/DocUtils.hs +++ b/src/GHCMod/Options/DocUtils.hs @@ -15,10 +15,8 @@ -- along with this program. If not, see . 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 -desc = footerDoc . Just . indent 2 . vsep - -code :: [String] -> Doc -code x = vsep [line, indent 4 $ vsep $ map text x, line] - -infixl 7 <||> -infixr 8 <$$> -infixr 8 $$ -infixr 9 <=> +infixl 6 <||> +infixr 7 <$$> +infixr 7 $$ +infixr 8 <=> +infixr 9 $$$ ($$) :: (a -> b) -> a -> b ($$) = ($) +($$$) :: (a -> b) -> a -> b +($$$) = ($) + (<||>) :: Alternative a => a b -> a b -> a b (<||>) = (<|>) diff --git a/src/GHCMod/Options/Help.hs b/src/GHCMod/Options/Help.hs new file mode 100644 index 0000000..2a81e16 --- /dev/null +++ b/src/GHCMod/Options/Help.hs @@ -0,0 +1,67 @@ +-- ghc-mod: Making Haskell development *more* fun +-- Copyright (C) 2015 Nikolay Yakimov +-- +-- 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 . +{-# 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