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