Lint.hs

{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module OptEnvConf.Lint
  ( LintError (..),
    LintErrorMessage (..),
    renderLintErrors,
    renderLintError,
    lintParser,
  )
where

import Autodocodec
import Control.Monad
import Control.Monad.Reader
import qualified Data.Aeson.Types as JSON
import Data.Either
import Data.Foldable
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as T
import GHC.Stack (SrcLoc, prettySrcLoc)
import OptEnvConf.Args
import OptEnvConf.Parser
import qualified OptEnvConf.Reader as OptEnvConf
import OptEnvConf.Setting
import OptEnvConf.Validation
import Text.Colour

data LintError = LintError
  { lintErrorSrcLoc :: !(Maybe SrcLoc),
    lintErrorMessage :: !LintErrorMessage
  }

data LintErrorMessage
  = LintErrorUndocumented
  | LintErrorEmptySetting
  | LintErrorDashInShort
  | LintErrorDashInLong !(NonEmpty Char)
  | LintErrorNoReaderForArgument
  | LintErrorNoMetavarForArgument
  | LintErrorNoReaderForOption
  | LintErrorNoDashedForOption
  | LintErrorNoMetavarForOption
  | LintErrorNoDashedForSwitch
  | LintErrorNoOptionOrSwitchForDashed
  | LintErrorNoReaderForEnvVar
  | LintErrorNoMetavarForEnvVar
  | LintErrorNoCommands
  | LintErrorUnreadableExample !String
  | LintErrorUndecodableExample !String
  | LintErrorConfigWithoutLoad
  | LintErrorManyInfinite

renderLintErrors :: NonEmpty LintError -> [Chunk]
renderLintErrors =
  unlinesChunks
    . ([fore red "Setting parser is invalid:"] :)
    . map ("  " :)
    . concatMap (([] :) . renderLintError)

renderLintError :: LintError -> [[Chunk]]
renderLintError LintError {..} =
  concat
    [ [[fore red "Invalid Setting:"]],
      case lintErrorMessage of
        LintErrorUndocumented ->
          [["missing ", functionChunk "help", "."]]
        LintErrorEmptySetting ->
          concat
            [ [ [ "This ",
                  functionChunk "setting",
                  " parses nothing."
                ]
              ],
              [ [ "Add an ",
                  functionChunk "argument",
                  ", ",
                  functionChunk "switch",
                  ", ",
                  functionChunk "option",
                  ", ",
                  functionChunk "env",
                  ", ",
                  functionChunk "conf",
                  ", or ",
                  functionChunk "value",
                  "."
                ]
              ]
            ]
        LintErrorDashInShort ->
          [ [functionChunk "short", " may not contain a '-'."],
            ["Found ", functionChunk "short", " '-'."]
          ]
        LintErrorDashInLong s ->
          [ [functionChunk "long", " may not start with a '-'."],
            ["Found ", functionChunk "long", " ", chunk $ T.pack $ show $ NE.toList s, "."],
            [ "Try ",
              functionChunk "long",
              " ",
              chunk $
                T.pack $
                  show $
                    let go = \case
                          [] -> []
                          '-' : cs -> go cs
                          c : cs -> c : cs
                     in go $ NE.toList s,
              " instead."
            ]
          ]
        LintErrorNoReaderForArgument ->
          [ [ functionChunk "argument",
              " has no ",
              functionChunk "reader",
              "."
            ]
          ]
        LintErrorNoMetavarForArgument ->
          [ [ functionChunk "argument",
              " has no ",
              functionChunk "metavar",
              "."
            ]
          ]
        LintErrorNoReaderForOption ->
          [ [ functionChunk "option",
              " or ",
              functionChunk "name",
              " has no ",
              functionChunk "reader",
              "."
            ]
          ]
        LintErrorNoDashedForOption ->
          [ [ functionChunk "option",
              " has no ",
              functionChunk "long",
              " or ",
              functionChunk "short",
              "."
            ]
          ]
        LintErrorNoMetavarForOption ->
          [ [ functionChunk "option",
              " or ",
              functionChunk "name",
              " has no ",
              functionChunk "metavar",
              "."
            ]
          ]
        LintErrorNoDashedForSwitch ->
          [ [ functionChunk "switch",
              " has no ",
              functionChunk "long",
              " or ",
              functionChunk "short",
              "."
            ]
          ]
        LintErrorNoOptionOrSwitchForDashed ->
          [ [ functionChunk "long",
              " or ",
              functionChunk "short",
              " has no ",
              functionChunk "option",
              " or ",
              functionChunk "switch",
              "."
            ]
          ]
        LintErrorNoReaderForEnvVar ->
          [ [ functionChunk "env",
              " or ",
              functionChunk "name",
              " has no ",
              functionChunk "reader",
              "."
            ]
          ]
        LintErrorNoMetavarForEnvVar ->
          [ [ functionChunk "env",
              " or ",
              functionChunk "name",
              " has no ",
              functionChunk "metavar",
              "."
            ]
          ]
        LintErrorNoCommands ->
          [ [ functionChunk "commands",
              " was called with an empty list."
            ]
          ]
        LintErrorUnreadableExample e ->
          [ [functionChunk "example", " was called with an example that none of the ", functionChunk "reader", "s succeed in reading."],
            ["Example: ", chunk $ T.pack e]
          ]
        LintErrorUndecodableExample e ->
          [ [functionChunk "example", " was called with an example that none of the ", functionChunk "conf", "s succeed in decoding."],
            ["Example: ", chunk $ T.pack e]
          ]
        LintErrorConfigWithoutLoad ->
          [ [ functionChunk "conf",
              " or ",
              functionChunk "name",
              " was called with no way to load configuration."
            ],
            [ "You can load configuration with ",
              functionChunk "withConfig",
              ", or explicitly not load any configuration with ",
              functionChunk "withoutConfig",
              "."
            ]
          ]
        LintErrorManyInfinite ->
          [ [ functionChunk "many",
              " or ",
              functionChunk "some",
              " was called with a parser that may succeed without consuming anything."
            ],
            ["This is not allowed because the parser would run infinitely."]
          ],
      maybe [] (pure . ("Defined at: " :) . pure . fore cyan . chunk . T.pack . prettySrcLoc) lintErrorSrcLoc
    ]

functionChunk :: Text -> Chunk
functionChunk = fore yellow . chunk

lintParser :: Parser a -> Maybe (NonEmpty LintError)
lintParser =
  either Just (const Nothing)
    . validationToEither
    . (`runReader` False) -- Set to true for parsers that have a way to load conf
    . runValidationT
    . go
  where
    -- Returns whether 'many' is allowed.
    -- 'many' is allowed only when every parse below consumes something.
    go :: Parser a -> ValidationT LintError (Reader Bool) Bool
    go = \case
      ParserPure _ -> pure False
      ParserAp p1 p2 -> do
        c1 <- go p1
        c2 <- go p2
        pure (c1 || c2)
      ParserSelect p1 p2 -> do
        c1 <- go p1
        c2 <- go p2
        pure (c1 || c2) -- TODO: is this right?
      ParserEmpty _ -> pure True
      ParserAlt p1 p2 -> do
        c1 <- go p1
        c2 <- go p2
        pure (c1 && c2) -- TODO: is this right?
        -- TODO lint if we don't try to parse anything consuming under many.
      ParserMany p -> do
        c <- go p
        when (not c) $
          mapValidationTFailure (LintError Nothing) $
            validationTFailure LintErrorManyInfinite
        pure c
      ParserSome p -> do
        c <- go p
        when (not c) $
          mapValidationTFailure (LintError Nothing) $
            validationTFailure LintErrorManyInfinite
        pure c
      ParserAllOrNothing _ p -> go p
      ParserCheck _ _ _ p -> go p
      ParserCommands mLoc ls -> do
        if null ls
          then validationTFailure $ LintError mLoc LintErrorNoCommands
          else and <$> traverse (go . commandParser) ls -- TODO is this right?
      ParserWithConfig _ p1 p2 -> do
        c1 <- go p1
        c2 <- local (const True) (go p2)
        pure $ c1 || c2
      ParserSetting mLoc Setting {..} -> mapValidationTFailure (LintError mLoc) $ do
        case settingHelp of
          Nothing ->
            -- Hidden values may be undocumented
            when (not settingHidden) $ validationTFailure LintErrorUndocumented
          Just _ -> pure ()
        when
          ( and
              [ not settingTryArgument,
                isNothing settingSwitchValue,
                not settingTryOption,
                isNothing settingEnvVars,
                isNothing settingConfigVals
              ]
          )
          $ validationTFailure LintErrorEmptySetting
        for_ settingDasheds $ \case
          DashedLong cs@('-' :| _) -> validationTFailure $ LintErrorDashInLong cs
          DashedShort '-' -> validationTFailure LintErrorDashInShort
          _ -> pure ()
        when (settingTryArgument && null settingReaders) $
          validationTFailure LintErrorNoReaderForArgument
        when (settingTryArgument && not settingHidden && isNothing settingMetavar) $
          validationTFailure LintErrorNoMetavarForArgument
        when (settingTryOption && null settingReaders) $
          validationTFailure LintErrorNoReaderForOption
        when (settingTryOption && null settingDasheds) $
          validationTFailure LintErrorNoDashedForOption
        when (settingTryOption && not settingHidden && isNothing settingMetavar) $
          validationTFailure LintErrorNoMetavarForOption
        when (isJust settingSwitchValue && null settingDasheds) $
          validationTFailure LintErrorNoDashedForSwitch
        when (not settingTryOption && isNothing settingSwitchValue && not (null settingDasheds)) $
          validationTFailure LintErrorNoOptionOrSwitchForDashed
        when (isJust settingEnvVars && null settingReaders) $
          validationTFailure LintErrorNoReaderForEnvVar
        when (isJust settingEnvVars && not settingHidden && isNothing settingMetavar) $
          validationTFailure LintErrorNoMetavarForEnvVar
        for_ settingExamples $ \e ->
          let canRead r = isRight $ OptEnvConf.runReader r e
           in when ((settingTryArgument || settingTryOption) && not (any canRead settingReaders)) $
                validationTFailure $
                  LintErrorUnreadableExample e
        for_ settingExamples $ \e ->
          let canDecode (ConfigValSetting _ c) = isRight $ JSON.parseEither (parseJSONVia c) (JSON.String (T.pack e))
           in when (isJust settingConfigVals && not (any canDecode (maybe [] NE.toList settingConfigVals))) $
                validationTFailure $
                  LintErrorUndecodableExample e
        hasConfig <- ask
        when (isJust settingConfigVals && not hasConfig) $
          validationTFailure LintErrorConfigWithoutLoad
        pure $
          -- 'many' is only allowed if something is being consumed and it's
          -- impossible for nothing to be consumed.
          and
            [ settingTryArgument || settingTryOption || isJust settingSwitchValue,
              null settingEnvVars,
              null settingConfigVals
            ]