1module Options.Applicative.Help.Chunk
2  ( Chunk(..)
3  , chunked
4  , listToChunk
5  , (<<+>>)
6  , (<</>>)
7  , vcatChunks
8  , vsepChunks
9  , isEmpty
10  , stringChunk
11  , paragraph
12  , extractChunk
13  , tabulate
14  ) where
15
16import Control.Applicative
17import Control.Monad
18import Data.List.NonEmpty (NonEmpty(..))
19import Data.Maybe
20import Data.Semigroup
21import Prelude
22
23import Options.Applicative.Help.Pretty
24
25-- | The free monoid on a semigroup 'a'.
26newtype Chunk a = Chunk
27  { unChunk :: Maybe a }
28  deriving (Eq, Show)
29
30instance Functor Chunk where
31  fmap f = Chunk . fmap f . unChunk
32
33instance Applicative Chunk where
34  pure = Chunk . pure
35  Chunk f <*> Chunk x = Chunk (f <*> x)
36
37instance Alternative Chunk where
38  empty = Chunk Control.Applicative.empty
39  a <|> b = Chunk $ unChunk a <|> unChunk b
40
41instance Monad Chunk where
42  return = pure
43  m >>= f = Chunk $ unChunk m >>= unChunk . f
44
45instance Semigroup a => Semigroup (Chunk a) where
46  (<>) = chunked (<>)
47
48instance Semigroup a => Monoid (Chunk a) where
49  mempty = Chunk Nothing
50  mappend = (<>)
51
52instance MonadPlus Chunk where
53  mzero = Chunk mzero
54  mplus m1 m2 = Chunk $ mplus (unChunk m1) (unChunk m2)
55
56-- | Given a semigroup structure on 'a', return a monoid structure on 'Chunk a'.
57--
58-- Note that this is /not/ the same as 'liftA2'.
59chunked :: (a -> a -> a)
60        -> Chunk a -> Chunk a -> Chunk a
61chunked _ (Chunk Nothing) y = y
62chunked _ x (Chunk Nothing) = x
63chunked f (Chunk (Just x)) (Chunk (Just y)) = Chunk (Just (f x y))
64
65-- | Concatenate a list into a Chunk.  'listToChunk' satisfies:
66--
67-- > isEmpty . listToChunk = null
68-- > listToChunk = mconcat . fmap pure
69listToChunk :: Semigroup a => [a] -> Chunk a
70listToChunk [] = mempty
71listToChunk (x:xs) = pure (sconcat (x :| xs))
72
73-- | Part of a constrained comonad instance.
74--
75-- This is the counit of the adjunction between 'Chunk' and the forgetful
76-- functor from monoids to semigroups.  It satisfies:
77--
78-- > extractChunk . pure = id
79-- > extractChunk . fmap pure = id
80extractChunk :: Monoid a => Chunk a -> a
81extractChunk = fromMaybe mempty . unChunk
82-- we could also define:
83-- duplicate :: Monoid a => Chunk a -> Chunk (Chunk a)
84-- duplicate = fmap pure
85
86-- | Concatenate two 'Chunk's with a space in between.  If one is empty, this
87-- just returns the other one.
88--
89-- Unlike '<+>' for 'Doc', this operation has a unit element, namely the empty
90-- 'Chunk'.
91(<<+>>) :: Chunk Doc -> Chunk Doc -> Chunk Doc
92(<<+>>) = chunked (<+>)
93
94-- | Concatenate two 'Chunk's with a softline in between.  This is exactly like
95-- '<<+>>', but uses a softline instead of a space.
96(<</>>) :: Chunk Doc -> Chunk Doc -> Chunk Doc
97(<</>>) = chunked (</>)
98
99-- | Concatenate 'Chunk's vertically.
100vcatChunks :: [Chunk Doc] -> Chunk Doc
101vcatChunks = foldr (chunked (.$.)) mempty
102
103-- | Concatenate 'Chunk's vertically separated by empty lines.
104vsepChunks :: [Chunk Doc] -> Chunk Doc
105vsepChunks = foldr (chunked (\x y -> x .$. mempty .$. y)) mempty
106
107-- | Whether a 'Chunk' is empty.  Note that something like 'pure mempty' is not
108-- considered an empty chunk, even though the underlying 'Doc' is empty.
109isEmpty :: Chunk a -> Bool
110isEmpty = isNothing . unChunk
111
112-- | Convert a 'String' into a 'Chunk'.  This satisfies:
113--
114-- > isEmpty . stringChunk = null
115-- > extractChunk . stringChunk = string
116stringChunk :: String -> Chunk Doc
117stringChunk "" = mempty
118stringChunk s = pure (string s)
119
120-- | Convert a paragraph into a 'Chunk'.  The resulting chunk is composed by the
121-- words of the original paragraph separated by softlines, so it will be
122-- automatically word-wrapped when rendering the underlying document.
123--
124-- This satisfies:
125--
126-- > isEmpty . paragraph = null . words
127paragraph :: String -> Chunk Doc
128paragraph = foldr (chunked (</>) . stringChunk) mempty
129          . words
130
131tabulate' :: Int -> [(Doc, Doc)] -> Chunk Doc
132tabulate' _ [] = mempty
133tabulate' size table = pure $ vcat
134  [ indent 2 (fillBreak size key <+> value)
135  | (key, value) <- table ]
136
137-- | Display pairs of strings in a table.
138tabulate :: [(Doc, Doc)] -> Chunk Doc
139tabulate = tabulate' 24
140