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