APISpec.hs

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

module OptEnvConf.APISpec (spec) where

import Autodocodec
import Data.Map (Map)
import Data.Text (Text)
import Data.Version
import GHC.Stack (HasCallStack, withFrozenCallStack)
import OptEnvConf
import OptEnvConf.Test
import OptEnvConf.TestUtils
import Test.Syd
import Text.Colour
import Text.Show.Pretty as Pretty

spec :: Spec
spec = do
  exampleParserSpec "empty" "empty parser" emptyParser
  exampleParserSpec "many-args" "many args parser" manyArgsParser
  exampleParserSpec "some-args" "some args parser" someArgsParser
  exampleParserSpec "optional" "optional argument" optionalParser
  exampleParserSpec "big-config" "example with a big configuration" bigConfigParser
  exampleParserSpec "sub-settings" "example with a sub settings" subSettingsParser
  exampleParserSpec "hidden" "example with hidden settings" hiddenParser
  exampleParserSpec "enable-disable" "enableDisableSwitch example" enableDisableParser
  exampleParserSpec "yes-no" "yesNoSwitch example" yesNoParser
  exampleParserSpec "enable-disable-optional" "enableDisableSwitch' example" enableDisableParser'
  exampleParserSpec "yes-no-optional" "yesNoSwitch' example" yesNoParser'
  exampleParserSpec "verbose" "verbosity example" verboseParser
  exampleParserSpec "same-help" "example where multiple options use the same help string" sameHelpParser
  exampleParserSpec "sum-type" "Sum type example" sumTypeParser
  exampleParserSpec "secret" "Secrets example" secretParser
  exampleParserSpec "with-default" "withDefault example" withDefaultParser
  exampleParserSpec "greet" "hello world example" greetParser
  exampleParserSpec "three-commands" "example with three commands" threeCommandsParser
  exampleParserSpec "sub-commands" "example with subcommands" subCommandsParser

exampleParserSpec :: (HasCallStack) => FilePath -> String -> Parser a -> Spec
exampleParserSpec dir progDesc p = withFrozenCallStack $ describe dir $ do
  let version = makeVersion [0, 0, 0]

  it "passes the linter" $
    parserLintTest p

  it "shows the parser in the same way" $
    goldenStringFile ("test_resources/docs/" <> dir <> "/show.txt") $
      case Pretty.parseValue (showParserABit (parserEraseSrcLocs p)) of
        Nothing -> expectationFailure "Error parsing value"
        Just v -> pure $ Pretty.valToStr v

  it "produces the same docs structure as before" $
    pureGoldenStringFile ("test_resources/docs/" <> dir <> "/docs.txt") $
      ppShow $
        parserDocs p

  it "produces the same opt docs structure as before" $
    pureGoldenStringFile ("test_resources/docs/" <> dir <> "/opt-docs.txt") $
      ppShow $
        parserOptDocs p

  it "produces the same env docs structure as before" $
    pureGoldenStringFile ("test_resources/docs/" <> dir <> "/env-docs.txt") $
      ppShow $
        parserConfDocs p

  it "produces the same conf docs structure as before" $
    pureGoldenStringFile ("test_resources/docs/" <> dir <> "/config-docs.txt") $
      ppShow $
        parserEnvDocs p

  it "documents the version page in the same way" $
    pureGoldenChunksFile ("test_resources/docs/" <> dir <> "/version.txt") $
      renderVersionPage dir version

  it "documents the help page in the same way" $
    pureGoldenChunksFile ("test_resources/docs/" <> dir <> "/help.txt") $
      renderHelpPage dir version progDesc $
        parserDocs p

  it "documents the short opt parser in the same way" $
    pureGoldenChunksFile ("test_resources/docs/" <> dir <> "/opt-short.txt") $
      renderShortOptDocs dir $
        parserOptDocs p

  it "documents the long opt parser in the same way" $
    pureGoldenChunksFile ("test_resources/docs/" <> dir <> "/opt-long.txt") $
      renderLongOptDocs $
        parserOptDocs p

  it "documents the env parser in the same way" $
    pureGoldenChunksFile ("test_resources/docs/" <> dir <> "/env.txt") $
      renderEnvDocs $
        parserEnvDocs p

  it "documents the conf parser in the same way" $
    pureGoldenChunksFile ("test_resources/docs/" <> dir <> "/config.txt") $
      renderConfDocs $
        parserConfDocs p

  it "documents the man page in the same way" $
    pureGoldenTextFile ("test_resources/docs/" <> dir <> "/man.txt") $
      renderChunksText WithoutColours $
        renderManPage dir version progDesc $
          parserDocs p

  it "renders the reference documentation in the same way" $
    pureGoldenChunksFile ("test_resources/docs/" <> dir <> "/reference.txt") $
      renderReferenceDocumentation dir $
        parserDocs p

  it "renders the Nix options the same way" $
    pureGoldenTextFile ("test_resources/docs/" <> dir <> "/nix-options.nix") $
      renderParserNixOptions p

