-- |
--
-- Module      : Ronn.Options.Applicative
-- Copyright   : (c) 2024 Patrick Brisbin
-- License     : AGPL-3
-- Maintainer  : pbrisbin@gmail.com
-- Stability   : experimental
-- Portability : POSIX
module Ronn.Options.Applicative
  ( optSynopsis
  , optDefinitions
  ) where

import Prelude

import Control.Monad (void)
import Data.List (intersperse, sortBy)
import Data.String (IsString (..))
import Data.Text (Text)
import Options.Applicative (Parser)
import Options.Applicative.Common (mapParser, treeMapParser)
import Options.Applicative.Help.Chunk (Chunk (..))
import Options.Applicative.Help.Pretty (Doc)
import Options.Applicative.Help.Pretty qualified as Pretty
import Options.Applicative.Types
  ( OptName (..)
  , OptProperties (..)
  , OptReader (..)
  , OptTree (..)
  , Option (..)
  )
import Ronn.AST

optSynopsis :: Parser a -> [Part]
optSynopsis :: forall a. Parser a -> [Part]
optSynopsis = Bool -> OptTree (Option ()) -> [Part]
go Bool
False (OptTree (Option ()) -> [Part])
-> (Parser a -> OptTree (Option ())) -> Parser a -> [Part]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall x. ArgumentReachability -> Option x -> Option ())
-> Parser a -> OptTree (Option ())
forall b a.
(forall x. ArgumentReachability -> Option x -> b)
-> Parser a -> OptTree b
treeMapParser ((Option x -> Option ())
-> ArgumentReachability -> Option x -> Option ()
forall a b. a -> b -> a
const Option x -> Option ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void)
 where
  go :: Bool -> OptTree (Option ()) -> [Part]
  go :: Bool -> OptTree (Option ()) -> [Part]
go Bool
nested = \case
    Leaf Option ()
o -> [Option () -> Part
forall x. Option x -> Part
optSynopsisPart Option ()
o]
    MultNode [OptTree (Option ())]
ts -> (OptTree (Option ()) -> [Part]) -> [OptTree (Option ())] -> [Part]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Bool -> OptTree (Option ()) -> [Part]
go Bool
True) [OptTree (Option ())]
ts
    AltNode AltNodeType
_ [Leaf Option ()
o]
      | FlagReader {} <- Option () -> OptReader ()
forall a. Option a -> OptReader a
optMain Option ()
o -> [Part -> Part
Brackets (Part -> Part) -> Part -> Part
forall a b. (a -> b) -> a -> b
$ Option () -> Part
forall x. Option x -> Part
optSynopsisPart Option ()
o] -- optional o
      | Bool
otherwise -> [Option () -> Part
forall x. Option x -> Part
optSynopsisPart Option ()
o]
    AltNode AltNodeType
_ [OptTree (Option ())]
ts ->
      [ (if Bool
nested then Part -> Part
Parens else Part -> Part
forall a. a -> a
id) (Part -> Part) -> Part -> Part
forall a b. (a -> b) -> a -> b
$
          [Part] -> Part
Concat ([Part] -> Part) -> [Part] -> Part
forall a b. (a -> b) -> a -> b
$
            Part -> [Part] -> [Part]
forall a. a -> [a] -> [a]
intersperse Part
" \\| " ([Part] -> [Part]) -> [Part] -> [Part]
forall a b. (a -> b) -> a -> b
$
              (OptTree (Option ()) -> [Part]) -> [OptTree (Option ())] -> [Part]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Bool -> OptTree (Option ()) -> [Part]
go Bool
True) [OptTree (Option ())]
ts
      ]
    BindNode OptTree (Option ())
t -> Bool -> OptTree (Option ()) -> [Part]
go Bool
True OptTree (Option ())
t

optSynopsisPart :: Option x -> Part
optSynopsisPart :: forall x. Option x -> Part
optSynopsisPart Option x
o = Part -> Part
bracketize Part
go
 where
  go :: Part
