{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}

module Options.Applicative.Help.Types (
    ParserHelp (..)
  , renderHelp
  , helpText
  ) where

import Data.Semigroup
import Data.Text (Text)
import Options.Applicative.Help.Chunk
import Options.Applicative.Help.Pretty
import Options.Applicative.Help.Style (SetStyle (..), styleToRawText, defaultStyle)
import Prelude
import Prettyprinter.Internal (textSpaces)
import Prettyprinter.Render.Util.Panic

import qualified Data.Text.Lazy.Builder as B
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT

data ParserHelp = ParserHelp
  { ParserHelp -> Chunk Doc
helpError :: Chunk Doc
  , ParserHelp -> Chunk Doc
helpSuggestions :: Chunk Doc
  , ParserHelp -> Chunk Doc
helpHeader :: Chunk Doc
  , ParserHelp -> Chunk Doc
helpUsage :: Chunk Doc
  , ParserHelp -> Chunk Doc
helpDescription :: Chunk Doc
  , ParserHelp -> Chunk Doc
helpBody :: Chunk Doc
  , ParserHelp -> Chunk Doc
helpGlobals :: Chunk Doc
  , ParserHelp -> Chunk Doc
helpFooter :: Chunk Doc
  }

instance Show ParserHelp where
  showsPrec :: Int -> ParserHelp -> ShowS
showsPrec Int
_ ParserHelp
h = String -> ShowS
showString (Int -> ParserHelp -> String
renderHelp Int
80 ParserHelp
h)

instance Monoid ParserHelp where
  mempty :: ParserHelp
mempty = Chunk Doc
-> Chunk Doc
-> Chunk Doc
-> Chunk Doc
-> Chunk Doc
-> Chunk Doc
-> Chunk Doc
-> Chunk Doc
-> ParserHelp
ParserHelp Chunk Doc
forall a. Monoid a => a
mempty Chunk Doc
forall a. Monoid a => a
mempty Chunk Doc
forall a. Monoid a => a
mempty Chunk Doc
forall a. Monoid a => a
mempty Chunk Doc
forall a. Monoid a => a
mempty Chunk Doc
forall a. Monoid a => a
mempty Chunk Doc
forall a. Monoid a => a
mempty Chunk Doc
forall a. Monoid a => a
mempty
  mappend :: ParserHelp -> ParserHelp -> ParserHelp
mappend = ParserHelp -> ParserHelp -> ParserHelp
forall a. Semigroup a => a -> a -> a
(<>)

instance Semigroup ParserHelp where
  (ParserHelp Chunk Doc
e1 Chunk Doc
s1 Chunk Doc
h1 Chunk Doc
u1 Chunk Doc
d1 Chunk Doc
b1 Chunk Doc
g1 Chunk Doc
f1) <> :: ParserHelp -> ParserHelp -> ParserHelp
<> (ParserHelp Chunk Doc
e2 Chunk Doc
s2 Chunk Doc
h2 Chunk Doc
u2 Chunk Doc
d2 Chunk Doc
b2 Chunk Doc
g2 Chunk Doc
f2)
    = Chunk Doc
-> Chunk Doc
-> Chunk Doc
-> Chunk Doc
-> Chunk Doc
-> Chunk Doc
-> Chunk Doc
-> Chunk Doc
-> ParserHelp
ParserHelp (Chunk Doc -> Chunk Doc -> Chunk Doc
forall a. Monoid a => a -> a -> a
mappend Chunk Doc
e1 Chunk Doc
e2) (Chunk Doc -> Chunk Doc -> Chunk Doc
forall a. Monoid a => a -> a -> a
mappend Chunk Doc
s1 Chunk Doc
s2)
                 (Chunk Doc -> Chunk Doc -> Chunk Doc
forall a. Monoid a => a -> a -> a
mappend Chunk Doc
h1 Chunk Doc
h2) (Chunk Doc -> Chunk Doc -> Chunk Doc
forall a. Monoid a => a -> a -> a
mappend Chunk Doc
u1 Chunk Doc
u2)
                 (Chunk Doc -> Chunk Doc -> Chunk Doc
forall a. Monoid a => a -> a -> a
mappend Chunk Doc
d1 Chunk Doc
d2) (Chunk Doc -> Chunk Doc -> Chunk Doc
forall a. Monoid a => a -> a -> a
mappend Chunk Doc
b1 Chunk Doc
b2)
                 (Chunk Doc -> Chunk Doc -> Chunk Doc
forall a. Monoid a => a -> a -> a
mappend Chunk Doc
g1 Chunk Doc
g2) (Chunk Doc -> Chunk Doc -> Chunk Doc
forall a. Monoid a => a -> a -> a
mappend Chunk Doc
f1 Chunk Doc
f2)

