doclayout 0.4.0.1 → 0.5

raw patch · 7 files changed

+638/−141 lines, 7 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• changelog.md +31/−0
• doclayout.cabal +6/−3
• src/Text/DocLayout.hs +350/−138
• src/Text/DocLayout/ANSIFont.hs +107/−0
• src/Text/DocLayout/Attributed.hs +50/−0
• src/Text/DocLayout/HasChars.hs +89/−0
• test/test.hs +5/−0

@@ -1,5 +1,36 @@ # doclayout +## 0.5++  * Extract existing HasChars definition into a module+    Text.DocLayout.HasChars (Evan Silberman).++  * Add a `build` method to the signature of HasChars [API change]+    (Evan Silberman). This has a default definition, and is only needed with+    the ANSI renderer, so existing users should not need to add anything to+    their HasChars instances.++  * Introduce support for ANSI-styled output (Evan Silberman) [API change].+    `renderPlain` and `renderANSI` are now exported; the old `render`+    is a synonym of `renderPlain`.  In addition, various functions are+    exported to add ANSI formatting (including bold, italics,+    underline, strikeout, links, and colors) to a Doc. The Attributed+    type is also now exported.++  * Change type of Block constructor, replacing `[a]` with `[Attributed a]`,+    which carries a Font along with an inner string type [API change]+    (Evan Silberman).++  * Introduce FlatDocs and use them for rendering (Evan Silberman).+    This is an internal concept, not part of the public API.+    FlatDoc is an "intermediate representation" for the Doc "interpreter".+    The general design is that any Doc can be turned into a list of FlatDocs+    that carry equivalent information. The main point of doing this+    is to replace the nested Styled and Linked Docs, which form a more+    complicated tree structure than previously existed in DocLayout.++  * Deprecate `unfoldD`.+ ## 0.4.0.1    * Add clause for Empty to renderList (#22).