go = case Option x -> OptReader x
forall a. Option a -> OptReader a
optMain Option x
o of
    OptReader [OptName]
names CReader x
_ String -> ParseError
_ ->
      let mv :: String
mv = OptProperties -> String
propMetaVar (OptProperties -> String) -> OptProperties -> String
forall a b. (a -> b) -> a -> b
$ Option x -> OptProperties
forall a. Option a -> OptProperties
optProps Option x
o
      in  [Part] -> Part
Concat ([Part] -> Part) -> [Part] -> Part
forall a b. (a -> b) -> a -> b
$ Part -> [Part] -> [Part]
forall a. a -> [a] -> [a]
intersperse Part
"\\|" ([Part] -> [Part]) -> [Part] -> [Part]
forall a b. (a -> b) -> a -> b
$ Maybe String -> [OptName] -> [Part]
renderNames (String -> Maybe String
forall a. a -> Maybe a
Just String
mv) [OptName]
names
    FlagReader [OptName]
names x
_ ->
      [Part] -> Part
Concat ([Part] -> Part) -> [Part] -> Part
forall a b. (a -> b) -> a -> b
$ Part -> [Part] -> [Part]
forall a. a -> [a] -> [a]
intersperse Part
"\\|" ([Part] -> [Part]) -> [Part] -> [Part]
forall a b. (a -> b) -> a -> b
$ Maybe String -> [OptName] -> [Part]
renderNames Maybe String
forall a. Maybe a
Nothing [OptName]
names
    ArgReader {} ->
      case OptProperties -> Maybe String
propShowDefault (OptProperties -> Maybe String) -> OptProperties -> Maybe String
forall a b. (a -> b) -> a -> b
$ Option x -> OptProperties
forall a. Option a -> OptProperties
optProps Option x
o of
        Maybe String
Nothing -> Part -> Part
Variable (Part -> Part) -> Part -> Part
forall a b. (a -> b) -> a -> b
$ String -> Part
forall a. IsString a => String -> a
fromString (String -> Part) -> String -> Part
forall a b. (a -> b) -> a -> b
$ OptProperties -> String
propMetaVar (OptProperties -> String) -> OptProperties -> String
forall a b. (a -> b) -> a -> b
$ Option x -> OptProperties
forall a. Option a -> OptProperties
optProps Option x
o
        Just {} -> Part -> Part
Brackets (Part -> Part) -> Part -> Part
forall a b. (a -> b) -> a -> b
$ String -> Part
forall a. IsString a => String -> a
fromString (String -> Part) -> String -> Part
forall a b. (a -> b) -> a -> b
$ OptProperties -> String
propMetaVar (OptProperties -> String) -> OptProperties -> String
forall a b. (a -> b) -> a -> b
$ Option x -> OptProperties
forall a. Option a -> OptProperties
optProps Option x
o
    CmdReader {} -> Part
"" -- TODO
  bracketize :: Part -> Part
bracketize = case OptProperties -> Maybe String
propShowDefault (OptProperties -> Maybe String) -> OptProperties -> Maybe String
forall a b. (a -> b) -> a -> b
$ Option x -> OptProperties
forall a. Option a -> OptProperties
optProps Option x
o of
    Maybe String
Nothing -> Part -> Part
forall a. a -> a
id
    Just {} -> Part -> Part
Brackets

optDefinitions :: Parser a -> [Definition]
optDefinitions :: forall a. Parser a -> [Definition]
optDefinitions = (forall x. ArgumentReachability -> Option x -> Definition)
-> Parser a -> [Definition]
forall b a.
(forall x. ArgumentReachability -> Option x -> b)
-> Parser a -> [b]
mapParser ArgumentReachability -> Option x -> Definition
forall x. ArgumentReachability -> Option x -> Definition
forall a x. a -> Option x -> Definition
optDefinition

