module Options.Applicative.Help.Chunk
  ( Chunk(..)
  , chunked
  , listToChunk
  , (<<+>>)
  , (<</>>)
  , vcatChunks
  , vsepChunks
  , isEmpty
  , stringChunk
  , paragraph
  , extractChunk
  , tabulate
  ) where

import Control.Applicative
import Control.Monad
import Data.List.NonEmpty (NonEmpty(..))
import Data.Maybe
import Data.Semigroup
import Prelude

import Options.Applicative.Help.Pretty

-- | The free monoid on a semigroup 'a'.
newtype Chunk a = Chunk
  { Chunk a -> Maybe a
unChunk :: Maybe a }
  deriving (Chunk a -> Chunk a -> Bool
(Chunk a -> Chunk a -> Bool)
-> (Chunk a -> Chunk a -> Bool) -> Eq (Chunk a)
forall a. Eq a => Chunk a -> Chunk a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Chunk a -> Chunk a -> Bool
$c/= :: forall a. Eq a => Chunk a -> Chunk a -> Bool
== :: Chunk a -> Chunk a -> Bool
$c== :: forall a. Eq a => Chunk a -> Chunk a -> Bool
Eq, Int -> Chunk a -> ShowS
[Chunk a] -> ShowS
Chunk a -> String
(Int -> Chunk a -> ShowS)
-> (Chunk a -> String) -> ([Chunk a] -> ShowS) -> Show (Chunk a)
forall a. Show a => Int -> Chunk a -> ShowS
forall a. Show a => [Chunk a] -> ShowS
forall a. Show a => Chunk a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Chunk a] -> ShowS
$cshowList :: forall a. Show a => [Chunk a] -> ShowS
show :: Chunk a -> String
$cshow :: forall a. Show a => Chunk a -> String
showsPrec :: Int -> Chunk a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Chunk a -> ShowS
Show)

instance Functor Chunk where
  fmap :: (a -> b) -> Chunk a -> Chunk b
fmap a -> b
f = Maybe b -> Chunk b
forall a. Maybe a -> Chunk a
Chunk (Maybe b -> Chunk b) -> (Chunk a -> Maybe b) -> Chunk a -> Chunk b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (Maybe a -> Maybe b) -> (Chunk a -> Maybe a) -> Chunk a -> Maybe b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Chunk a -> Maybe a
forall a. Chunk a -> Maybe a
unChunk

instance Applicative Chunk where
  pure :: a -> Chunk a
pure = Maybe a -> Chunk a
forall a. Maybe a -> Chunk a
Chunk (Maybe a -> Chunk a) -> (a -> Maybe a) -> a -> Chunk a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  Chunk Maybe (a -> b)
f <*> :: Chunk (a -> b) -> Chunk a -> Chunk b
<*> Chunk Maybe a
x = Maybe b -> Chunk b
forall a. Maybe a -> Chunk a
Chunk (Maybe (a -> b)
f Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe a
x)

instance Alternative Chunk where
  empty :: Chunk a
empty = Maybe a -> Chunk a
forall a. Maybe a -> Chunk a
Chunk Maybe a
forall (f :: * -> *) a. Alternative f => f a
Control.Applicative.empty
  Chunk a
a <|> :: Chunk a -> Chunk a -> Chunk a
<|> Chunk a
b = Maybe a -> Chunk a
forall a. Maybe a -> Chunk a
Chunk (Maybe a -> Chunk a) -> Maybe a -> Chunk a
forall a b. (a -> b) -> a -> b
$ Chunk a -> Maybe a
forall a. Chunk a -> Maybe a
unChunk Chunk a
a Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Chunk a -> Maybe a
forall a. Chunk a -> Maybe a
unChunk Chunk a
b

instance Monad Chunk where
  return :: a -> Chunk a
return = a -> Chunk a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  Chunk a
m >>= :: Chunk a -> (a -> Chunk b) -> Chunk b
>>= a -> Chunk b
f = Maybe b -> Chunk b
forall a. Maybe a -> Chunk a
Chunk (Maybe b -> Chunk b) -> Maybe b -> Chunk b
forall a b. (a -> b) -> a -> b
$ Chunk a -> Maybe a
forall a. Chunk a -> Maybe a
unChunk Chunk a
m Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Chunk b -> Maybe b
forall a. Chunk a -> Maybe a
unChunk (Chunk b -> Maybe b) -> (a -> Chunk b) -> a -> Maybe b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Chunk b
f