@@ -1,5 +1,5 @@ name:                doclayout-version:             0.4.0.1+version:             0.5 synopsis:            A prettyprinting library for laying out text documents. description:         doclayout is a prettyprinting library for laying out                      text documents, with several features not present@@ -10,7 +10,7 @@ license-file:        LICENSE author:              John MacFarlane maintainer:          jgm@berkeley.edu-copyright:           2016-19 John MacFarlane+copyright:           2016-24 John MacFarlane category:            Text build-type:          Simple extra-source-files:  udhr/txt/*.txt,@@ -18,12 +18,15 @@                      udhr/languages.txt,                      src/Text/unicodeWidth.inc data-files:          README.md-                     changelog.md+extra-source-files:  changelog.md cabal-version:       >=1.10  library   hs-source-dirs:      src   exposed-modules:     Text.DocLayout+  other-modules:       Text.DocLayout.HasChars,+                       Text.DocLayout.ANSIFont,+                       Text.DocLayout.Attributed   build-depends:       base >= 4.12 && < 5,                        text,                        containers,

@@ -27,6 +27,8 @@ module Text.DocLayout (      -- * Rendering        render+     , renderPlain+     , renderANSI      -- * Doc constructors      , cr      , blankline@@ -54,6 +56,22 @@      , parens      , quotes      , doubleQuotes+     , bold+     , italic+     , underlined+     , strikeout+     , fg+     , bg+     , Color+     , black+     , red+     , green+     , yellow+     , blue+     , magenta+     , cyan+     , white+     , link      , empty      -- * Functions for concatenating documents      , (<+>)@@ -84,6 +102,7 @@      -- * Types      , Doc(..)      , HasChars(..)+     , Attributed      )  where@@ -96,14 +115,21 @@ import Data.Bifunctor (second) import Data.Char (isSpace, ord) import Data.List (foldl', intersperse)+import Data.List.NonEmpty (NonEmpty((:|)))+import qualified Data.List.NonEmpty as N import qualified Data.IntMap.Strict as IM import qualified Data.Map.Strict as M import qualified Data.Map.Internal as MInt import Data.Data (Data, Typeable)+import Data.Foldable (toList) import Data.String import qualified Data.Text as T-import qualified Data.Text.Lazy as TL import Data.Text (Text)+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Builder as B+import Text.DocLayout.HasChars+import Text.DocLayout.ANSIFont+import Text.DocLayout.Attributed #if MIN_VERSION_base(4,11,0) #else import Data.Semigroup@@ -111,51 +137,13 @@ import Text.Emoji (baseEmojis)  --- | Class abstracting over various string types that--- can fold over characters.  Minimal definition is 'foldrChar'--- and 'foldlChar', but defining the other methods can give better--- performance.-class (IsString a, Semigroup a, Monoid a, Show a) => HasChars a where-  foldrChar     :: (Char -> b -> b) -> b -> a -> b-  foldlChar     :: (b -> Char -> b) -> b -> a -> b-  replicateChar :: Int -> Char -> a-  replicateChar n c = fromString (replicate n c)-  isNull        :: a -> Bool-  isNull = foldrChar (\_ _ -> False) True-  splitLines    :: a -> [a]-  splitLines s = (fromString firstline : otherlines)-   where-    (firstline, otherlines) = foldrChar go ([],[]) s-    go '\n' (cur,lns) = ([], fromString cur : lns)-    go c    (cur,lns) = (c:cur, lns)--instance HasChars Text where-  foldrChar         = T.foldr-  foldlChar         = T.foldl'-  splitLines        = T.splitOn "\n"-  replicateChar n c = T.replicate n (T.singleton c)-  isNull            = T.null--instance HasChars String where-  foldrChar     = foldr-  foldlChar     = foldl'-  splitLines    = lines . (++"\n")-  replicateChar = replicate-  isNull        = null--instance HasChars TL.Text where-  foldrChar         = TL.foldr-  foldlChar         = TL.foldl'-  splitLines        = TL.splitOn "\n"-  replicateChar n c = TL.replicate (fromIntegral n) (TL.singleton c)-  isNull            = TL.null- -- | Document, including structure relevant for layout. data Doc a = Text Int a            -- ^ Text with specified width.-         | Block Int [a]           -- ^ A block with a width and lines.+         | Block Int [Attributed a]           -- ^ A block with a width and lines.          | VFill Int a             -- ^ A vertically expandable block;                  -- when concatenated with a block, expands to height                  -- of block, with each line containing the specified text.+         | CookedText Int (Attributed a) -- ^ Text which doesn't need further cooking          | Prefixed Text (Doc a)   -- ^ Doc with each line prefixed with text.                  -- Note that trailing blanks are omitted from the prefix                  -- when the line after it is empty.@@ -167,10 +155,13 @@          | NewLine                 -- ^ newline.          | BlankLines Int          -- ^ Ensure a number of blank lines.          | Concat (Doc a) (Doc a)  -- ^ Two documents concatenated.+         | Styled StyleReq (Doc a)+         | Linked Text (Doc a)       -- ^ A hyperlink          | Empty          deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable,                   Data, Typeable, Generic) + instance Semigroup (Doc a) where   x <> Empty = x   Empty <> x = x@@ -183,6 +174,7 @@ instance HasChars a => IsString (Doc a) where   fromString = text +{-# DEPRECATED unfoldD "unfoldD will be removed from the API." #-} -- | Unfold a 'Doc' into a flat list. unfoldD :: Doc a -> [Doc a] unfoldD Empty = []@@ -268,26 +260,89 @@           z     -> x <> z     _                         -> d +-- Elements of a document with Styled and Linked subtrees flattened out into+-- a linear structure with open and close tags. An implementation detail of+-- the rendering process.+data FlatDoc a = FText Int a+               | FBlock Int [Attributed a]+               | FVFill Int a+               | FCookedText Int (Attributed a)+               | FPrefixed Text (NonEmpty (FlatDoc a))+               | FBeforeNonBlank (NonEmpty (FlatDoc a))+               | FFlush (NonEmpty (FlatDoc a))+               | FBreakingSpace+               | FAfterBreak (NonEmpty (FlatDoc a))+               | FCarriageReturn+               | FNewLine+               | FBlankLines Int+               | FStyleOpen StyleReq+               | FStyleClose+               | FLinkOpen Text+               | FLinkClose+         deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable,+                  Data, Typeable, Generic)++-- Given a Doc, return an equivalent list of FlatDocs, to be processed by+-- renderList. Worth noting:+--   * Treelike docs (Styled, and Linked) are turned into lists beginning+--     with an "open" tag and ending with a "close" tag, with the flattened+--     inner content in between.+--   * Other Docs with inner content are eliminated if the inner content is+--     empty, otherwise the inner content is itself flattened and made into+--     a NonEmpty.+flatten :: HasChars a => Doc a -> [FlatDoc a]+flatten (Text n a) = [FText n a]+flatten (Block n a) = [FBlock n a]+flatten (VFill n a) = [FVFill n a]+flatten (CookedText n a) = [FCookedText n a]+flatten (Prefixed p d) | null f = []+                       | otherwise = [FPrefixed p (N.fromList f)]+                       where f = (normalize . flatten) d+flatten (BeforeNonBlank d) | null f = []+                           | otherwise = [FBeforeNonBlank (N.fromList f)]+                           where f = flatten d+flatten (Flush d) | null f = []+                  | otherwise = [FFlush (N.fromList f)]+                  where f = flatten d+flatten BreakingSpace = [FBreakingSpace]+flatten CarriageReturn = [FCarriageReturn]+flatten (AfterBreak t) | null f = []+                       | otherwise = [FAfterBreak (N.fromList f)]+                       where f = flatten $ fromString $ T.unpack t+flatten NewLine = [FNewLine]+flatten (BlankLines n) = [FBlankLines n]+flatten Empty = []+flatten (Concat x y) = flatten x <> flatten y+flatten (Linked l x) = FLinkOpen l : flatten x <> [FLinkClose]+flatten (Styled f x) = FStyleOpen f : flatten x <> [FStyleClose]+ type DocState a = State (RenderState a) ()  data RenderState a = RenderState{-         output     :: [a]        -- ^ In reverse order+         output     :: [Attr a]        -- ^ In reverse order        , prefix     :: Text        , usePrefix  :: Bool        , lineLength :: Maybe Int  -- ^ 'Nothing' means no wrapping        , column     :: Int        , newlines   :: Int        -- ^ Number of preceding newlines+       , fontStack  :: [Font]+       , linkTarget :: Maybe Text -- ^ Current link target        } +peekFont :: RenderState a -> Font+peekFont st = case fontStack st of+                [] -> baseFont+                x:_ -> x+ newline :: HasChars a => DocState a newline = do   st' <- get   let rawpref = prefix st'   when (column st' == 0 && usePrefix st' && not (T.null rawpref)) $ do      let pref = fromString $ T.unpack $ T.dropWhileEnd isSpace rawpref-     modify $ \st -> st{ output = pref : output st+     modify $ \st -> st{ output = Attr Nothing baseFont pref : output st                        , column = column st + realLength pref }-  modify $ \st -> st { output = "\n" : output st+  modify $ \st -> st { output = Attr Nothing baseFont "\n" : output st                      , column = 0                      , newlines = newlines st + 1                      }@@ -295,19 +350,48 @@ outp :: HasChars a => Int -> a -> DocState a outp off s = do           -- offset >= 0 (0 might be combining char)   st' <- get-  let pref = fromString $ T.unpack $ prefix st'-  when (column st' == 0 && usePrefix st' && not (isNull pref)) $-    modify $ \st -> st{ output = pref : output st+  let pref = if usePrefix st' then fromString $ T.unpack $ prefix st' else mempty+  let font = peekFont st'+  when (column st' == 0 && not (isNull pref && font == baseFont)) $+    modify $ \st -> st{ output = Attr Nothing baseFont pref : output st                     , column = column st + realLength pref }-  modify $ \st -> st{ output = s : output st+  modify $ \st -> st{ output = Attr (linkTarget st) font s : output st                     , column = column st + off                     , newlines = 0 } --- | Render a 'Doc'.  @render (Just n)@ will use--- a line length of @n@ to reflow text on breakable spaces.--- @render Nothing@ will not reflow text.+-- | Synonym for 'renderPlain'. render :: HasChars a => Maybe Int -> Doc a -> a-render linelen doc = mconcat . reverse . output $+render = renderPlain++-- | Render a 'Doc' with ANSI escapes.  @renderANSI (Just n)@ will use+-- a line length of @n@ to reflow text on breakable spaces.+-- @renderANSI Nothing@ will not reflow text.+renderANSI :: HasChars a => Maybe Int -> Doc a -> TL.Text+renderANSI n d = B.toLazyText $ go $ prerender n d where+  go s = (\(_,_,o) -> o) (go' s) <> B.fromText (renderFont baseFont) <> B.fromText (renderOSC8 Nothing)+  go' (Attributed s) = foldl attrRender (Nothing, baseFont, B.fromText "") s++-- | Render a 'Doc' without using ANSI escapes.  @renderPlain (Just n)@ will use+-- a line length of @n@ to reflow text on breakable spaces.+-- @renderPlain Nothing@ will not reflow text.+renderPlain :: HasChars a => Maybe Int -> Doc a -> a+renderPlain n d = go $ prerender n d where+  go (Attributed s) = foldMap attrStrip s++attrStrip :: HasChars a => Attr a -> a+attrStrip (Attr _ _ y) | isNull y = ""+                       | otherwise = y++attrRender :: HasChars a => (Link, Font, B.Builder) -> Attr a -> (Link, Font, B.Builder)+attrRender (l, f, acc) (Attr m g y)+    | isNull y = (l, f, acc)+    | otherwise = (m, g, acc <> B.fromText newFont <> B.fromText newLink <> build y)+  where+    newLink = if l == m then mempty else renderOSC8 m+    newFont = if f == g then mempty else renderFont g++prerender :: HasChars a => Maybe Int -> Doc a -> Attributed a+prerender linelen doc = fromList . reverse . output $   execState (renderDoc doc) startingState    where startingState = RenderState{                             output = mempty@@ -315,38 +399,38 @@                           , usePrefix = True                           , lineLength = linelen                           , column = 0-                          , newlines = 2 }+                          , newlines = 2+                          , fontStack = []+                          , linkTarget = Nothing }  renderDoc :: HasChars a => Doc a -> DocState a-renderDoc = renderList . normalize . unfoldD+renderDoc = renderList . normalize . flatten  -normalize :: HasChars a => [Doc a] -> [Doc a]+normalize :: HasChars a => [FlatDoc a] -> [FlatDoc a] normalize [] = []-normalize (Concat{} : xs) = normalize xs -- should not happen after unfoldD-normalize (Empty : xs) = normalize xs -- should not happen after unfoldD-normalize [NewLine] = normalize [CarriageReturn]-normalize [BlankLines _] = normalize [CarriageReturn]-normalize [BreakingSpace] = []-normalize (BlankLines m : BlankLines n : xs) =-  normalize (BlankLines (max m n) : xs)-normalize (BlankLines num : BreakingSpace : xs) =-  normalize (BlankLines num : xs)-normalize (BlankLines m : CarriageReturn : xs) = normalize (BlankLines m : xs)-normalize (BlankLines m : NewLine : xs) = normalize (BlankLines m : xs)-normalize (NewLine : BlankLines m : xs) = normalize (BlankLines m : xs)-normalize (NewLine : BreakingSpace : xs) = normalize (NewLine : xs)-normalize (NewLine : CarriageReturn : xs) = normalize (NewLine : xs)-normalize (CarriageReturn : CarriageReturn : xs) =-  normalize (CarriageReturn : xs)-normalize (CarriageReturn : BlankLines m : xs) = normalize (BlankLines m : xs)-normalize (CarriageReturn : BreakingSpace : xs) =-  normalize (CarriageReturn : xs)-normalize (BreakingSpace : CarriageReturn : xs) =-  normalize (CarriageReturn:xs)-normalize (BreakingSpace : NewLine : xs) = normalize (NewLine:xs)-normalize (BreakingSpace : BlankLines n : xs) = normalize (BlankLines n:xs)-normalize (BreakingSpace : BreakingSpace : xs) = normalize (BreakingSpace:xs)+normalize [FNewLine] = normalize [FCarriageReturn]+normalize [FBlankLines _] = normalize [FCarriageReturn]+normalize [FBreakingSpace] = []+normalize (FBlankLines m : FBlankLines n : xs) =+  normalize (FBlankLines (max m n) : xs)+normalize (FBlankLines num : FBreakingSpace : xs) =+  normalize (FBlankLines num : xs)+normalize (FBlankLines m : FCarriageReturn : xs) = normalize (FBlankLines m : xs)+normalize (FBlankLines m : FNewLine : xs) = normalize (FBlankLines m : xs)+normalize (FNewLine : FBlankLines m : xs) = normalize (FBlankLines m : xs)+normalize (FNewLine : FBreakingSpace : xs) = normalize (FNewLine : xs)+normalize (FNewLine : FCarriageReturn : xs) = normalize (FNewLine : xs)+normalize (FCarriageReturn : FCarriageReturn : xs) =+  normalize (FCarriageReturn : xs)+normalize (FCarriageReturn : FBlankLines m : xs) = normalize (FBlankLines m : xs)+normalize (FCarriageReturn : FBreakingSpace : xs) =+  normalize (FCarriageReturn : xs)+normalize (FBreakingSpace : FCarriageReturn : xs) =+  normalize (FCarriageReturn:xs)+normalize (FBreakingSpace : FNewLine : xs) = normalize (FNewLine:xs)+normalize (FBreakingSpace : FBlankLines n : xs) = normalize (FBlankLines n:xs)+normalize (FBreakingSpace : FBreakingSpace : xs) = normalize (FBreakingSpace:xs) normalize (x:xs) = x : normalize xs  mergeBlocks :: HasChars a => Int -> (Int, [a]) -> (Int, [a]) -> (Int, [a])@@ -364,45 +448,93 @@              else take h lns2   pad n s = s <> replicateChar (n - realLength s) ' ' -renderList :: HasChars a => [Doc a] -> DocState a+renderList :: HasChars a => [FlatDoc a] -> DocState a renderList [] = return () -renderList (Empty : xs) = renderList xs--renderList (Text off s : xs) = do+renderList (FText off s : xs) = do   outp off s   renderList xs -renderList (Prefixed pref d : xs) = do+renderList (FCookedText off s : xs) = do+  st' <- get+  let pref = if usePrefix st' then fromString $ T.unpack $ prefix st' else mempty+  let elems (Attributed x) = reverse $ toList x+  when (column st' == 0 && not (isNull pref))  $+    modify $ \st -> st{ output = Attr Nothing baseFont pref : output st+                      , column = column st + realLength pref }+  modify $ \st -> st{ output = elems s ++ output st+                    , column = column st + off+                    , newlines = 0 }+  renderList xs++-- FStyleOpen and FStyleClose are balanced by construction when we create+-- them in `flatten`, so we can just pop the stack when we encounter+-- FStyleClose+renderList (FStyleOpen style : xs) = do   st <- get+  let prevFont = peekFont st+  let nextFont = prevFont ~> style+  modify $ \s -> s{fontStack = nextFont : fontStack s}+  renderList xs++renderList (FStyleClose : xs) = do+  modify $ \s -> s{fontStack = drop 1 $ fontStack s}+  renderList xs++-- Nested links are nonsensical, we only handle the outermost and+-- silently ignore any attempts to have a link inside a link++-- Nested links are nonsensical, we only handle the outermost and+-- silently ignore any attempts to have a link inside a link+renderList (FLinkOpen target : xs) = do+  st <- get+  case linkTarget st of+    Nothing -> do+      modify $ \s -> s{linkTarget = Just target}+      renderList xs+    _ -> do+      let (next, rest) = break isLinkClose xs+      renderList (next <> drop 1 rest)+  where+    isLinkClose FLinkClose = True+    isLinkClose _ = False++renderList (FLinkClose : xs) = do+  modify $ \s -> s{linkTarget = Nothing}+  renderList xs++renderList (FPrefixed pref d : xs) = do+  st <- get   let oldPref = prefix st   put st{ prefix = prefix st <> pref }-  renderDoc d+  renderList $ normalize $ N.toList d   modify $ \s -> s{ prefix = oldPref }   -- renderDoc CarriageReturn   renderList xs -renderList (Flush d : xs) = do+renderList (FFlush d : xs) = do   st <- get   let oldUsePrefix = usePrefix st   put st{ usePrefix = False }-  renderDoc d+  renderList $ normalize $ N.toList d   modify $ \s -> s{ usePrefix = oldUsePrefix }   renderList xs -renderList (BeforeNonBlank d : xs) =-  case xs of+renderList (FBeforeNonBlank d : xs) = do+  let next = dropWhile (not . isPrintable) xs+  case next of     (x:_) | startsBlank x -> renderList xs-          | otherwise     -> renderDoc d >> renderList xs+          | otherwise     -> renderList (normalize $ N.toList d) >> renderList xs     []                    -> renderList xs-renderList (BlankLines num : xs) = do++renderList (FBlankLines num : xs) = do   st <- get   case output st of      _ | newlines st > num -> return ()        | otherwise -> replicateM_ (1 + num - newlines st) newline   renderList xs -renderList (CarriageReturn : xs) = do+renderList (FCarriageReturn : xs) = do   st <- get   if newlines st > 0      then renderList xs@@ -410,12 +542,12 @@        newline        renderList xs -renderList (NewLine : xs) = do+renderList (FNewLine : xs) = do   newline   renderList xs -renderList (BreakingSpace : xs) = do-  let isBreakingSpace BreakingSpace = True+renderList (FBreakingSpace : xs) = do+  let isBreakingSpace FBreakingSpace = True       isBreakingSpace _ = False   let xs' = dropWhile isBreakingSpace xs   let next = takeWhile (not . isBreakable) xs'@@ -426,41 +558,39 @@         _  -> when (column st > 0) $ outp 1 " "   renderList xs' -renderList (AfterBreak t : xs) = do+renderList (FAfterBreak t : xs) = do   st <- get   if newlines st > 0-     then renderList (fromString (T.unpack t) : xs)+     then renderList (toList t <> xs)      else renderList xs -renderList (b : xs) | isBlock b = do+-- FBlock and FVFill are all that's left+renderList (b : xs) = do+  st <- get+  let font = peekFont st   let (bs, rest) = span isBlock xs   -- ensure we have right padding unless end of line-  let heightOf (Block _ ls) = length ls+  let heightOf (FBlock _ ls) = length ls       heightOf _            = 1   let maxheight = maximum $ map heightOf (b:bs)-  let toBlockSpec (Block w ls) = (w, ls)-      toBlockSpec (VFill w t)  = (w, take maxheight $ repeat t)+  let toBlockSpec (FBlock w ls) = (w, ls)+      toBlockSpec (FVFill w t)  = (w, map (singleton . (Attr (linkTarget st) font)) (take maxheight $ repeat t))       toBlockSpec _            = (0, [])   let (_, lns') = foldl (mergeBlocks maxheight) (toBlockSpec b)                              (map toBlockSpec bs)-  st <- get   let oldPref = prefix st   case column st - realLength oldPref of         n | n > 0 -> modify $ \s -> s{ prefix = oldPref <> T.replicate n " " }         _ -> return ()-  renderList $ intersperse CarriageReturn (map literal lns')+  renderList $ intersperse FCarriageReturn (mapMaybe cook lns')   modify $ \s -> s{ prefix = oldPref }   renderList rest -renderList (x:_) = error $ "renderList encountered " ++ show x--isBreakable :: HasChars a => Doc a -> Bool-isBreakable BreakingSpace      = True-isBreakable CarriageReturn     = True-isBreakable NewLine            = True-isBreakable (BlankLines _)     = True-isBreakable (Concat Empty y)   = isBreakable y-isBreakable (Concat x _)       = isBreakable x+isBreakable :: HasChars a => FlatDoc a -> Bool+isBreakable FBreakingSpace      = True+isBreakable FCarriageReturn     = True+isBreakable FNewLine            = True+isBreakable (FBlankLines _)     = True isBreakable _                  = False  startsBlank' :: HasChars a => a -> Bool@@ -469,33 +599,43 @@    go Nothing  c = Just (isSpace c)    go (Just b) _ = Just b -startsBlank :: HasChars a => Doc a -> Bool-startsBlank (Text _ t)         = startsBlank' t-startsBlank (Block n ls)       = n > 0 && all startsBlank' ls-startsBlank (VFill n t)        = n > 0 && startsBlank' t-startsBlank (BeforeNonBlank x) = startsBlank x-startsBlank (Prefixed _ x)     = startsBlank x-startsBlank (Flush x)          = startsBlank x-startsBlank BreakingSpace      = True-startsBlank (AfterBreak t)     = startsBlank (Text 0 t)-startsBlank CarriageReturn     = True-startsBlank NewLine            = True-startsBlank (BlankLines _)     = True-startsBlank (Concat Empty y)   = startsBlank y-startsBlank (Concat x _)       = startsBlank x-startsBlank Empty              = True+startsBlank :: HasChars a => FlatDoc a -> Bool+startsBlank (FText _ t)                = startsBlank' t+startsBlank (FCookedText _ t)          = startsBlank' t+startsBlank (FBlock n ls)              = n > 0 && all startsBlank' ls+startsBlank (FVFill n t)               = n > 0 && startsBlank' t+startsBlank (FBeforeNonBlank (x :| _)) = startsBlank x+startsBlank (FPrefixed _ (x :| _))     = startsBlank x+startsBlank (FFlush (x :| _))          = startsBlank x+startsBlank FBreakingSpace             = True+startsBlank (FAfterBreak (t :| _))     = startsBlank t+startsBlank FCarriageReturn            = True+startsBlank FNewLine                   = True+startsBlank (FBlankLines _)            = True+startsBlank (FStyleOpen _)             = True+startsBlank (FLinkOpen _)              = True+startsBlank FStyleClose                = True+startsBlank FLinkClose                 = True -isBlock :: Doc a -> Bool-isBlock Block{} = True-isBlock VFill{} = True+isPrintable :: FlatDoc a -> Bool+isPrintable FLinkOpen{} = False+isPrintable FLinkClose{} = False+isPrintable FStyleOpen{} = False+isPrintable FStyleClose{} = False+isPrintable _ = True++isBlock :: FlatDoc a -> Bool+isBlock FBlock{} = True+isBlock FVFill{} = True isBlock _       = False -offsetOf :: Doc a -> Int-offsetOf (Text o _)      = o-offsetOf (Block w _)     = w-offsetOf (VFill w _)     = w-offsetOf BreakingSpace   = 1-offsetOf _               = 0+offsetOf :: FlatDoc a -> Int+offsetOf (FText o _)       = o+offsetOf (FBlock w _)      = w+offsetOf (FVFill w _)      = w+offsetOf (FCookedText w _) = w+offsetOf FBreakingSpace    = 1+offsetOf _                = 0  -- | Create a 'Doc' from a stringlike value. literal :: HasChars a => a -> Doc a@@ -509,6 +649,10 @@         splitLines x {-# NOINLINE literal #-} +cook :: HasChars a => Attributed a -> Maybe (FlatDoc a)+cook x | isNull x = Nothing+       | otherwise = let !len = realLength x in Just (FCookedText len x)+ -- | A literal string.  (Like 'literal', but restricted to String.) text :: HasChars a => String -> Doc a text = literal . fromString@@ -592,7 +736,10 @@     Text n _ -> (l, c + n)     Block n _ -> (l, c + n)     VFill n _ -> (l, c + n)+    CookedText n _ -> (l, c + n)     Empty -> (l, c)+    Styled _ d -> getOffset breakWhen (l, c) d+    Linked _ d -> getOffset breakWhen (l, c) d     CarriageReturn -> (max l c, 0)     NewLine -> (max l c, 0)     BlankLines _ -> (max l c, 0)@@ -646,12 +793,14 @@ height :: HasChars a => Doc a -> Int height = length . splitLines . render Nothing -block :: HasChars a => (a -> a) -> Int -> Doc a -> Doc a+block :: HasChars a => (Attributed a -> Attributed a) -> Int -> Doc a -> Doc a block filler width d   | width < 1 && not (isEmpty d) = block filler 1 d   | otherwise                    = Block width ls      where-       ls = map filler $ chop width $ render (Just width) d+       preimage = prerender (Just width) d+       reboxed = chop width preimage+       ls = map filler reboxed  -- | An expandable border that, when placed next to a box, -- expands to the height of the box.  Strings cycle through the@@ -706,6 +855,69 @@ -- | Wraps a 'Doc' in double quotes. doubleQuotes :: HasChars a => Doc a -> Doc a doubleQuotes = inside (char '"') (char '"')++styled :: HasChars a => StyleReq -> Doc a -> Doc a+styled _ Empty = Empty+styled s x = Styled s x++-- | Puts a 'Doc' in boldface.+bold :: HasChars a => Doc a -> Doc a+bold = styled (RWeight Bold)++-- | Puts a 'Doc' in italics.+italic :: HasChars a => Doc a -> Doc a+italic = styled (RShape Italic)++-- | Underlines a 'Doc'.+underlined :: HasChars a => Doc a -> Doc a+underlined = styled (RUnderline ULSingle)++-- | Puts a line through a 'Doc'.+strikeout :: HasChars a => Doc a -> Doc a+strikeout = styled (RStrikeout Struck)++-- The Color type is here as an opaque alias to Color8 for the public interface+-- and there's trivial smart constructors for the individual colors to+-- hopefully allow for easier extension to supporting indexed and rgb colors in+-- the future, without dramatically changing the public API.++type Color = Color8++-- | Set foreground color.+fg :: HasChars a => Color -> Doc a -> Doc a+fg = styled . RForeground . FG++-- | Set background color.+bg :: HasChars a => Color -> Doc a -> Doc a+bg = styled . RBackground . BG++blue :: Color+blue = Blue++black :: Color+black = Black++red :: Color+red = Red++green :: Color+green = Green++yellow :: Color+yellow = Yellow++magenta :: Color+magenta = Magenta++cyan :: Color+cyan = Cyan++white :: Color+white = White++-- | Make Doc a hyperlink.+link :: HasChars a => Text -> Doc a -> Doc a+link = Linked  -- | Returns width of a character in a monospace font:  0 for a combining -- character, 1 for a regular character, 2 for an East Asian wide character.

@@ -0,0 +1,107 @@+{-# LANGUAGE OverloadedStrings  #-}+{-# LANGUAGE DeriveDataTypeable #-}+module Text.DocLayout.ANSIFont+  ( Font(..)+  , baseFont+  , StyleReq(..)+  , Weight(..)+  , Shape(..)+  , Color8(..)+  , Underline(..)+  , Strikeout(..)+  , Foreground(..)+  , Background(..)+  , (~>)+  , renderFont+  , renderOSC8+  ) where++import Data.Data (Data)+import Data.String+import Data.Text (Text)++data Font = Font+  { ftWeight :: Weight,+    ftShape :: Shape,+    ftUnderline :: Underline,+    ftStrikeout :: Strikeout,+    ftForeground :: Foreground,+    ftBackground :: Background,+    ftLink :: Maybe Text+  }+  deriving (Show, Eq, Read, Data, Ord)++baseFont :: Font+baseFont = Font Normal Roman ULNone Unstruck FGDefault BGDefault Nothing++data Weight = Normal | Bold deriving (Show, Eq, Read, Data, Ord)+data Shape = Roman | Italic deriving (Show, Eq, Read, Data, Ord)+data Color8 = Black | Red | Green | Yellow | Blue | Magenta | Cyan | White deriving (Show, Eq, Enum, Read, Data, Ord)+data Underline = ULNone | ULSingle | ULDouble | ULCurly deriving (Show, Eq, Read, Data, Ord)+data Strikeout = Unstruck | Struck deriving (Show, Eq, Read, Data, Ord)+data Foreground = FGDefault | FG Color8 deriving (Show, Eq, Read, Data, Ord)+data Background = BGDefault | BG Color8 deriving (Show, Eq, Read, Data, Ord)++data StyleReq+  = RWeight Weight+  | RShape Shape+  | RForeground Foreground+  | RBackground Background+  | RUnderline Underline+  | RStrikeout Strikeout+  deriving (Show, Eq, Read, Data, Ord)++(~>) :: Font -> StyleReq -> Font+(~>) f (RWeight w) = f{ftWeight = w}+(~>) f (RShape s) = f{ftShape = s}+(~>) f (RForeground c) = f{ftForeground = c}+(~>) f (RBackground c) = f{ftBackground = c}+(~>) f (RUnderline u) = f{ftUnderline = u}+(~>) f (RStrikeout u) = f{ftStrikeout = u}++rawSGR :: (Semigroup a, IsString a) => a -> a+rawSGR n = "\ESC[" <> n <> "m"++class SGR b where+  renderSGR :: (Semigroup a, IsString a) => b -> a++instance SGR Weight where+  renderSGR Normal = rawSGR "22"+  renderSGR Bold = rawSGR "1"++instance SGR Shape where+  renderSGR Roman = rawSGR "23"+  renderSGR Italic = rawSGR "3"++instance SGR Foreground where+  renderSGR FGDefault = rawSGR "39"+  renderSGR (FG a) = (rawSGR . fromString . show . (+) 30 . fromEnum) a++instance SGR Background where+  renderSGR BGDefault = rawSGR "49"+  renderSGR (BG a) = (rawSGR . fromString . show . (+) 40 . fromEnum) a++instance SGR Underline where+  renderSGR ULNone = rawSGR "24"+  renderSGR ULSingle = rawSGR "4"+  renderSGR ULDouble = rawSGR "21"+  renderSGR ULCurly = rawSGR "4:3"++instance SGR Strikeout where+  renderSGR Unstruck = rawSGR "29"+  renderSGR Struck = rawSGR "9"++renderFont :: (Semigroup a, IsString a) => Font -> a+renderFont f+  | f == baseFont = rawSGR "0"+  | otherwise =+      renderSGR (ftWeight f)+        <> renderSGR (ftShape f)+        <> renderSGR (ftForeground f)+        <> renderSGR (ftBackground f)+        <> renderSGR (ftUnderline f)+        <> renderSGR (ftStrikeout f)++renderOSC8 :: (Semigroup a, IsString a) => Maybe a -> a+renderOSC8 Nothing = "\ESC]8;;\ESC\\"+renderOSC8 (Just t) = "\ESC]8;;" <> t <> "\ESC\\"

@@ -0,0 +1,50 @@+{-# LANGUAGE DeriveGeneric      #-}+{-# LANGUAGE DeriveTraversable  #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-}+module Text.DocLayout.Attributed (Attributed(..), Attr(..), Link, fromList, singleton)+  where++import Data.String+import Text.DocLayout.ANSIFont (Font, baseFont)+import Data.Data (Data, Typeable)+import GHC.Generics+import Data.Sequence ((><))+import qualified Data.Sequence as S+import Data.Text (Text)++type Link = Maybe Text++-- | Font attributes.+data Attr a = Attr Link Font a+  deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable,+    Data, Typeable, Generic)++instance Semigroup a => Semigroup (Attr a) where+  (<>) (Attr l f x) (Attr _ _ y) = Attr l f $ x <> y  -- This is arbitrary++instance (IsString a, Monoid a) => Monoid (Attr a) where+  mempty = Attr Nothing baseFont (fromString "")++-- | A sequence of strings with font attributes.+newtype Attributed a = Attributed (S.Seq (Attr a))+  deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable,+         Data, Typeable, Generic)++fromList :: [Attr a] -> Attributed a+fromList = Attributed . S.fromList++singleton :: Attr a -> Attributed a+singleton = Attributed . S.singleton++instance IsString a => IsString (Attr a) where+  fromString x = Attr Nothing baseFont (fromString x)++instance IsString a => IsString (Attributed a) where+  fromString x = Attributed $ S.singleton $ Attr Nothing baseFont (fromString x)++instance Semigroup a => Semigroup (Attributed a) where+  (<>) (Attributed a) (Attributed b) = Attributed $ a >< b++instance Monoid a => Monoid (Attributed a) where+  mempty = Attributed S.empty

@@ -0,0 +1,89 @@+{-# LANGUAGE CPP                #-}+{-# LANGUAGE FlexibleInstances  #-}+{-# LANGUAGE NoImplicitPrelude  #-}+{-# LANGUAGE OverloadedStrings  #-}+module Text.DocLayout.HasChars (HasChars(..)) where+import Prelude+import Data.String+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import Data.Text (Text)+import qualified Data.Text.Lazy.Builder as B+import Data.List (foldl', uncons)+import Data.Maybe (fromMaybe)+import Text.DocLayout.Attributed+import Data.Sequence (Seq(..), (|>))+import qualified Data.Sequence as S++-- | Class abstracting over various string types that+-- can fold over characters.  Minimal definition is 'foldrChar'+-- and 'foldlChar', but defining the other methods can give better+-- performance.+class (IsString a, Semigroup a, Monoid a, Show a) => HasChars a where+  foldrChar     :: (Char -> b -> b) -> b -> a -> b+  foldlChar     :: (b -> Char -> b) -> b -> a -> b+  replicateChar :: Int -> Char -> a+  replicateChar n c = fromString (replicate n c)+  isNull        :: a -> Bool+  isNull = foldrChar (\_ _ -> False) True+  splitLines    :: a -> [a]+  splitLines s = (fromString firstline : otherlines)+   where+    (firstline, otherlines) = foldrChar go ([],[]) s+    go '\n' (cur,lns) = ([], fromString cur : lns)+    go c    (cur,lns) = (c:cur, lns)+  build         :: a -> B.Builder+  build = foldrChar (mappend . B.singleton) (B.fromString "")++instance HasChars Text where+  foldrChar         = T.foldr+  foldlChar         = T.foldl'+  splitLines        = T.splitOn "\n"+  replicateChar n c = T.replicate n (T.singleton c)+  isNull            = T.null+  build             = B.fromText++instance HasChars String where+  foldrChar     = foldr+  foldlChar     = foldl'+  splitLines    = lines . (++"\n")+  replicateChar = replicate+  isNull        = null+  build         = B.fromString++instance HasChars TL.Text where+  foldrChar         = TL.foldr+  foldlChar         = TL.foldl'+  splitLines        = TL.splitOn "\n"+  replicateChar n c = TL.replicate (fromIntegral n) (TL.singleton c)+  isNull            = TL.null+  build             = B.fromLazyText++instance HasChars a => HasChars (Attr a) where+  foldrChar f a (Attr _ _ x) = foldrChar f a x+  foldlChar f a (Attr _ _ x) = foldlChar f a x+  splitLines (Attr l f x) = Attr l f <$> splitLines x+  build (Attr _ _ x) = build x++instance (HasChars a) => HasChars (Attributed a) where+  foldrChar _ acc (Attributed S.Empty) = acc+  foldrChar f acc (Attributed (xs :|> (Attr _ _ x))) =+    let l = foldrChar f acc x+        innerFold e a = foldrChar f a e+     in foldr innerFold l xs+  foldlChar _ acc (Attributed S.Empty) = acc+  foldlChar f acc (Attributed ((Attr _ _ x) :<| xs)) =+    let l = foldlChar f acc x+        innerFold e a = foldlChar f a e+     in foldr innerFold l xs+  splitLines (Attributed s) = fmap Attributed $ reverse $ go ([], S.empty) s+    where+      go (lns, cur) S.Empty = cur : lns+      go (lns, cur) (x :<| xs) =+        case splitLines x of+          []      -> go (cur : lns, S.empty) xs+          [k1]    -> go (lns, cur |> k1) xs+          k1 : ks ->+            let (end, most) = fromMaybe (S.empty, []) $ uncons $ reverse $ S.singleton <$> ks+             in go (most ++ (cur |> k1) : lns, end) xs+  build = foldMap build

@@ -287,6 +287,11 @@       (literal "a" <> cr <> literal "\nb" <> cr <> literal "c")       "a\n\nb\nc" +  , renderTest "breaking within styled text"+      (Just 5)+      ("hi" <+> (fg blue ("mom" <+> "and" <+> "dad")))+      "hi\nmom\nand\ndad"+   , testCase "length of normal text" $       realLength ("This is going to be too long anyway" :: String) @?= 35