Script 'mail_helper' called by obssrc Hello community, here is the log from the commit of package ghc-doclayout for openSUSE:Factory checked in at 2024-10-28 15:18:29 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-doclayout (Old) and /work/SRC/openSUSE:Factory/.ghc-doclayout.new.2020 (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-doclayout" Mon Oct 28 15:18:29 2024 rev:11 rq:1218550 version:0.5 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-doclayout/ghc-doclayout.changes 2023-04-04 21:19:56.673008367 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-doclayout.new.2020/ghc-doclayout.changes 2024-10-28 15:20:19.675470117 +0100 @@ -1,0 +2,35 @@ +Mon Sep 9 05:57:29 UTC 2024 - Peter Simons <[email protected]> + +- Update doclayout to version 0.5. + ## 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`. + +------------------------------------------------------------------- Old: ---- doclayout-0.4.0.1.tar.gz New: ---- doclayout-0.5.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-doclayout.spec ++++++ --- /var/tmp/diff_new_pack.lriC5Y/_old 2024-10-28 15:20:20.631509931 +0100 +++ /var/tmp/diff_new_pack.lriC5Y/_new 2024-10-28 15:20:20.635510098 +0100 @@ -1,7 +1,7 @@ # # spec file for package ghc-doclayout # -# Copyright (c) 2023 SUSE LLC +# Copyright (c) 2024 SUSE LLC # # All modifications and additions to the file contributed by third parties # remain the property of their copyright owners, unless otherwise agreed @@ -20,7 +20,7 @@ %global pkgver %{pkg_name}-%{version} %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.4.0.1 +Version: 0.5 Release: 0 Summary: A prettyprinting library for laying out text documents License: BSD-3-Clause @@ -105,9 +105,9 @@ %license LICENSE %dir %{_datadir}/%{pkg_name}-%{version} %{_datadir}/%{pkg_name}-%{version}/README.md -%{_datadir}/%{pkg_name}-%{version}/changelog.md %files devel -f %{name}-devel.files +%doc changelog.md %files -n ghc-%{pkg_name}-doc -f ghc-%{pkg_name}-doc.files %license LICENSE ++++++ doclayout-0.4.0.1.tar.gz -> doclayout-0.5.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/doclayout-0.4.0.1/changelog.md new/doclayout-0.5/changelog.md --- old/doclayout-0.4.0.1/changelog.md 2001-09-09 03:46:40.000000000 +0200 +++ new/doclayout-0.5/changelog.md 2001-09-09 03:46:40.000000000 +0200 @@ -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). diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/doclayout-0.4.0.1/doclayout.cabal new/doclayout-0.5/doclayout.cabal --- old/doclayout-0.4.0.1/doclayout.cabal 2001-09-09 03:46:40.000000000 +0200 +++ new/doclayout-0.5/doclayout.cabal 2001-09-09 03:46:40.000000000 +0200 @@ -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: [email protected] -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, diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/doclayout-0.4.0.1/src/Text/DocLayout/ANSIFont.hs new/doclayout-0.5/src/Text/DocLayout/ANSIFont.hs --- old/doclayout-0.4.0.1/src/Text/DocLayout/ANSIFont.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/doclayout-0.5/src/Text/DocLayout/ANSIFont.hs 2001-09-09 03:46:40.000000000 +0200 @@ -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\\" diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/doclayout-0.4.0.1/src/Text/DocLayout/Attributed.hs new/doclayout-0.5/src/Text/DocLayout/Attributed.hs --- old/doclayout-0.4.0.1/src/Text/DocLayout/Attributed.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/doclayout-0.5/src/Text/DocLayout/Attributed.hs 2001-09-09 03:46:40.000000000 +0200 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/doclayout-0.4.0.1/src/Text/DocLayout/HasChars.hs new/doclayout-0.5/src/Text/DocLayout/HasChars.hs --- old/doclayout-0.4.0.1/src/Text/DocLayout/HasChars.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/doclayout-0.5/src/Text/DocLayout/HasChars.hs 2001-09-09 03:46:40.000000000 +0200 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/doclayout-0.4.0.1/src/Text/DocLayout.hs new/doclayout-0.5/src/Text/DocLayout.hs --- old/doclayout-0.4.0.1/src/Text/DocLayout.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/doclayout-0.5/src/Text/DocLayout.hs 2001-09-09 03:46:40.000000000 +0200 @@ -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 - -isBlock :: Doc a -> Bool -isBlock Block{} = True -isBlock VFill{} = 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 + +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 @@ -707,6 +856,69 @@ 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. -- Ambiguous characters are treated as width 1. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/doclayout-0.4.0.1/test/test.hs new/doclayout-0.5/test/test.hs --- old/doclayout-0.4.0.1/test/test.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/doclayout-0.5/test/test.hs 2001-09-09 03:46:40.000000000 +0200 @@ -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