optDefinition :: a -> Option x -> Definition
optDefinition :: forall a x. a -> Option x -> Definition
optDefinition a
_ Option x
o =
  Definition
    { $sel:name:Definition :: Part
name = case Option x -> OptReader x
forall a. Option a -> OptReader a
optMain Option x
o of
        OptReader [OptName]
names CReader x
_ String -> ParseError
_ ->
          let mv :: String
mv = OptProperties -> String
propMetaVar (OptProperties -> String) -> OptProperties -> String
forall a b. (a -> b) -> a -> b
$ Option x -> OptProperties
forall a. Option a -> OptProperties
optProps Option x
o
          in  [Part] -> Part
Concat ([Part] -> Part) -> [Part] -> Part
forall a b. (a -> b) -> a -> b
$ Part -> [Part] -> [Part]
forall a. a -> [a] -> [a]
intersperse Part
", " ([Part] -> [Part]) -> [Part] -> [Part]
forall a b. (a -> b) -> a -> b
$ Maybe String -> [OptName] -> [Part]
renderNames (String -> Maybe String
forall a. a -> Maybe a
Just String
mv) [OptName]
names
        FlagReader [OptName]
names x
_ ->
          [Part] -> Part
Concat ([Part] -> Part) -> [Part] -> Part
forall a b. (a -> b) -> a -> b
$ Part -> [Part] -> [Part]
forall a. a -> [a] -> [a]
intersperse Part
", " ([Part] -> [Part]) -> [Part] -> [Part]
forall a b. (a -> b) -> a -> b
$ Maybe String -> [OptName] -> [Part]
renderNames Maybe String
forall a. Maybe a
Nothing [OptName]
names
        ArgReader {} -> Part -> Part
Code (Part -> Part) -> Part -> Part
forall a b. (a -> b) -> a -> b
$ String -> Part
forall a. IsString a => String -> a
fromString (String -> Part) -> String -> Part
forall a b. (a -> b) -> a -> b
$ OptProperties -> String
propMetaVar (OptProperties -> String) -> OptProperties -> String
forall a b. (a -> b) -> a -> b
$ Option x -> OptProperties
forall a. Option a -> OptProperties
optProps Option x
o
        CmdReader {} -> Part
forall a. HasCallStack => a
undefined -- TODO
    , $sel:description:Definition :: Line
description =
        let
          help :: Part
help = Text -> Part
Raw (Chunk Doc -> Text
docToText (Chunk Doc -> Text) -> Chunk Doc -> Text
forall a b. (a -> b) -> a -> b
$ OptProperties -> Chunk Doc
propHelp (OptProperties -> Chunk Doc) -> OptProperties -> Chunk Doc
forall a b. (a -> b) -> a -> b
$ Option x -> OptProperties
forall a. Option a -> OptProperties
optProps Option x
o)
          suffix :: [Part]
suffix =
            [Part] -> (String -> [Part]) -> Maybe String -> [Part]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (Part -> [Part]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Part -> [Part]) -> (String -> Part) -> String -> [Part]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Part -> Part
Parens (Part -> Part) -> (String -> Part) -> String -> Part
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Part
"default " <>) (Part -> Part) -> (String -> Part) -> String -> Part
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Part
forall a. IsString a => String -> a
fromString) (Maybe String -> [Part]) -> Maybe String -> [Part]
forall a b. (a -> b) -> a -> b
$
              OptProperties -> Maybe String
propShowDefault (OptProperties -> Maybe String) -> OptProperties -> Maybe String
forall a b. (a -> b) -> a -> b
$
                Option x -> OptProperties
forall a. Option a -> OptProperties
optProps Option x
o
        in
          [Part] -> Line
Line ([Part] -> Line) -> [Part] -> Line
forall a b. (a -> b) -> a -> b
$ Part
help Part -> [Part] -> [Part]
forall a. a -> [a] -> [a]
: [Part]
suffix
    , $sel:content:Definition :: Maybe [Content]
content = Maybe [Content]
forall a. Maybe a
Nothing
    }

