Chunk.hs

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
  { unChunk :: Maybe a }
  deriving (Eq, Show)

instance Functor Chunk where
  fmap f = Chunk . fmap f . unChunk

instance Applicative Chunk where
  pure = Chunk . pure
  Chunk f <*> Chunk x = Chunk (f <*> x)

instance Alternative Chunk where
  empty = Chunk Control.Applicative.empty
  a <|> b = Chunk $ unChunk a <|> unChunk b

instance Monad Chunk where
  return = pure
  m >>= f = Chunk $ unChunk m >>= unChunk . f

instance Semigroup a => Semigroup (Chunk a) where
  (<>) = chunked (<>)

instance Semigroup a => Monoid (Chunk a) where
  mempty = Chunk Nothing
  mappend = (<>)

instance MonadPlus Chunk where
  mzero = Chunk mzero
  mplus m1 m2 = Chunk $ mplus (unChunk m1) (unChunk 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 _ (Chunk Nothing) y = y
chunked _ x (Chunk Nothing) = x
chunked f (Chunk (Just x)) (Chunk (Just y)) = Chunk (Just (f x y))

-- | Concatenate a list into a Chunk.  'listToChunk' satisfies:
--
-- > isEmpty . listToChunk = null
-- > listToChunk = mconcat . fmap pure
listToChunk :: Semigroup a => [a] -> Chunk a
listToChunk [] = mempty
listToChunk (x:xs) = pure (sconcat (x :| 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 = fromMaybe mempty . 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
(<<+>>) = chunked (<+>)

-- | 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
(<</>>) = chunked (</>)

-- | Concatenate 'Chunk's vertically.
vcatChunks :: [Chunk Doc] -> Chunk Doc
vcatChunks = foldr (chunked (.$.)) mempty

-- | Concatenate 'Chunk's vertically separated by empty lines.
vsepChunks :: [Chunk Doc] -> Chunk Doc
vsepChunks = foldr (chunked (\x y -> x .$. mempty .$. y)) 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 = isNothing . unChunk

-- | Convert a 'String' into a 'Chunk'.  This satisfies:
--
-- > isEmpty . stringChunk = null
-- > extractChunk . stringChunk = string
stringChunk :: String -> Chunk Doc
stringChunk "" = mempty
stringChunk s = pure (pretty 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 = foldr (chunked (</>) . stringChunk) mempty
          . words

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