instance Semigroup a => Semigroup (Chunk a) where
  <> :: Chunk a -> Chunk a -> Chunk a
(<>) = (a -> a -> a) -> Chunk a -> Chunk a -> Chunk a
forall a. (a -> a -> a) -> Chunk a -> Chunk a -> Chunk a
chunked a -> a -> a
forall a. Semigroup a => a -> a -> a
(<>)

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

instance MonadPlus Chunk where
  mzero :: Chunk a
mzero = Maybe a -> Chunk a
forall a. Maybe a -> Chunk a
Chunk Maybe a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
  mplus :: Chunk a -> Chunk a -> Chunk a
mplus Chunk a
m1 Chunk a
m2 = Maybe a -> Chunk a
forall a. Maybe a -> Chunk a
Chunk (Maybe a -> Chunk a) -> Maybe a -> Chunk a
forall a b. (a -> b) -> a -> b
$ Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus (Chunk a -> Maybe a
forall a. Chunk a -> Maybe a
unChunk Chunk a
m1) (Chunk a -> Maybe a
forall a. Chunk a -> Maybe a
unChunk Chunk a
m2)

-- | Given a semigroup structure on 'a', return a monoid structure on 'Chunk a'.
--
-- Note that this is /not/ the same as 'liftA2'.
chunked :: (a -> a -> a)
        -> Chunk a -> Chunk a -> Chunk a
chunked :: (a -> a -> a) -> Chunk a -> Chunk a -> Chunk a
chunked a -> a -> a
_ (Chunk Maybe a
Nothing) Chunk a
y = Chunk a
y
chunked a -> a -> a
_ Chunk a
x (Chunk Maybe a
Nothing) = Chunk a
x
chunked a -> a -> a
f (Chunk (Just a
x)) (Chunk (Just a
y)) = Maybe a -> Chunk a
forall a. Maybe a -> Chunk a
Chunk (a -> Maybe a
forall a. a -> Maybe a
Just (a -> a -> a
f a
x a
y))

-- | Concatenate a list into a Chunk.  'listToChunk' satisfies:
--
-- > isEmpty . listToChunk = null
-- > listToChunk = mconcat . fmap pure
listToChunk :: Semigroup a => [a] -> Chunk a
listToChunk :: [a] -> Chunk a
listToChunk [] = Chunk a
forall a. Monoid a => a
mempty
listToChunk (a
x:[a]
xs) = a -> Chunk a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NonEmpty a -> a
forall a. Semigroup a => NonEmpty a -> a
sconcat (a
x a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| [a]
xs))

-- | Part of a constrained comonad instance.
--
-- This is the counit of the adjunction between 'Chunk' and the forgetful
-- functor from monoids to semigroups.  It satisfies:
--
-- > extractChunk . pure = id
-- > extractChunk . fmap pure = id
extractChunk :: Monoid a => Chunk a -> a
extractChunk :: Chunk a -> a
extractChunk = a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe a
forall a. Monoid a => a
mempty (Maybe a -> a) -> (Chunk a -> Maybe a) -> Chunk a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Chunk a -> Maybe a
forall a. Chunk a -> Maybe a
unChunk
-- we could also define:
-- duplicate :: Monoid a => Chunk a -> Chunk (Chunk a)
-- duplicate = fmap pure

-- | Concatenate two 'Chunk's with a space in between.  If one is empty, this
-- just returns the other one.
--
-- Unlike '<+>' for 'Doc', this operation has a unit element, namely the empty
-- 'Chunk'.
(<<+>>) :: Chunk Doc -> Chunk Doc -> Chunk Doc
<<+>> :: Chunk Doc -> Chunk Doc -> Chunk Doc
(<<+>>) = (Doc -> Doc -> Doc) -> Chunk Doc -> Chunk Doc -> Chunk Doc
forall a. (a -> a -> a) -> Chunk a -> Chunk a -> Chunk a
chunked Doc -> Doc -> Doc
(<+>)

-- | Concatenate two 'Chunk's with a softline in between.  This is exactly like
-- '<<+>>', but uses a softline instead of a space.
(<</>>) :: Chunk Doc -> Chunk Doc -> Chunk Doc
<</>> :: Chunk Doc -> Chunk Doc -> Chunk Doc
(<</>>) = (Doc -> Doc -> Doc) -> Chunk Doc -> Chunk Doc -> Chunk Doc
forall a. (a -> a -> a) -> Chunk a -> Chunk a -> Chunk a
chunked Doc -> Doc -> Doc
(</>)

