Add --config-help option (#1491)

src/Data/Aeson/Extended.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeSynonymInstances #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE LambdaCase #-}
@@ -12,8 +14,10 @@ module Data.Aeson.Extended (
   , (.:?)
   -- * JSON Parser that emits warnings
   , DescriptiveParser
+  , Describe(..)
   , JSONWarning (..)
   , withObjectWarnings
+  , prettyDesc
   , jsonSubWarnings
   , jsonSubWarningsT
   , jsonSubWarningsTT
@@ -29,23 +33,24 @@ module Data.Aeson.Extended (
   , (..!=)
   ) where
 
-import Control.Applicative
-import Control.Monad.Logger (MonadLogger, logWarn)
-import Control.Monad.Trans (lift)
-import Control.Monad.Trans.Writer.Strict (WriterT, mapWriterT, runWriterT, tell)
-import Data.Aeson as Export hiding ((.:), (.:?))
+import           Control.Applicative
+import           Control.Monad.Logger (MonadLogger, logWarn)
+import           Control.Monad.Trans (lift)
+import           Control.Monad.Trans.Writer.Strict (WriterT, mapWriterT, runWriterT, tell)
 import qualified Data.Aeson as A
-import Data.Aeson.Types hiding ((.:), (.:?))
+import           Data.Aeson as Export hiding ((.:), (.:?))
+import           Data.Aeson.Types hiding ((.:), (.:?))
 import qualified Data.HashMap.Strict as HashMap
-import Data.Typeable
-import Data.Monoid
-import Data.Set (Set)
+import           Data.Map.Strict (Map)
+import           Data.Monoid
+import           Data.Proxy
+import           Data.Set (Set)
 import qualified Data.Set as Set
-import Data.Text (unpack, Text)
+import           Data.Text (unpack, Text)
 import qualified Data.Text as T
-import Data.Traversable
+import           Data.Traversable
 import qualified Data.Traversable as Traversable
-import Prelude -- Fix redundant import warnings
+import           Prelude -- Fix redundant import warnings
 
 -- | Extends @.:@ warning to include field name.
 (.:) :: FromJSON a => Object -> Text -> Parser a
@@ -57,26 +62,42 @@ import Prelude -- Fix redundant import warnings
 (.:?) o p = modifyFailure (("failed to parse field '" <> unpack p <> "': ") <>) (o A..:? p)
 {-# INLINE (.:?) #-}
 
+class Describe a  where
+    describe :: Proxy a -> Text
+
+instance Describe Object where describe _ = "object"
+instance Describe Bool where describe _ = "boolean"
+instance Describe Text where describe _ = "string"
+instance Describe Char where describe _ = "character"
+instance Describe Int where describe _ = "integer"
+instance Describe a => Describe [a] where
+    describe _ = case describe (Proxy :: Proxy a) of
+                   "character" -> "string"
+                   _ -> "list of " <> describe (Proxy :: Proxy a) <> "s"
+instance Describe a => Describe (Set a) where
+    describe _ = "set of " <> describe (Proxy :: Proxy a) <> "s"
+instance Describe (Map k v) where describe _ = "mapping"
+
 -- | 'DescriptiveParser' version of @.:@.
 (..:)
-    :: forall a. (Typeable a,FromJSON a)
+    :: forall a. (FromJSON a,Describe a)
     => Object -> Text -> DescriptiveParser a
 o ..: k =
     tellJSONField k *>
     DescriptiveParser
     { runDescriptiveParser = lift (o .: k)
-    , describeDescriptiveParser = DescField (Link k) (typeOf (undefined :: a))
+    , describeDescriptiveParser = DescField (Link k) (describe (Proxy :: Proxy a))
     }
 
 -- | 'DescriptiveParser' version of @.:?@.
 (..:?)
-    :: forall a. (FromJSON a,Typeable a)
+    :: forall a. (FromJSON a,Describe a)
     => Object -> Text -> DescriptiveParser (Maybe a)
 o ..:? k =
     tellJSONField k *>
     DescriptiveParser
     { runDescriptiveParser = (lift (o .:? k))
-    , describeDescriptiveParser = DescOptionalField k (typeOf (undefined :: a))
+    , describeDescriptiveParser = DescOptionalField k (describe (Proxy :: Proxy a))
     }
 
 -- | 'DescriptiveParser' version of @.!=@.
@@ -228,8 +249,8 @@ data Desc
     = DescEmpty
     | DescAnd ![Desc]
     | DescOr ![Desc]
-    | DescField !Chain !TypeRep
-    | DescOptionalField !Text !TypeRep
+    | DescField !Chain !Text
+    | DescOptionalField !Text !Text
     | DescNotEqual !Desc
     deriving (Show)
 
@@ -302,7 +323,7 @@ data Chain
 -- | Chain the list of parsers. This allows us to have some dependency
 -- without monads.
 chainMaybe
-    :: forall a. (FromJSON a, Typeable a)
+    :: forall a. (FromJSON a, Describe a)
     => Object -> Chain -> DescriptiveParser (Maybe a)
 chainMaybe o chain =
     case chain of
@@ -315,5 +336,19 @@ chainMaybe o chain =
                                             Just o' ->
                                                 runDescriptiveParser
                                                     (chainMaybe o' c)
-            , describeDescriptiveParser = DescField chain (typeOf (undefined :: a))
+            , describeDescriptiveParser = DescField chain (describe (Proxy :: Proxy a))
             }
+
+prettyDesc :: Desc -> Text
+prettyDesc = go
+  where
+    go (DescAnd xs) = T.unlines (map go xs)
+    go (DescOr xs) = "One of:\n" <> indent (T.intercalate "\nOR\n" (map go xs))
+    go DescEmpty = ""
+    go (DescField f t) = renderChain f <> ": " <> t <> "" <> " [optional]"
+    go (DescOptionalField f t) =
+        f <> ": " <> t <> " [optional]"
+    go (DescNotEqual n) = go n
+    indent = T.unlines . map ("  " <>) . T.lines
+    renderChain (Link x) = x
+    renderChain (Chain this that) = this <> "." <> renderChain that

src/Stack/Options.hs

@@ -44,6 +44,7 @@ import           Options.Applicative.Builder.Extra
 import           Options.Applicative.Types (fromM, oneM, readerAsk)
 import           Stack.Clean (CleanOpts(..))
 import           Stack.Config (packagesParser)
+import           Stack.Types.Config (describeConfig)
 import           Stack.ConfigCmd
 import           Stack.Constants (stackProgName)
 import           Stack.Coverage (HpcReportOpts(..))
@@ -568,7 +569,13 @@ execOptsExtraParser = eoPlainParser <|>
 globalOptsParser :: Bool -> Maybe LogLevel -> Parser GlobalOptsMonoid
 globalOptsParser hide0 defLogLevel =
     GlobalOptsMonoid <$>
-    optional (strOption (long Docker.reExecArgName <> hidden <> internal)) <*>
+    (optional (abortOption
+                   (InfoMsg
+                        ("The following YAML settings are supported: \n\n" <>
+                         T.unpack describeConfig)) $
+               long "config-help" <>
+               help "Show all available configuration (.yaml file) options") *>
+    optional (strOption (long Docker.reExecArgName <> hidden <> internal))) <*>
     optional (option auto (long dockerEntrypointArgName <> hidden <> internal)) <*>
     logLevelOptsParser hide0 defLogLevel <*>
     configOptsParser hide0 <*>

src/Stack/Types/Config.hs

@@ -10,6 +10,7 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 
 -- | The Config type.
 
@@ -119,6 +120,8 @@ module Stack.Types.Config
   ,SetupInfoLocation(..)
   -- ** Docker entrypoint
   ,DockerEntrypoint(..)
+  -- ** Documentation
+  ,describeConfig
   ) where
 
 import           Control.Applicative
@@ -132,7 +135,7 @@ import           Data.Aeson.Extended
                  (ToJSON, toJSON, FromJSON, parseJSON, withText, object, jsonValidate,
                   (.=), (..:), (..:?), (..!=), Value(String, Object),Chain (..), chainMaybe,
                   withObjectWarnings, DescriptiveParser, Object, jsonSubWarnings, JSONWarning,
-                  jsonSubWarningsT, jsonSubWarningsTT)
+                  jsonSubWarningsT, jsonSubWarningsTT, Describe(..), prettyDesc, describeDescriptiveParser)
 import           Data.Attoparsec.Args
 import           Data.Binary (Binary)
 import           Data.ByteString (ByteString)
@@ -276,6 +279,10 @@ data Config =
          -- match cabal.
          }
 