helpText :: ParserHelp -> Doc
helpText :: ParserHelp -> Doc
helpText (ParserHelp Chunk Doc
e Chunk Doc
s Chunk Doc
h Chunk Doc
u Chunk Doc
d Chunk Doc
b Chunk Doc
g Chunk Doc
f) =
  Chunk Doc -> Doc
forall a. Monoid a => Chunk a -> a
extractChunk (Chunk Doc -> Doc) -> Chunk Doc -> Doc
forall a b. (a -> b) -> a -> b
$
    [Chunk Doc] -> Chunk Doc
vsepChunks [Chunk Doc
e, Chunk Doc
s, Chunk Doc
h, Chunk Doc
u, (Doc -> Doc) -> Chunk Doc -> Chunk Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Doc -> Doc
indent Int
2) Chunk Doc
d, Chunk Doc
b, Chunk Doc
g, Chunk Doc
f]

-- | Convert a help text to 'String'.
renderHelp :: Int -> ParserHelp -> String
renderHelp :: Int -> ParserHelp -> String
renderHelp Int
cols
  = Text -> String
LT.unpack
  (Text -> String) -> (ParserHelp -> Text) -> ParserHelp -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
B.toLazyText
  (Builder -> Text) -> (ParserHelp -> Builder) -> ParserHelp -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleDocStream Ann -> Builder
renderAnsi
  (SimpleDocStream Ann -> Builder)
-> (ParserHelp -> SimpleDocStream Ann) -> ParserHelp -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayoutOptions -> Doc -> SimpleDocStream Ann
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutPretty (PageWidth -> LayoutOptions
LayoutOptions (Int -> Double -> PageWidth
AvailablePerLine Int
cols Double
1.0))
  (Doc -> SimpleDocStream Ann)
-> (ParserHelp -> Doc) -> ParserHelp -> SimpleDocStream Ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParserHelp -> Doc
helpText

renderAnsi :: SimpleDocStream Ann -> B.Builder
renderAnsi :: SimpleDocStream Ann -> Builder
renderAnsi
  = SetStyle
-> (Text -> Builder)
-> (SetStyle -> SetStyle -> Builder)
-> (SetStyle -> SetStyle -> Builder)
-> SimpleDocStream SetStyle
-> Builder
forall ann.
Monoid ann =>
ann
-> (Text -> Builder)
-> (ann -> ann -> Builder)
-> (ann -> ann -> Builder)
-> SimpleDocStream ann
-> Builder
renderCtxDecorated SetStyle
defaultStyle Text -> Builder
B.fromText SetStyle -> SetStyle -> Builder
renderPush SetStyle -> SetStyle -> Builder
renderPop
  (SimpleDocStream SetStyle -> Builder)