-- | Concatenate 'Chunk's vertically.
vcatChunks :: [Chunk Doc] -> Chunk Doc
vcatChunks :: [Chunk Doc] -> Chunk Doc
vcatChunks = (Chunk Doc -> Chunk Doc -> Chunk Doc)
-> Chunk Doc -> [Chunk Doc] -> Chunk Doc
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Doc -> Doc -> Doc) -> Chunk Doc -> Chunk Doc -> Chunk Doc
forall a. (a -> a -> a) -> Chunk a -> Chunk a -> Chunk a
chunked Doc -> Doc -> Doc
(.$.)) Chunk Doc
forall a. Monoid a => a
mempty

-- | Concatenate 'Chunk's vertically separated by empty lines.
vsepChunks :: [Chunk Doc] -> Chunk Doc
vsepChunks :: [Chunk Doc] -> Chunk Doc
vsepChunks = (Chunk Doc -> Chunk Doc -> Chunk Doc)
-> Chunk Doc -> [Chunk Doc] -> Chunk Doc
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Doc -> Doc -> Doc) -> Chunk Doc -> Chunk Doc -> Chunk Doc
forall a. (a -> a -> a) -> Chunk a -> Chunk a -> Chunk a
chunked (\Doc
x Doc
y -> Doc
x Doc -> Doc -> Doc
.$. Doc
forall a. Monoid a => a
mempty Doc -> Doc -> Doc
.$. Doc
y)) Chunk Doc
forall a. Monoid a => a
mempty

-- | Whether a 'Chunk' is empty.  Note that something like 'pure mempty' is not
-- considered an empty chunk, even though the underlying 'Doc' is empty.
isEmpty :: Chunk a -> Bool
isEmpty :: Chunk a -> Bool
isEmpty = Maybe a -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe a -> Bool) -> (Chunk a -> Maybe a) -> Chunk a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Chunk a -> Maybe a
forall a. Chunk a -> Maybe a
unChunk

-- | Convert a 'String' into a 'Chunk'.  This satisfies:
--
-- > isEmpty . stringChunk = null
-- > extractChunk . stringChunk = string
stringChunk :: String -> Chunk Doc
stringChunk :: String -> Chunk Doc
stringChunk String
"" = Chunk Doc
forall a. Monoid a => a
mempty
stringChunk String
s = Doc -> Chunk Doc
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Doc
string String
s)

-- | Convert a paragraph into a 'Chunk'.  The resulting chunk is composed by the
-- words of the original paragraph separated by softlines, so it will be
-- automatically word-wrapped when rendering the underlying document.
--
-- This satisfies:
--
-- > isEmpty . paragraph = null . words
paragraph :: String -> Chunk Doc
paragraph :: String -> Chunk Doc
paragraph = (String -> Chunk Doc -> Chunk Doc)
-> Chunk Doc -> [String] -> Chunk Doc
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Doc -> Doc -> Doc) -> Chunk Doc -> Chunk Doc -> Chunk Doc
forall a. (a -> a -> a) -> Chunk a -> Chunk a -> Chunk a
chunked Doc -> Doc -> Doc
(</>) (Chunk Doc -> Chunk Doc -> Chunk Doc)
-> (String -> Chunk Doc) -> String -> Chunk Doc -> Chunk Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Chunk Doc
stringChunk) Chunk Doc
forall a. Monoid a => a
mempty
          ([String] -> Chunk Doc)
-> (String -> [String]) -> String -> Chunk Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
words

-- | Display pairs of strings in a table.
tabulate :: Int -> [(Doc, Doc)] -> Chunk Doc
tabulate :: Int -> [(Doc, Doc)] -> Chunk Doc
tabulate Int
_ [] = Chunk Doc
forall a. Monoid a => a
mempty
tabulate Int
size [(Doc, Doc)]
table = Doc -> Chunk Doc
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Doc -> Chunk Doc) -> Doc -> Chunk Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat
  [ Int -> Doc -> Doc
indent Int
2 (Int -> Doc -> Doc
fillBreak Int
size Doc
key Doc -> Doc -> Doc
<+> Doc
value)
  | (Doc
key, Doc
value) <- [(Doc, Doc)]
table ]