+-- | Description of the config parser.
+describeConfig :: Text
+describeConfig = prettyDesc (describeDescriptiveParser (parseConfigMonoidJSON mempty))
+
 -- | Which packages to ghc-options on the command line apply to?
 data ApplyGhcOptions = AGOTargets -- ^ all local targets
                      | AGOLocals -- ^ all local packages, even non-targets
@@ -330,6 +337,8 @@ instance FromJSON (PackageIndex, [JSONWarning]) where
             , indexRequireHashes = reqHashes
             }|])
 
+instance Describe IndexName where describe _ = "package index name"
+
 -- | Unique name for a package index
 newtype IndexName = IndexName { unIndexName :: ByteString }
     deriving (Show, Eq, Ord, Hashable, Binary)
@@ -562,6 +571,8 @@ instance FromJSON (PackageEntry, [JSONWarning]) where
         <*> jsonSubWarnings (o ..: "location")
         <*> o ..:? "subdirs" ..!= []) v
 
+instance Describe PackageLocation where describe _ = "package location"
+
 data PackageLocation
     = PLFilePath FilePath
     -- ^ Note that we use @FilePath@ and not @Path@s. The goal is: first parse
@@ -962,6 +973,8 @@ parseConfigMonoidJSON obj = $(ado [|do
                         Right x -> return $ Just x
         return (name, b)
 
+instance Describe a => Describe (a,[JSONWarning]) where describe _ = describe (Proxy :: Proxy a)
+
 configMonoidWorkDirName :: Text
 configMonoidWorkDirName = "work-dir"
 
@@ -1594,3 +1607,20 @@ data DockerEntrypoint = DockerEntrypoint
     { deUidGid :: !(Maybe (UserID, GroupID))
       -- ^ UID/GID of host user, if we wish to perform UID/GID switch in container
     } deriving (Read,Show)
+
+instance Describe VersionCheck where describe _ = "version check"
+instance Describe PvpBounds where describe _ = "PVP bounds"
+instance Describe PackageIndex where describe _ = "package index"
+instance Describe SetupInfoLocation where describe _ = "setup info location"
+instance Describe GHCVariant where describe _ = "GHC variant"
+instance Describe ApplyGhcOptions where describe _ = "GHC options"
+instance Describe CompilerVersion where describe _ = "compiler version"
+instance Describe Resolver where describe _ = "resolver"
+instance Describe PackageEntry where describe _ = "package entry"
+instance Describe SCM where describe _ = "SCM"
+instance Describe Version where describe _ = "version"
+instance Describe DownloadInfo where describe _ = "download info"
+instance Describe PackageIdentifier where describe _ = "package identifier"
+instance Describe DockerOptsMonoid where describe _ = "docker options"
+instance Describe ImageOptsMonoid where describe _ = "image options"
+instance Describe NixOptsMonoid where describe _ = "nix options"

src/Stack/Types/Docker.hs

@@ -213,6 +213,9 @@ data DockerMonoidRepoOrImage
   | DockerMonoidImage String
   deriving (Show)
 
+instance Describe VersionRangeJSON where describe _ = "version range"
+instance Describe Mount where describe _ = "mount volume"
+
 -- | Newtype for non-orphan FromJSON instance.
 newtype VersionRangeJSON = VersionRangeJSON { unVersionRangeJSON :: VersionRange }
   deriving Show

src/Stack/Types/Image.hs

@@ -44,6 +44,7 @@ data ImageDockerOptsMonoid = ImageDockerOptsMonoid
     , imgDockerMonoidImageName :: !(Maybe String)
     } deriving (Show)
 
+instance Describe (ImageDockerOptsMonoid,a) where describe _ = "docker options"
 instance FromJSON (ImageOptsMonoid, [JSONWarning]) where
     parseJSON = withObjectWarnings
             "ImageOptsMonoid"