-> (SimpleDocStream Ann -> SimpleDocStream SetStyle)
-> SimpleDocStream Ann
-> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ann -> Maybe SetStyle)
-> SimpleDocStream Ann -> SimpleDocStream SetStyle
forall ann ann'.
(ann -> Maybe ann') -> SimpleDocStream ann -> SimpleDocStream ann'
alterAnnotationsS Ann -> Maybe SetStyle
alter
  where
    alter :: Ann -> Maybe SetStyle
    alter :: Ann -> Maybe SetStyle
alter (AnnStyle SetStyle
setStyle) = SetStyle -> Maybe SetStyle
forall a. a -> Maybe a
Just SetStyle
setStyle
    alter (AnnTrace Int
_ String
_) = Maybe SetStyle
forall a. Maybe a
Nothing
    renderPush :: SetStyle -> SetStyle -> B.Builder
    renderPush :: SetStyle -> SetStyle -> Builder
renderPush SetStyle
_ SetStyle
setStyle = String -> Builder
B.fromString (SetStyle -> String
styleToRawText SetStyle
setStyle)
    renderPop :: SetStyle -> SetStyle -> B.Builder
    renderPop :: SetStyle -> SetStyle -> Builder
renderPop SetStyle
setStyle SetStyle
_ = String -> Builder
B.fromString (SetStyle -> String
styleToRawText SetStyle
setStyle)

renderCtxDecorated
    :: Monoid ann
    => ann
    -> (Text -> B.Builder) -- ^ Render plain 'Text'
    -> (ann -> ann -> B.Builder)  -- ^ How to render an annotation
    -> (ann -> ann -> B.Builder)  -- ^ How to render the removed annotation
    -> SimpleDocStream ann
    -> B.Builder
renderCtxDecorated :: ann
-> (Text -> Builder)
-> (ann -> ann -> Builder)
-> (ann -> ann -> Builder)
-> SimpleDocStream ann
-> Builder
renderCtxDecorated ann
topAnn Text -> Builder
toText ann -> ann -> Builder
push ann -> ann -> Builder
pop = [ann] -> SimpleDocStream ann -> Builder
go [ann
topAnn]
  where
    go :: [ann] -> SimpleDocStream ann -> Builder
go [ann]
_                      SimpleDocStream ann
SFail               = Builder
forall void. void
panicUncaughtFail
    go []                     SimpleDocStream ann
SEmpty              = Builder
forall a. Monoid a => a
mempty
    go (ann
_:ann
_:[ann]
_)                SimpleDocStream ann
SEmpty              = Builder
forall void. void
panicInputNotFullyConsumed
    go (ann
_:[ann]
_)                  SimpleDocStream ann
SEmpty              = Builder
forall a. Monoid a => a
mempty
    go [ann]
stack                  (SChar Char
c SimpleDocStream ann
rest)      = Text -> Builder
toText (Char -> Text
T.singleton Char
c) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [ann] -> SimpleDocStream ann -> Builder
go [ann]
stack SimpleDocStream ann
rest
    go [ann]
stack                  (SText Int
_l Text
t SimpleDocStream ann
rest)   = Text -> Builder
toText Text
t Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [ann] -> SimpleDocStream ann -> Builder
go [ann]
stack SimpleDocStream ann
rest
    go [ann]
stack                  (SLine Int
i SimpleDocStream ann
rest)      = Text -> Builder
toText (Char -> Text
T.singleton Char
'\n') Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
toText (Int -> Text
textSpaces Int
i) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [ann] -> SimpleDocStream ann -> Builder
go [ann]
stack SimpleDocStream ann
rest
    go stack :: [ann]
stack@(ann
ctxAnn:[ann]
_)       (SAnnPush ann
ann SimpleDocStream ann
rest) = ann -> ann -> Builder
push ann
ctxAnn ann
ann Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [ann] -> SimpleDocStream ann -> Builder
go ((ann
ctxAnn ann -> ann -> ann
forall a. Semigroup a => a -> a -> a
<> ann
ann) ann -> [ann] -> [ann]
forall a. a -> [a] -> [a]
: [ann]
stack) SimpleDocStream ann
rest
    go (ann
ann:stack :: [ann]
stack@(ann
ctxAnn:[ann]
_)) (SAnnPop SimpleDocStream ann
rest)      = ann -> ann -> Builder
pop ann
ctxAnn ann
ann Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [ann] -> SimpleDocStream ann -> Builder
go [ann]
stack SimpleDocStream ann
rest
    go []                     SAnnPop{}           = Builder
forall void. void
panicUnpairedPop
    go [ann]
_                      (SAnnPush ann
_ SimpleDocStream ann
_)      = String -> Builder
forall a. HasCallStack => String -> a
error String
"Unpaired push"
    go [ann]
_                      (SAnnPop SimpleDocStream ann
_)         = String -> Builder
forall a. HasCallStack => String -> a
error String
"Unpaired pop"
{-# INLINE renderCtxDecorated #-}