sameHelpParser :: Parser (Either Int String, Bool)
sameHelpParser =
  withoutConfig $
    let h = help "int or string"
     in (,)
          <$> choice
            [ Left
                <$> setting
                  [ h,
                    name "int",
                    reader auto,
                    metavar "INT"
                  ],
              Right
                <$> setting
                  [ h,
                    name "string",
                    reader str,
                    metavar "STR"
                  ]
            ]
          <*> yesNoSwitch
            [ h,
              name "other",
              value True
            ]

data SumType
  = SumTypeA
  | SumTypeB
  deriving (Show)

instance HasCodec SumType where
  codec = bimapCodec parseSumType renderSumType codec

parseSumType :: String -> Either String SumType
parseSumType = \case
  "a" -> pure SumTypeA
  "b" -> pure SumTypeB
  s -> Left $ unwords ["Unknown 'SumType':", s]

renderSumType :: SumType -> String
renderSumType = \case
  SumTypeA -> "a"
  SumTypeB -> "b"

sumTypeParser :: Parser SumType
sumTypeParser =
  withoutConfig $
    let h = help "example"
     in choice
          [ setting
              [ help "a",
                switch SumTypeA,
                short 'a'
              ],
            setting
              [ help "b",
                switch SumTypeB,
                short 'b'
              ],
            setting
              [ h,
                reader $ eitherReader parseSumType,
                env "sum-type",
                metavar "SUM_TYPE"
              ],
            setting
              [ h,
                conf "sum-type"
              ],
            setting
              [ h,
                valueWithShown renderSumType SumTypeA
              ]
          ]

secretParser :: Parser (Text, Text, Text, Text, Text)
secretParser =
  withoutConfig $
    (,,,,)
      <$> secretTextFileSetting
        [ help "First example secret",
          name "first-secret-file"
        ]
      <*> secretTextFileOrBareSetting
        [ help "Second example secret, bare or in a file",
          name "second-secret"
        ]
      <*> secretTextFileOrBareSetting
        [ help "Second example secret, bare or in a file, only option",
          option,
          long "second-secret"
        ]
      <*> secretTextFileOrBareSetting
        [ help "Second example secret, bare or in a file, only env",
          env "second-secret"
        ]
      <*> secretTextFileOrBareSetting
        [ help "Second example secret, bare or in a file, only conf",
          conf "second-secret"
        ]

data FirstOrSecond = First | Second
  deriving (Show)

instance HasParser FirstOrSecond where
  settingsParser =
    -- This version has no default value, so we can add one with 'withDefault'
    choice
      [ setting
          [ help "first",
            switch First,
            short 'f',
            long "first"
          ],
        setting
          [ help "second",
            switch Second,
            short 's',
            long "second"
          ]
      ]

withDefaultParser :: Parser FirstOrSecond
withDefaultParser = withDefault Second settingsParser

data Greet = Greet !String !String !Bool

greetParser :: Parser Greet
greetParser =
  subEnv "GREET_" $
    withLocalYamlConfig $
      Greet
        <$> setting
          [ reader str,
            option,
            short 'g',
            long "greeting",
            metavar "GREETING",
            env "GREETING",
            conf "greeting",
            value "Hello",
            example "Greetings",
            help "Greeting to use"
          ]
        <*> setting
          [ reader str,
            argument,
            help "Who to greet",
            value "world",
            metavar "SUBJECT"
          ]
        <*> setting
          [ reader exists,
            switch True,
            short 'p',
            long "polite",
            env "POLITE",
            conf "polite",
            metavar "ANY",
            value False,
            help "Whether to be polite"
          ]

data BigConfig = BigConfig
  { bigConfigMap :: Map String (Map String Int),
    bigConfigSubObject :: Maybe Text
  }

instance HasCodec BigConfig where
  codec =
    object "BigConfig" $
      BigConfig
        <$> requiredField' "map" .= bigConfigMap
        <*> optionalField' "sub" .= bigConfigSubObject