docToText :: Chunk Doc -> Text
docToText :: Chunk Doc -> Text
docToText =
  Text -> (Doc -> Text) -> Maybe Doc -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
    Text
""
    ( SimpleDocStream AnsiStyle -> Text
Pretty.renderStrict
        (SimpleDocStream AnsiStyle -> Text)
-> (Doc -> SimpleDocStream AnsiStyle) -> Doc -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayoutOptions -> Doc -> SimpleDocStream AnsiStyle
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
Pretty.layoutPretty LayoutOptions
Pretty.defaultLayoutOptions
    )
    (Maybe Doc -> Text)
-> (Chunk Doc -> Maybe Doc) -> Chunk Doc -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Chunk Doc -> Maybe Doc
forall a. Chunk a -> Maybe a
unChunk

renderNames :: Maybe String -> [OptName] -> [Part]
renderNames :: Maybe String -> [OptName] -> [Part]
renderNames Maybe String
mArg = (OptName -> Part) -> [OptName] -> [Part]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe String -> OptName -> Part
renderName Maybe String
mArg) ([OptName] -> [Part])
-> ([OptName] -> [OptName]) -> [OptName] -> [Part]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [OptName] -> [OptName]
sortNames

renderName :: Maybe String -> OptName -> Part
renderName :: Maybe String -> OptName -> Part
renderName Maybe String
mArg = \case
  OptShort Char
c -> Part -> Part
Code (Part -> Part) -> Part -> Part
forall a b. (a -> b) -> a -> b
$ String -> Part
forall a. IsString a => String -> a
fromString [Char
'-', Char
c]
  OptLong String
st -> Part -> Part
addArg (Part -> Part) -> Part -> Part
forall a b. (a -> b) -> a -> b
$ Part -> Part
Code (Part -> Part) -> Part -> Part
forall a b. (a -> b) -> a -> b
$ String -> Part
forall a. IsString a => String -> a
fromString (String -> Part) -> String -> Part
forall a b. (a -> b) -> a -> b
$ String
"--" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
st
 where
  addArg :: Part -> Part
  addArg :: Part -> Part
addArg = case Maybe String
mArg of
    Maybe String
Nothing -> Part -> Part
forall a. a -> a
id
    Just String
arg -> [Part] -> Part
Concat ([Part] -> Part) -> (Part -> [Part]) -> Part -> Part
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Part] -> [Part] -> [Part]
forall a. Semigroup a => a -> a -> a
<> [Part
"=", Part -> Part
Variable (Part -> Part) -> Part -> Part
forall a b. (a -> b) -> a -> b
$ String -> Part
forall a. IsString a => String -> a
fromString String
arg]) ([Part] -> [Part]) -> (Part -> [Part]) -> Part -> [Part]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Part -> [Part]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure

sortNames :: [OptName] -> [OptName]
sortNames :: [OptName] -> [OptName]
sortNames = (OptName -> OptName -> Ordering) -> [OptName] -> [OptName]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((OptName -> OptName -> Ordering) -> [OptName] -> [OptName])
-> (OptName -> OptName -> Ordering) -> [OptName] -> [OptName]
forall a b. (a -> b) -> a -> b
$ ((OptName, OptName) -> Ordering) -> OptName -> OptName -> Ordering
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (((OptName, OptName) -> Ordering)
 -> OptName -> OptName -> Ordering)
-> ((OptName, OptName) -> Ordering)
-> OptName
-> OptName
-> Ordering
forall a b. (a -> b) -> a -> b
$ \case
  (OptShort Char
a, OptShort Char
b) -> Char -> Char -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Char
a Char
b
  (OptShort Char
_, OptLong String
_) -> Ordering
LT
  (OptLong String
a, OptLong String
b) -> String -> String -> Ordering
forall a. Ord a => a -> a -> Ordering
compare String
a String
b
  (OptLong String
_, OptShort Char
_) -> Ordering
GT