bigConfigParser :: Parser BigConfig
bigConfigParser =
  withLocalYamlConfig $
    setting
      [ conf "big",
        help "big configuration object"
      ]

subSettingsParser :: Parser String
subSettingsParser =
  withLocalYamlConfig $
    subAll "foo" $
      subAll "bar" $
        setting
          [ reader str,
            name "quux",
            help "Example with sub-settings",
            metavar "STR"
          ]

manyArgsParser :: Parser [String]
manyArgsParser =
  many
    ( setting
        [ reader str,
          argument,
          help "Argument",
          metavar "ARGUMENT"
        ]
    )

someArgsParser :: Parser [String]
someArgsParser =
  some
    ( setting
        [ reader str,
          argument,
          help "Argument",
          metavar "ARGUMENT"
        ]
    )

data Optional = Optional (Maybe String)

optionalParser :: Parser Optional
optionalParser =
  Optional
    <$> optional
      ( setting
          [ reader str,
            argument,
            help "Argument",
            metavar "ARGUMENT"
          ]
      )

data Hidden = Hidden String

hiddenParser :: Parser Hidden
hiddenParser =
  Hidden
    <$> setting
      [ reader str,
        argument,
        hidden,
        metavar "STR",
        value "default",
        help "Example of a hidden setting"
      ]

data EnableDisable = EnableDisable Bool

enableDisableParser :: Parser EnableDisable
enableDisableParser =
  withoutConfig $
    EnableDisable
      <$> enableDisableSwitch
        [ long "example",
          help "Example of an enable/disable switch",
          env "EXAMPLE",
          conf "example",
          value True
        ]

enableDisableParser' :: Parser (Maybe EnableDisable)
enableDisableParser' =
  withoutConfig $
    fmap EnableDisable
      <$> optional
        ( enableDisableSwitch
            [ long "example",
              help "Example of an enable/disable switch",
              env "EXAMPLE",
              conf "example"
            ]
        )

data YesNo = YesNo Bool

yesNoParser :: Parser YesNo
yesNoParser =
  withoutConfig $
    YesNo
      <$> yesNoSwitch
        [ long "example",
          help "Example of a yes/no switch",
          env "EXAMPLE",
          conf "example",
          value True
        ]

yesNoParser' :: Parser (Maybe YesNo)
yesNoParser' =
  withoutConfig $
    fmap YesNo
      <$> optional
        ( yesNoSwitch
            [ long "example",
              help "Example of a yes/no switch",
              env "EXAMPLE",
              conf "example"
            ]
        )

data Empty = Empty

emptyParser :: Parser Empty
emptyParser =
  pure Empty

data ThreeCommands
  = One !String
  | Two !Int !Bool
  | Three

threeCommandsParser :: Parser ThreeCommands
threeCommandsParser =
  withoutConfig $
    commands
      [ command "one" "first" $
          One
            <$> setting
              [ help "argument",
                reader str,
                metavar "STR",
                argument
              ],
        command "two" "second" $
          Two
            <$> setting
              [ help "number",
                reader auto,
                option,
                metavar "INT",
                name "number",
                short 'n',
                shownExample 5
              ]
            <*> enableDisableSwitch
              [ help "enable extra",
                name "enable",
                value False
              ],
        command "three-very-long-command-name" "third" (pure Three),
        defaultCommand "one"
      ]

data SubCommands
  = Top !String
  | Sub !Sub1 !Sub2

subCommandsParser :: Parser SubCommands
subCommandsParser =
  withLocalYamlConfig $
    commands
      [ command "top" "command without subcommands" $
          Top
            <$> setting
              [ help "name",
                reader str,
                metavar "NAME",
                name "name",
                example "john"
              ],
        command "sub" "command with subcommands" $
          Sub <$> sub1Parser <*> sub2Parser
      ]

data Sub1 = A | B

sub1Parser :: Parser Sub1
sub1Parser =
  commands
    [ command "a" "A" $ pure A,
      command "b" "B" $ pure B
    ]

data Sub2 = C | D

sub2Parser :: Parser Sub2
sub2Parser =
  commands
    [ command "c" "C" $ pure C,
      command "d" "D" $ pure D,
      defaultCommand "c"
    ]

verboseParser :: Parser Int
verboseParser =
  length
    <$> many
      ( setting
          [ help "Verbosity level. Use multiple to increase verbosity",
            short 'v',
            switch ()
          ]
      )