dynamic-pp (empty) → 0.1.0
raw patch · 5 files changed
+1751/−0 lines, 5 filesdep +Cabaldep +HUnit-Plusdep +ansi-terminalsetup-changed
Dependencies added: Cabal, HUnit-Plus, ansi-terminal, base, blaze-builder, bytestring, hashable, unordered-containers, utf8-string
Files
- LICENSE +28/−0
- Setup.hs +2/−0
- dynamic-pp.cabal +47/−0
- src/Text/Format.hs +1631/−0
- test/UnitTest.hs +43/−0
+ LICENSE view
@@ -0,0 +1,28 @@+Copyright (c) 2015, Eric McCorkle+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++* Neither the name of dynamic-pp nor the names of its+ contributors may be used to endorse or promote products derived from+ this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ dynamic-pp.cabal view
@@ -0,0 +1,47 @@+Name: dynamic-pp+Category: Text+Version: 0.1.0+License: BSD3+License-File: LICENSE+Author: Eric McCorkle+Maintainer: Eric McCorkle <emc2@metricspace.net>+Stability: Alpha+Synopsis: A pretty-print library that employs a dynamic programming algorithm for optimal rendering.+Homepage: https://github.com/emc2/dynamic-pp+Bug-Reports: https://github.com/emc2/dynamic-pp/issues+Copyright: Copyright (c) 2015 Eric McCorkle. All rights reserved.+Description:+ This library provides pretty-print operators similar to the set provided by the Wadler-Leijin pretty-printer.+ The main difference, however, is that it utilizes a dynamic programming algorithm for rendering. This slightly+ reduces the available combinators, but provides a layout engine that optimizes documents, minimizing their+ over-wrap and line count.+ .+ The dynamic programming algorithm has pathological cases that cause it to run in quadratic time; however,+ typical use on code-like programs should see better run times. In general, documents with many uses of the+ choose combinator will require more time to render.+ .+ This library also provides two simpler rendering engines for uses where the full optimal layout engine is not+ necessary. These engines are much simpler and consume fewer resources.+Build-type: Simple+Cabal-version: >= 1.16++Source-Repository head+ Type: git+ Location: git@github.com:emc2/dynamic-pp.git++Test-Suite UnitTest+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ Main-Is: UnitTest.hs+ hs-source-dirs: src test+ build-depends: base >= 4.4.0 && < 5, Cabal >= 1.16.0, hashable, bytestring,+ utf8-string, blaze-builder, ansi-terminal, unordered-containers,+ HUnit-Plus+ ghc-options: -fhpc++Library+ default-language: Haskell2010+ hs-source-dirs: src+ build-depends: base >= 4.4.0 && < 5, Cabal >= 1.16.0, hashable, bytestring,+ utf8-string, blaze-builder, ansi-terminal, unordered-containers+ exposed-modules: Text.Format
+ src/Text/Format.hs view
@@ -0,0 +1,1631 @@+-- Copyright (c) 2015 Eric McCorkle. All rights reserved.+--+-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions+-- are met:+-- 1. Redistributions of source code must retain the above copyright+-- notice, this list of conditions and the following disclaimer.+-- 2. Redistributions in binary form must reproduce the above copyright+-- notice, this list of conditions and the following disclaimer in the+-- documentation and/or other materials provided with the distribution.+-- 3. Neither the name of the author nor the names of any contributors+-- may be used to endorse or promote products derived from this software+-- without specific prior written permission.+--+-- THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS ``AS IS''+-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED+-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A+-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS+-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+-- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+-- LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF+-- USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND+-- ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT+-- OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+-- SUCH DAMAGE.+{-# OPTIONS_GHC -Wall -Werror -funbox-strict-fields #-}+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances,+ MultiParamTypeClasses, UndecidableInstances #-}++-- | A pretty printer implementation, based loosely on the+-- Wadler-Leijin pretty printer, but redesigned to facilitate a+-- dynamic programming optimal layout algorithm.+--+-- This pretty printer module trades some of the generality of the+-- Wadler-Leijin scheme in order to facilitate an efficient optimizing+-- layout engine. The nesting, column, and width combinators are+-- removed.+module Text.Format(+ -- * Basic Definitions+ -- ** Types+ Doc,+ Graphics(..),+ -- ** Type Classes+ Format(..),+ FormatM(..),++ -- * Creating @Doc@s++ -- ** Constructors++ -- *** Basic+ empty,+ line,+ linebreak,+ softline,+ softbreak,++ -- *** From datatypes+ char,+ string,+ bytestring,+ lazyBytestring,++ -- *** Literals+ lparen,+ rparen,+ lbrack,+ rbrack,+ lbrace,+ rbrace,+ langle,+ rangle,+ squote,+ dquote,+ backquote,+ comma,+ semi,+ colon,+ dot,+ backslash,+ equals,+ space,++ -- *** Derived+ nest,+ indent,+ align,+ squoted,+ dquoted,+ parens,+ brackets,+ braces,+ angles,+ list,++ -- *** Graphics Mode+ graphics,+ dullWhite,+ dullRed,+ dullYellow,+ dullGreen,+ dullBlue,+ dullCyan,+ dullMagenta,+ dullBlack,+ vividWhite,+ vividRed,+ vividYellow,+ vividGreen,+ vividBlue,+ vividCyan,+ vividMagenta,+ vividBlack,+ dullWhiteBackground,+ dullRedBackground,+ dullYellowBackground,+ dullGreenBackground,+ dullBlueBackground,+ dullCyanBackground,+ dullMagentaBackground,+ dullBlackBackground,+ vividWhiteBackground,+ vividRedBackground,+ vividYellowBackground,+ vividGreenBackground,+ vividBlueBackground,+ vividCyanBackground,+ vividMagentaBackground,+ vividBlackBackground,++ -- ** Combining @Doc@s++ -- *** Basic+ beside,+ concat,+ choose,++ -- *** Derived+ (<>),+ (<+>),+ (<$>),+ (<$$>),+ (</>),+ (<//>),+ hsep,+ hcat,+ vsep,+ vcat,+ sep,+ cat,+ fillSep,+ fillCat,+ enclose,+ punctuate,+ encloseSep,++ -- ** Transforming @Doc@s+ flatten,+ group,++ -- * Rendering @Doc@s+ renderOneLine,+ buildOneLine,+ putOneLine,+ renderFast,+ buildFast,+ putFast,+ renderOptimal,+ buildOptimal,+ putOptimal+ ) where++import Blaze.ByteString.Builder+import Blaze.ByteString.Builder.Char.Utf8+import Control.Monad+import Data.Hashable+import Data.HashMap.Strict(HashMap)+import Data.List(intersperse, minimumBy)+import Data.Maybe+import Data.Monoid hiding ((<>))+import Data.Word+import Prelude hiding (concat)+import System.Console.ANSI+import System.IO++import qualified Data.ByteString as Strict+import qualified Data.ByteString.UTF8 as Strict.UTF8+import qualified Data.ByteString.Lazy as Lazy+import qualified Data.ByteString.Lazy.Char8 as Lazy.Char8+import qualified Data.ByteString.Lazy.UTF8 as Lazy.UTF8+import qualified Data.HashMap.Strict as HashMap++-- | Datatype representing a formatted document.++-- Docs are organized into a tree structure whose nodes dictate the+-- formatting of the generated text. These are rendered by the+-- various rendering engines into a Builder (from the blaze-builder+-- library).+data Doc =+ -- | A single character. Cannot be a newline.+ Char { charContent :: !Char }+ -- | A raw Builder that constructs a string containing no+ -- newlines. This is used to represent basic text.+ | Builder {+ -- | Length of the text that gets built.+ builderLength :: !Int,+ -- | A Builder that constructs the text.+ builderContent :: !Builder+ }+ -- | A newline.+ | Line {+ -- | Whether to insert a space when undone by a group.+ insertSpace :: !Bool+ }+ -- | Concatenated documents. An empty list here represents an empty @Doc@.+ | Cat {+ catDocs :: [Doc]+ }+ -- | Increase the nesting level of a document.+ | Nest {+ -- | Amount by which to increase nesting.+ nestLevel :: !Int,+ -- | Whether to align to the current column, or the base nesting+ -- level.+ nestAlign :: !Bool,+ -- | Whether the indentation is delayed, or takes place immediately.+ nestDelay :: !Bool,+ -- | Document whose nesting should be increased.+ nestDoc :: Doc+ }+ -- | Choose the \"best\" from among a list of options.+ | Choose {+ -- | The list of options.+ chooseOptions :: [Doc]+ }+ -- | Set graphics mode options when rendering the child @Doc@.+ | Graphics {+ -- | Graphics mode to set.+ graphicsSGR :: !Graphics,+ -- | Document to render with graphic mode.+ graphicsDoc :: Doc+ }++-- | Graphics options for ANSI terminals. All options are wrapped in+-- the 'Maybe' datatype, with 'Nothing' meaning \"leave this option+-- as-is\".+data Graphics =+ -- | Set options on the terminal, or keep the current setting in+ -- the case of 'Nothing'.+ Options {+ -- | Console intensity.+ consoleIntensity :: !(Maybe ConsoleIntensity),+ -- | Underlining.+ underlining :: !(Maybe Underlining),+ -- | Blinking speed.+ blinkSpeed :: !(Maybe BlinkSpeed),+ -- | Foreground color and intensity.+ foreground :: !(Maybe (Color, ColorIntensity)),+ -- | Background color and intensity.+ background :: !(Maybe (Color, ColorIntensity)),+ -- | Whether or not to swap the foreground and background.+ swapForegroundBackground :: !(Maybe Bool)+ }+ -- | Reset the terminal in this mode.+ | Default++-- | Generate a 'Doc' representing a graphics mode switch.+switchGraphics :: Graphics -> Graphics -> Builder+switchGraphics _ Default = fromString (setSGRCode [Reset])+switchGraphics Default Options { consoleIntensity = consIntensity,+ swapForegroundBackground = swap,+ underlining = underline,+ foreground = fore,+ background = back,+ blinkSpeed = blink } =+ let+ withConsIntensity = maybe [] ((: []) . SetConsoleIntensity) consIntensity+ withUnderline = maybe withConsIntensity ((: withConsIntensity) .+ SetUnderlining)+ underline+ withBlink = maybe withUnderline ((: withUnderline) . SetBlinkSpeed) blink+ withSwap = maybe withBlink ((: withBlink) . SetSwapForegroundBackground)+ swap+ withForeground =+ maybe withSwap (\(color, intensity) -> SetColor Foreground intensity+ color : withSwap) fore+ withBackground =+ maybe withForeground (\(color, intensity) -> SetColor Background intensity+ color : withForeground) back+ in+ fromString (setSGRCode withBackground)+switchGraphics Options { consoleIntensity = consIntensity1,+ swapForegroundBackground = swap1,+ underlining = underline1,+ foreground = fore1,+ background = back1,+ blinkSpeed = blink1 }+ Options { consoleIntensity = consIntensity2,+ swapForegroundBackground = swap2,+ underlining = underline2,+ foreground = fore2,+ background = back2,+ blinkSpeed = blink2 } =+ let+ withConsIntensity =+ if consIntensity1 /= consIntensity2+ then maybe [] ((: []) . SetConsoleIntensity) consIntensity2+ else []+ withUnderline =+ if underline1 /= underline2+ then maybe withConsIntensity ((: withConsIntensity) . SetUnderlining)+ underline2+ else withConsIntensity+ withBlink =+ if blink1 /= blink2+ then maybe withUnderline ((: withUnderline) . SetBlinkSpeed) blink2+ else withUnderline+ withSwap =+ if swap1 /= swap2+ then maybe withBlink ((: withBlink) . SetSwapForegroundBackground) swap2+ else withBlink+ withForeground =+ if fore1 /= fore2+ then maybe withSwap (\(color, intensity) ->+ SetColor Foreground intensity color : withSwap)+ fore2+ else withSwap+ withBackground =+ if back1 /= back2+ then maybe withSwap (\(color, intensity) ->+ SetColor Background intensity color :+ withForeground) back2+ else withForeground+ in+ fromString (setSGRCode withBackground)++-- | An empty 'Doc'.+empty :: Doc+empty = Cat { catDocs = [] }++-- | A 'Doc' consisting of a linebreak, that is not turned into a+-- space when erased by a 'group'.+line :: Doc+line = Line { insertSpace = False }++-- | A 'Doc' consisting of a linebreak, that is turned into a space+-- when erased by a 'group'.+linebreak :: Doc+linebreak = Line { insertSpace = True }++-- | A 'Doc' consisting of a space character, that can be turned into+-- a linebreak in order to break lines that are too long.+softline :: Doc+softline = Choose { chooseOptions = [ char ' ', linebreak ] }++-- | An empty 'Doc' that can be turned into a linebreak in order to+-- break lines that are too long.+softbreak :: Doc+softbreak = Choose { chooseOptions = [ empty, line ] }++-- | A 'Doc' containing a single character.+char :: Char -> Doc+char '\n' = line+char chr = Char { charContent = chr }++-- | Create a 'Doc' containing a string.+string :: String -> Doc+string str = Builder { builderContent = fromString str,+ builderLength = length str }++-- | Create a 'Doc' containing a bytestring.+bytestring :: Strict.ByteString -> Doc+bytestring txt+ | Strict.null txt = empty+ | otherwise = Builder { builderLength = Strict.UTF8.length txt,+ builderContent = fromByteString txt }++-- | Create a 'Doc' containing a lazy bytestring+lazyBytestring :: Lazy.ByteString -> Doc+lazyBytestring txt+ | Lazy.null txt = empty+ | otherwise = Builder { builderLength = Lazy.UTF8.length txt,+ builderContent = fromLazyByteString txt }++-- | The character @(@+lparen :: Doc+lparen = char '('++-- | The character @)@+rparen :: Doc+rparen = char ')'++-- | The character @[@+lbrack :: Doc+lbrack = char '['++-- | The character @]@+rbrack :: Doc+rbrack = char ']'++-- | The character @{@+lbrace :: Doc+lbrace = char '{'++-- | The character @}@+rbrace :: Doc+rbrace = char '}'++-- | The character @<@+langle :: Doc+langle = char '<'++-- | The character @>@+rangle :: Doc+rangle = char '>'++-- | The character @'@+squote :: Doc+squote = char '\''++-- | The character @"@+dquote :: Doc+dquote = char '"'++-- | The character @`@+backquote :: Doc+backquote = char '`'++-- | The character @,@+comma :: Doc+comma = char ','++-- | The character @;@+semi :: Doc+semi = char ';'++-- | The character @:@+colon :: Doc+colon = char ':'++-- | The character @.@+dot :: Doc+dot = char '.'++-- | The character @\@+backslash :: Doc+backslash = char '\\'++-- | A space character.+space :: Doc+space = char ' '++-- | The character @=@+equals :: Doc+equals = char '='++-- | Increase the indentation level of a document by some amount.+nest :: Int -> Doc -> Doc+nest _ c @ Cat { catDocs = [] } = c+nest lvl n @ Nest { nestLevel = lvl' } = n { nestLevel = lvl + lvl' }+nest lvl doc = Nest { nestDelay = True, nestAlign = False,+ nestLevel = lvl, nestDoc = doc }++-- | Increase the indentation level of a document by some amount.+indent :: Int -> Doc -> Doc+indent _ c @ Cat { catDocs = [] } = c+indent lvl n @ Nest { nestLevel = lvl' } = n { nestLevel = lvl + lvl' }+indent lvl doc = Nest { nestDelay = False, nestAlign = False,+ nestLevel = lvl, nestDoc = doc }++-- | Set the indentation level to the current column.+align :: Doc -> Doc+align inner = Nest { nestDelay = True, nestAlign = True,+ nestLevel = 0, nestDoc = inner }++-- | Enclose a 'Doc' in single quotes+squoted :: Doc -> Doc+squoted = enclose squote squote++-- | Enclose a 'Doc' in double quotes+dquoted :: Doc -> Doc+dquoted = enclose dquote dquote++-- | Enclose a 'Doc' in paretheses+parens :: Doc -> Doc+parens = enclose lparen rparen++-- | Enclose a 'Doc' in brackets+brackets :: Doc -> Doc+brackets = enclose lbrack rbrack++-- | Enclose a 'Doc' in braces+braces :: Doc -> Doc+braces = enclose lbrace rbrace++-- | Enclose a 'Doc' in angles+angles :: Doc -> Doc+angles = enclose langle rangle++-- | Set the graphics mode on a document.+graphics :: Graphics -> Doc -> Doc+graphics sgr doc = Graphics { graphicsDoc = doc, graphicsSGR = sgr }++-- | Color a 'Doc' dull white.+dullWhite :: Doc -> Doc+dullWhite = graphics Options { consoleIntensity = Nothing,+ underlining = Nothing,+ blinkSpeed = Nothing,+ foreground = Just (White, Dull),+ background = Nothing,+ swapForegroundBackground = Nothing }++-- | Color a 'Doc' dull red.+dullRed :: Doc -> Doc+dullRed = graphics Options { consoleIntensity = Nothing,+ underlining = Nothing,+ blinkSpeed = Nothing,+ foreground = Just (Red, Dull),+ background = Nothing,+ swapForegroundBackground = Nothing }++-- | Color a 'Doc' dull yellow.+dullYellow :: Doc -> Doc+dullYellow = graphics Options { consoleIntensity = Nothing,+ underlining = Nothing,+ blinkSpeed = Nothing,+ foreground = Just (Yellow, Dull),+ background = Nothing,+ swapForegroundBackground = Nothing }++-- | Color a 'Doc' dull green.+dullGreen :: Doc -> Doc+dullGreen = graphics Options { consoleIntensity = Nothing,+ underlining = Nothing,+ blinkSpeed = Nothing,+ foreground = Just (Green, Dull),+ background = Nothing,+ swapForegroundBackground = Nothing }++-- | Color a 'Doc' dull blue.+dullBlue :: Doc -> Doc+dullBlue = graphics Options { consoleIntensity = Nothing,+ underlining = Nothing,+ blinkSpeed = Nothing,+ foreground = Just (Blue, Dull),+ background = Nothing,+ swapForegroundBackground = Nothing }++-- | Color a 'Doc' dull cyan.+dullCyan :: Doc -> Doc+dullCyan = graphics Options { consoleIntensity = Nothing,+ underlining = Nothing,+ blinkSpeed = Nothing,+ foreground = Just (Cyan, Dull),+ background = Nothing,+ swapForegroundBackground = Nothing }++-- | Color a 'Doc' dull magenta.+dullMagenta :: Doc -> Doc+dullMagenta = graphics Options { consoleIntensity = Nothing,+ underlining = Nothing,+ blinkSpeed = Nothing,+ foreground = Just (Magenta, Dull),+ background = Nothing,+ swapForegroundBackground = Nothing }++-- | Color a 'Doc' dull black.+dullBlack :: Doc -> Doc+dullBlack = graphics Options { consoleIntensity = Nothing,+ underlining = Nothing,+ blinkSpeed = Nothing,+ foreground = Just (Black, Dull),+ background = Nothing,+ swapForegroundBackground = Nothing }++-- | Color a 'Doc' vivid white.+vividWhite :: Doc -> Doc+vividWhite = graphics Options { consoleIntensity = Nothing,+ underlining = Nothing,+ blinkSpeed = Nothing,+ foreground = Just (White, Vivid),+ background = Nothing,+ swapForegroundBackground = Nothing }++-- | Color a 'Doc' vivid red.+vividRed :: Doc -> Doc+vividRed = graphics Options { consoleIntensity = Nothing,+ underlining = Nothing,+ blinkSpeed = Nothing,+ foreground = Just (Red, Vivid),+ background = Nothing,+ swapForegroundBackground = Nothing }++-- | Color a 'Doc' vivid yellow.+vividYellow :: Doc -> Doc+vividYellow = graphics Options { consoleIntensity = Nothing,+ underlining = Nothing,+ blinkSpeed = Nothing,+ foreground = Just (Yellow, Vivid),+ background = Nothing,+ swapForegroundBackground = Nothing }++-- | Color a 'Doc' vivid green.+vividGreen :: Doc -> Doc+vividGreen = graphics Options { consoleIntensity = Nothing,+ underlining = Nothing,+ blinkSpeed = Nothing,+ foreground = Just (Green, Vivid),+ background = Nothing,+ swapForegroundBackground = Nothing }++-- | Color a 'Doc' vivid blue.+vividBlue :: Doc -> Doc+vividBlue = graphics Options { consoleIntensity = Nothing,+ underlining = Nothing,+ blinkSpeed = Nothing,+ foreground = Just (Blue, Vivid),+ background = Nothing,+ swapForegroundBackground = Nothing }++-- | Color a 'Doc' vivid cyan.+vividCyan :: Doc -> Doc+vividCyan = graphics Options { consoleIntensity = Nothing,+ underlining = Nothing,+ blinkSpeed = Nothing,+ foreground = Just (Cyan, Vivid),+ background = Nothing,+ swapForegroundBackground = Nothing }++-- | Color a 'Doc' vivid magenta.+vividMagenta :: Doc -> Doc+vividMagenta = graphics Options { consoleIntensity = Nothing,+ underlining = Nothing,+ blinkSpeed = Nothing,+ foreground = Just (Magenta, Vivid),+ background = Nothing,+ swapForegroundBackground = Nothing }++-- | Color a 'Doc' vivid black.+vividBlack :: Doc -> Doc+vividBlack = graphics Options { consoleIntensity = Nothing,+ underlining = Nothing,+ blinkSpeed = Nothing,+ foreground = Just (Black, Vivid),+ background = Nothing,+ swapForegroundBackground = Nothing }++-- | Color a 'Doc's background dull white.+dullWhiteBackground :: Doc -> Doc+dullWhiteBackground = graphics Options { consoleIntensity = Nothing,+ underlining = Nothing,+ blinkSpeed = Nothing,+ background = Just (White, Dull),+ foreground = Nothing,+ swapForegroundBackground = Nothing }++-- | Color a 'Doc's background dull red.+dullRedBackground :: Doc -> Doc+dullRedBackground = graphics Options { consoleIntensity = Nothing,+ underlining = Nothing,+ blinkSpeed = Nothing,+ background = Just (Red, Dull),+ foreground = Nothing,+ swapForegroundBackground = Nothing }++-- | Color a 'Doc's background dull yellow.+dullYellowBackground :: Doc -> Doc+dullYellowBackground = graphics Options { consoleIntensity = Nothing,+ underlining = Nothing,+ blinkSpeed = Nothing,+ background = Just (Yellow, Dull),+ foreground = Nothing,+ swapForegroundBackground = Nothing }++-- | Color a 'Doc's background dull green.+dullGreenBackground :: Doc -> Doc+dullGreenBackground = graphics Options { consoleIntensity = Nothing,+ underlining = Nothing,+ blinkSpeed = Nothing,+ background = Just (Green, Dull),+ foreground = Nothing,+ swapForegroundBackground = Nothing }++-- | Color a 'Doc's background dull blue.+dullBlueBackground :: Doc -> Doc+dullBlueBackground = graphics Options { consoleIntensity = Nothing,+ underlining = Nothing,+ blinkSpeed = Nothing,+ background = Just (Blue, Dull),+ foreground = Nothing,+ swapForegroundBackground = Nothing }++-- | Color a 'Doc's background dull cyan.+dullCyanBackground :: Doc -> Doc+dullCyanBackground = graphics Options { consoleIntensity = Nothing,+ underlining = Nothing,+ blinkSpeed = Nothing,+ background = Just (Cyan, Dull),+ foreground = Nothing,+ swapForegroundBackground = Nothing }++-- | Color a 'Doc's background dull magenta.+dullMagentaBackground :: Doc -> Doc+dullMagentaBackground = graphics Options { consoleIntensity = Nothing,+ underlining = Nothing,+ blinkSpeed = Nothing,+ background = Just (Magenta, Dull),+ foreground = Nothing,+ swapForegroundBackground = Nothing }++-- | Color a 'Doc's background dull black.+dullBlackBackground :: Doc -> Doc+dullBlackBackground = graphics Options { consoleIntensity = Nothing,+ underlining = Nothing,+ blinkSpeed = Nothing,+ background = Just (Black, Dull),+ foreground = Nothing,+ swapForegroundBackground = Nothing }++-- | Color a 'Doc's background vivid white.+vividWhiteBackground :: Doc -> Doc+vividWhiteBackground = graphics Options { consoleIntensity = Nothing,+ underlining = Nothing,+ blinkSpeed = Nothing,+ background = Just (White, Vivid),+ foreground = Nothing,+ swapForegroundBackground = Nothing }++-- | Color a 'Doc's background vivid red.+vividRedBackground :: Doc -> Doc+vividRedBackground = graphics Options { consoleIntensity = Nothing,+ underlining = Nothing,+ blinkSpeed = Nothing,+ background = Just (Red, Vivid),+ foreground = Nothing,+ swapForegroundBackground = Nothing }++-- | Color a 'Doc's background vivid yellow.+vividYellowBackground :: Doc -> Doc+vividYellowBackground = graphics Options { consoleIntensity = Nothing,+ underlining = Nothing,+ blinkSpeed = Nothing,+ background = Just (Yellow, Vivid),+ foreground = Nothing,+ swapForegroundBackground = Nothing }++-- | Color a 'Doc's background vivid green.+vividGreenBackground :: Doc -> Doc+vividGreenBackground = graphics Options { consoleIntensity = Nothing,+ underlining = Nothing,+ blinkSpeed = Nothing,+ background = Just (Green, Vivid),+ foreground = Nothing,+ swapForegroundBackground = Nothing }++-- | Color a 'Doc's background vivid blue.+vividBlueBackground :: Doc -> Doc+vividBlueBackground = graphics Options { consoleIntensity = Nothing,+ underlining = Nothing,+ blinkSpeed = Nothing,+ background = Just (Blue, Vivid),+ foreground = Nothing,+ swapForegroundBackground = Nothing }++-- | Color a 'Doc's background vivid cyan.+vividCyanBackground :: Doc -> Doc+vividCyanBackground = graphics Options { consoleIntensity = Nothing,+ underlining = Nothing,+ blinkSpeed = Nothing,+ background = Just (Cyan, Vivid),+ foreground = Nothing,+ swapForegroundBackground = Nothing }++-- | Color a 'Doc's background vivid magenta.+vividMagentaBackground :: Doc -> Doc+vividMagentaBackground = graphics Options { consoleIntensity = Nothing,+ underlining = Nothing,+ blinkSpeed = Nothing,+ background = Just (Magenta, Vivid),+ foreground = Nothing,+ swapForegroundBackground = Nothing }++-- | Color a 'Doc's background vivid black.+vividBlackBackground :: Doc -> Doc+vividBlackBackground = graphics Options { consoleIntensity = Nothing,+ underlining = Nothing,+ blinkSpeed = Nothing,+ background = Just (Black, Vivid),+ foreground = Nothing,+ swapForegroundBackground = Nothing }++-- | Join two 'Doc's with no space in between.+(<>) :: Doc -> Doc -> Doc+(<>) = beside++-- | Join two 'Doc's with a space in between them.+(<+>) :: Doc -> Doc -> Doc+left <+> right = left <> space <> right++-- | Join two 'Doc's with a 'line' in between them.+(<$>) :: Doc -> Doc -> Doc+left <$> right = left <> line <> right++-- | Join two 'Doc's with a 'linebreak' in between them.+(<$$>) :: Doc -> Doc -> Doc+left <$$> right = left <> linebreak <> right++-- | Join two 'Doc's with a 'softline' in between them.+(</>) :: Doc -> Doc -> Doc+left </> right = left <> softline <> right++-- | Join two 'Doc's with a 'softbreak' in between them.+(<//>) :: Doc -> Doc -> Doc+left <//> right = left <> softbreak <> right++-- | Joun 'Doc's with no space in between them.+beside :: Doc -> Doc -> Doc+beside Cat { catDocs = left } Cat { catDocs = right } =+ Cat { catDocs = left ++ right }+beside left Cat { catDocs = right } = Cat { catDocs = left : right }+beside Cat { catDocs = left } right = Cat { catDocs = left ++ [right] }+beside left right = Cat { catDocs = [left, right] }++-- | Concatenate a list of 'Doc's. This is generally more efficient+-- than repeatedly using 'beside' or '<>'.+concat :: [Doc] -> Doc+concat docs = Cat { catDocs = docs }++-- | A choice of several options. Only one of these will be chosen+-- and used to render the final document.+choose :: [Doc] -> Doc+choose [] = empty+choose [doc] = doc+choose docs = Choose { chooseOptions = docs }++-- | Concatenate a list of 'Doc's. This is generally more efficient+-- than repeatedly using 'beside' or '<>'.+hcat :: [Doc] -> Doc+hcat docs = Cat { catDocs = docs }++-- | Join a list of 'Doc's with spaces in between each. This is+-- generally more efficient than repeatedly using '<+>'.+hsep :: [Doc] -> Doc+hsep = concat . intersperse space++-- | Join a list of 'Doc's with 'line's in between each. This is+-- generally more efficient than repeatedly using '<$$>'.+vsep :: [Doc] -> Doc+vsep = concat . intersperse line++-- | Join a list of 'Doc's with 'linebreak's in between each. This is+-- generally more efficient than repeatedly using '<$>'.+vcat :: [Doc] -> Doc+vcat = concat . intersperse linebreak++-- | Join a list of 'Doc's using either 'hsep' or 'vsep'.+sep :: [Doc] -> Doc+sep docs = Choose { chooseOptions = [hsep docs, vsep docs] }++-- | Join a list of 'Doc's using either 'hcat' or 'vcat'.+cat :: [Doc] -> Doc+cat docs = Choose { chooseOptions = [hcat docs, vcat docs] }++-- | Join a list of 'Doc's with 'softline's in between each. This is+-- generally more efficient than repeatedly using '</>'.+fillSep :: [Doc] -> Doc+fillSep = concat . intersperse softline++-- | Join a list of 'Doc's with 'softbreak's in between each. This is+-- generally more efficient than repeatedly using '<//>'.+fillCat :: [Doc] -> Doc+fillCat = concat . intersperse softbreak++-- | Enclose a 'Doc' within two other 'Doc's+enclose :: Doc -> Doc -> Doc -> Doc+enclose left right middle = hcat [left, middle, right]++-- | Concatenate a list of 'Doc's into a single doc, with each element+-- separated from the others by a given 'Doc' representing+-- punctuation.+punctuate :: Doc -> [Doc] -> [Doc]+punctuate punc (first : rest @ (_ : _)) = first <> punc : punctuate punc rest+punctuate _ doc = doc++-- | Enclose a list of 'Doc's, separated by punctuation, and align+-- nesting of the contents to the end of the left enclosing 'Doc'+encloseSep :: Doc -> Doc -> Doc -> [Doc] -> Doc+encloseSep left right _ [] = left <> right+encloseSep left right _ [doc] = left <> doc <> right+encloseSep left right middle docs =+ left <> align (concat (punctuate middle docs)) <> right++-- | Render a list, enclosed in brackets and separated by commas.+list :: [Doc] -> Doc+list = group . encloseSep lbrack rbrack (comma <> line)++-- | Erase all linebreaks in a 'Doc' and replace them with either+-- spaces or nothing, depending on the kind of linebreak.+flatten :: Doc -> Doc+flatten Line { insertSpace = True } = Char { charContent = ' ' }+flatten Line { insertSpace = False } = empty+flatten Cat { catDocs = docs } = Cat { catDocs = map flatten docs }+flatten Choose { chooseOptions = docs } =+ Choose { chooseOptions = map flatten docs }+flatten n @ Nest { nestDoc = inner } = n { nestDoc = flatten inner }+flatten doc = doc++-- | A 'Doc' that 'choose's between the unmodified argument, or the+-- 'flatten'ed version of the argument.+group :: Doc -> Doc+group doc = Choose { chooseOptions = [ doc, flatten doc ] }++-- | Produce a 'Builder' that renders the 'Doc' to one line.+buildOneLine :: Doc -> Builder+buildOneLine Char { charContent = chr } = fromChar chr+buildOneLine Builder { builderContent = builder } = builder+buildOneLine Line { insertSpace = True } = fromChar ' '+buildOneLine Line { insertSpace = False } = mempty+buildOneLine Cat { catDocs = docs } = mconcat (map buildOneLine docs)+buildOneLine Nest { nestDoc = inner } = buildOneLine inner+buildOneLine Choose { chooseOptions = first : _ } = buildOneLine first+buildOneLine Choose {} = error "Choose with no options"+buildOneLine Graphics { graphicsDoc = inner } = buildOneLine inner++-- | Render the entire 'Doc' to one line. Good for output that+-- will be read only by a machine, where newlines are not important at all+renderOneLine :: Doc -> Lazy.ByteString+renderOneLine = toLazyByteString . buildOneLine++-- | Output the entire 'Doc', as rendered by 'renderOneLine' to the+-- given 'Handle'.+putOneLine :: Handle -> Doc -> IO ()+putOneLine handle =+ toByteStringIO (Strict.hPut handle) . buildOneLine++-- | Produce a 'Builder' that renders the 'Doc' quickly.+buildFast :: Doc -> Builder+buildFast Char { charContent = chr } = fromChar chr+buildFast Builder { builderContent = builder } = builder+buildFast Line {} = fromChar '\n'+buildFast Cat { catDocs = docs } = mconcat (map buildFast docs)+buildFast Nest { nestDoc = inner } = buildFast inner+buildFast Choose { chooseOptions = first : _ } = buildFast first+buildFast Choose {} = error "Choose with no options"+buildFast Graphics { graphicsDoc = inner } = buildFast inner++-- | Render the entire 'Doc', preserving newlines, but without any+-- indentation. Good for output that will be read only by machine,+-- but where newlines matter.+renderFast :: Doc -> Lazy.ByteString+renderFast = toLazyByteString . buildFast++-- | Output the entire 'Doc', as rendered by 'renderFast' to the+-- given 'Handle'.+putFast :: Handle -> Doc -> IO ()+putFast handle =+ toByteStringIO (Strict.hPut handle) . buildFast++-- | A rendering of a document.++-- Renderings store three basic things: A notion of the "badness" of+-- this particular rendering (represented by the overrun and the+-- number of lines), the indentation mode for the next document, and a+-- function that actually produces the Builder.+data Render =+ Render {+ -- | The number of lines in the document.+ renderLines :: !Word,+ -- | The largest amount by which we've overrun.+ renderOverrun :: !Column,+ -- | A builder that constructs the document.+ renderBuilder :: !(Int -> Int -> Builder),+ -- | Indentation mode for the next document.+ renderIndent :: !Indent+ }++-- | Column data type. Represents how rendered documents affect the+-- current column.++-- Columns can be fixed, relative, or the maximum of the two. Fixed+-- means "this colucm exactly". Relative means "some starting point+-- plus this number".+data Column =+ -- | An absolute column offset.+ Fixed { fixedOffset :: !Int }+ -- | A relative column offset.+ | Relative { relOffset :: !Int }+ -- | The greater of a relative column offset and an absolute+ -- column offset.+ | Maximum {+ -- | This many columns offset from a relative point.+ maxRelative :: !Int,+ -- | But not less than this value.+ maxFixed :: !Int+ }+ deriving Show++-- | The indentation mode.+data Indent =+ -- | Indent starting with the zero column.+ Full+ -- | Indent starting with the current column.+ | Partial+ -- | No indent.+ | None+ deriving Show++instance Hashable Column where+ hashWithSalt s Fixed { fixedOffset = n } =+ s `hashWithSalt` (0 :: Int) `hashWithSalt` n+ hashWithSalt s Relative { relOffset = n } =+ s `hashWithSalt` (1 :: Int) `hashWithSalt` n+ hashWithSalt s Maximum { maxFixed = fixed, maxRelative = rel } =+ s `hashWithSalt` (2 :: Int) `hashWithSalt` fixed `hashWithSalt` rel++instance Ord Column where+ compare Fixed { fixedOffset = n1 } Fixed { fixedOffset = n2 } = compare n1 n2+ compare Fixed { fixedOffset = n }+ Maximum { maxFixed = fixed, maxRelative = rel } =+ case compare n fixed of+ EQ -> case compare n rel of+ EQ -> LT+ out -> out+ out -> out+ compare Fixed { fixedOffset = n1 } Relative { relOffset = n2 } =+ case compare n1 n2 of+ EQ -> LT+ out -> out+ compare Maximum { maxFixed = fixed, maxRelative = rel }+ Fixed { fixedOffset = n } =+ case compare fixed n of+ EQ -> case compare rel n of+ EQ -> GT+ out -> out+ out -> out+ compare Maximum { maxFixed = fixed1, maxRelative = rel1 }+ Maximum { maxFixed = fixed2, maxRelative = rel2 } =+ case compare fixed1 fixed2 of+ EQ -> compare rel1 rel2+ out -> out+ compare Maximum { maxFixed = fixed, maxRelative = rel }+ Relative { relOffset = n } =+ case compare rel n of+ EQ -> case compare fixed n of+ EQ -> GT+ out -> out+ out -> out+ compare Relative { relOffset = n1 } Fixed { fixedOffset = n2 } =+ case compare n1 n2 of+ EQ -> GT+ out -> out+ compare Relative { relOffset = n }+ Maximum { maxFixed = fixed, maxRelative = rel } =+ case compare n rel of+ EQ -> case compare n fixed of+ EQ -> LT+ out -> out+ out -> out+ compare Relative { relOffset = n1 } Relative { relOffset = n2 } =+ compare n1 n2++instance Eq Column where+ c1 == c2 = compare c1 c2 == EQ++-- | Given a starting column and an ending column, give a column+-- representing the combination of the two.+advance :: Column -> Column -> Column+-- If the second column is fixed, it doesn't matter what the first is.+advance _ f @ Fixed {} = f+-- If the first is fixed and the second is relative, then advance the+-- first by the relative offset.+advance Fixed { fixedOffset = start } Relative { relOffset = n } =+ Fixed { fixedOffset = start + n }+-- If the first is fixed and the second is a maximum, then we can+-- figure out which is the larger.+advance Fixed { fixedOffset = start }+ Maximum { maxFixed = fixed, maxRelative = rel } =+ Fixed { fixedOffset = max fixed (start + rel) }+-- If both are relative, just add them and make a new relative.+advance Relative { relOffset = start } Relative { relOffset = n } =+ Relative { relOffset = start + n }+-- If we combine a relative and a maximum, then add the relative+-- offset to the relative portion of the maximum+advance Relative { relOffset = start } m @ Maximum { maxRelative = n } =+ m { maxRelative = start + n }+advance m @ Maximum { maxRelative = rel } Relative { relOffset = n } =+ m { maxRelative = rel + n }+-- If both are a maximum, then the resulting relative portion is the+-- sum of the two relative portions. The resulting fixed portion is+-- the greater of the second fixed portion, or the first fixed portion+-- plus the second relative portion.+advance Maximum { maxFixed = fixed1, maxRelative = rel1 }+ Maximum { maxFixed = fixed2, maxRelative = rel2 } =+ Maximum { maxFixed = max fixed2 (fixed1 + rel2), maxRelative = rel1 + rel2 }++-- | Offsets structure. this is used as a key in a hash table. It is+-- also important to how the algorithm works. Renderings represent+-- "chunks", which have an ending column and a maximum column. The+-- algorithm glues these chunks together, then evaluates their+-- "badness" using the 'advance' function to recalculate the ending+-- column and the maximum starting offset.+data Offsets =+ Offsets {+ -- | Upper-bound: Highest starting column for this document+ -- without causing overrun. If this is negative, it means you've+ -- overrun by that much.+ offsetUpper :: !Int,+ -- | Ending column.+ offsetCol :: !Column+ }+ deriving Eq++instance Hashable Offsets where+ hashWithSalt s Offsets { offsetUpper = upper, offsetCol = col } =+ s `hashWithSalt` upper `hashWithSalt` col++-- | A result. This is split into 'Single' and 'Multi' in order to+-- optimize for the common case of a single possible rendering.+-- Otherwise, it would be perfectly fine to represent everything as a+-- HashMap.+data Result =+ -- | A single possible rendering.+ Single {+ -- | The rendered document.+ singleRender :: !Render,+ -- | The first column at which this render causes an overrun.+ -- Same as 'offsetUpper'.+ singleUpper :: !Int,+ -- | The current column at the end of rendering.+ singleCol :: !Column+ }+ -- | Multiple possible renderings.+ | Multi {+ -- | A multi-level map. The first map is indexed by the column+ -- upper-bound (meaning the first column at which using any of+ -- the contents will cause an overrun). The second map is+ -- indexed by the ending column.+ multiOptions :: !(HashMap Offsets Render)+ }++-- | Generate n spaces+makespaces :: Int -> Builder+makespaces n = fromLazyByteString (Lazy.Char8.replicate (fromIntegral n) ' ')++-- | Pick the best rendering of two.+bestRender :: Render -> Render -> Render+bestRender r1 @ Render { renderLines = lines1, renderOverrun = overrun1 }+ r2 @ Render { renderLines = lines2, renderOverrun = overrun2 }+ -- If one overruns less than the other, pick that one.+ | overrun1 < overrun2 = r1+ | overrun1 > overrun2 = r2+ -- Otherwise, pick the shortest one.+ | otherwise = if lines1 < lines2 then r1 else r2++-- Add a result into the HashMap+insertRender :: Int -> Column -> Render -> HashMap Offsets Render ->+ HashMap Offsets Render+insertRender upper col render =+ let+ offsets = Offsets { offsetUpper = upper, offsetCol = col }+ in+ HashMap.insertWith bestRender offsets render++-- If a result only has one possibility, convert it to a Single.+-- Otherwise, leave it.+packResult :: HashMap Offsets Render -> Result+packResult opts =+ case HashMap.toList opts of+ [(Offsets { offsetUpper = upper, offsetCol = col }, render)] ->+ Single { singleCol = col, singleUpper = upper, singleRender = render }+ _ -> Multi { multiOptions = opts }++-- Pick the best result out of a set of results. Used at the end to+-- pick the final result.+bestRenderInOpts :: HashMap Offsets Render -> Render+bestRenderInOpts =+ let+ -- | Compare two Renders. Less than means better.+ compareRenders Render { renderLines = lines1, renderOverrun = overrun1 }+ Render { renderLines = lines2, renderOverrun = overrun2 } =+ -- This is the same logic as bestRender+ case compare overrun1 overrun2 of+ EQ -> compare lines1 lines2+ out -> out+ in+ minimumBy compareRenders . HashMap.elems++-- | Append operation on complete states. A complete state is the+-- contents of an Offset and a Render (ie. the contents of Single, or+-- the contents of an entry in a Multi combined with the corresponding+-- key).+appendOne :: (Int, Column, Render) -> (Int, Column, Render) ->+ (Int, Column, Render)+appendOne (upper1, col1, Render { renderBuilder = build1,+ renderLines = lines1,+ renderOverrun = overrun1 })+ (upper2, col2, Render { renderBuilder = build2,+ renderLines = lines2,+ renderOverrun = overrun2,+ renderIndent = ind }) =+ let+ -- The new build is completely determined by the first render's+ -- starting column.+ newbuild = case col1 of+ -- If the first ending column is fixed, then start the second+ -- builder at that column.+ Fixed { fixedOffset = n } ->+ \nesting col -> build1 nesting col `mappend` build2 nesting n+ -- If the first ending column is relative, then advance the+ -- column by that much and start the second builder at that+ -- column.+ Relative { relOffset = n } ->+ \nesting col -> build1 nesting col `mappend` (build2 nesting $! col + n)+ -- If the ending column is a maximum+ Maximum { maxRelative = rel, maxFixed = fixed } ->+ \nesting col -> build1 nesting col `mappend`+ build2 nesting (max fixed (col + rel))++ -- The new upper-bound is determined by both ending columns.+ --+ -- IMPORTANT: In this logic, a negative upper-bound means you+ -- overrun by that much. This is critical to the functioning of+ -- this logic.+ newupper = case (col1, col2) of+ -- If the second column is fixed, then the upper-bound is the+ -- minimum of the two upper-bounds.+ (_, Fixed {}) -> min upper1 upper2+ -- Otherwise, we decrement the second upper-bound and take the+ -- minimum with the first.+ (Fixed { fixedOffset = n }, _) -> min upper1 (upper2 - n)+ (Relative { relOffset = n }, _) -> min upper1 (upper2 - n)+ -- For maximum, take the minimum over the first upper-bound, the+ -- second decremented by the fixed portion, and the second+ -- decremented by the relative portion.+ (Maximum { maxFixed = fixed, maxRelative = rel }, _) ->+ min upper1 (min (upper2 - fixed) (upper2 - rel))++ -- If the new upper bound is negative, the overrun is its absolute value+ newoverrun =+ if newupper < 0+ then Relative { relOffset = abs newupper }+ else Fixed { fixedOffset = 0 }++ in+ -- For the new column, use advance+ (newupper, col1 `advance` col2,+ Render { renderBuilder = newbuild, renderIndent = ind,+ -- For the new overrun, take the max of the existing+ -- overruns and newoverrun+ renderOverrun = max (max overrun1 overrun2) newoverrun,+ renderLines = lines1 + lines2 })++-- | Combine two results into a Multi. This achieves the same result+-- as HashMap.unionWith bestRender (meaning, union these maps,+-- combining using bestRender to pick when both maps have a given+-- index), but handles Singles as well.+mergeResults :: Result -> Result -> Result+-- Single is equivalent to a single-entry HashMap+mergeResults s1 @ Single { singleRender =+ r1 @ Render { renderOverrun = overrun1,+ renderLines = lines1 },+ singleUpper = upper1, singleCol = col1 }+ s2 @ Single { singleRender =+ r2 @ Render { renderOverrun = overrun2,+ renderLines = lines2 },+ singleUpper = upper2, singleCol = col2 }+ -- If the keys would collide+ | upper1 == upper2 && col1 == col2 =+ -- Duplicate the functionality of bestRender+ if overrun1 < overrun2+ then s1+ else if overrun1 > overrun2+ then s2+ else if lines1 < lines2+ then s1+ else s2+ -- Otherwise, create a Multi+ | otherwise =+ Multi { multiOptions =+ HashMap.fromList [(Offsets { offsetUpper = upper1,+ offsetCol = col1 },+ r1),+ (Offsets { offsetUpper = upper2,+ offsetCol = col2 },+ r2)] }+mergeResults Single { singleRender = render, singleUpper = upper,+ singleCol = col }+ Multi { multiOptions = opts } =+ -- Do an insertWith bestRender+ let+ offsets = Offsets { offsetUpper = upper, offsetCol = col }+ in+ Multi { multiOptions = HashMap.insertWith bestRender offsets render opts }+-- This operation is commutative+mergeResults m @ Multi {} s @ Single {} = mergeResults s m+-- Otherwise it's a straightaway HashMap union+mergeResults Multi { multiOptions = opts1 } Multi { multiOptions = opts2 } =+ Multi { multiOptions = HashMap.unionWith bestRender opts1 opts2 }++-- Add indentation on to a builder. Note, this is used to create the+-- builder functions used in Render.+contentBuilder :: Indent -> Builder -> Int -> Int -> Builder+-- For full indentation, glue on the full indent+contentBuilder Full builder nesting _ =+ makespaces nesting `mappend` builder+-- For partial indentation, bring us up to the current indent level+contentBuilder Partial builder nesting col =+ if col < nesting+ then makespaces (nesting - col) `mappend` builder+ else builder+-- Otherwise, do nothing.+contentBuilder None builder _ _ = builder++-- | Produce a 'Builder' that renders the 'Doc' using the optimal+-- layout engine.++-- Basic algorithm overview: each Doc is rendering into a Result,+-- which has an upper-bound (the last column at which we can start+-- without causing an overrun), an ending column (which may be a+-- relative or fixed position), and the actual render, which has a+-- "badness". A negative upper-bound value indicates overrun.+--+-- We keep only ONE result for each upper-bound, start column pair+-- (ie. the best one). This forms the "frontier" for the dynamic+-- programming algorithm.+--+-- Note that due to the complexity of the combinators, we CAN see+-- cubic time/space complexity. However, actual running times are+-- much lower, especially for Docs that contain many hard linebreaks+-- and few Options.+buildOptimal :: Int+ -- ^ The maximum number of columns.+ -> Bool+ -- ^ Whether or not to render with ANSI terminal options.+ -> Doc+ -- ^ The document to render.+ -> Builder+buildOptimal maxcol ansiterm doc =+ let+ buildDynamic :: Graphics -> Column -> Indent -> Doc -> Result+ -- For char, bytestring, and lazy bytestring,+ buildDynamic _ _ ind Char { charContent = chr } =+ let+ -- Why would you have maxcol == 0? Who knows, but check for it.+ overrun = if maxcol >= 1 then Relative 0 else Relative (maxcol - 1)+ builder = contentBuilder ind (fromChar chr)+ in+ -- Single characters have a single possibility, a relative+ -- ending position one beyond the start, and an upper-bound+ -- one shorter than the maximum width.+ Single {+ singleRender =+ Render { renderLines = 0, renderOverrun = overrun,+ renderBuilder = builder, renderIndent = None },+ singleCol = Relative 1, singleUpper = maxcol - 1+ }+ buildDynamic _ _ ind Builder { builderContent = txt, builderLength = len } =+ let+ -- Why would you have maxcol == 0? Who knows, but check for it.+ overrun = if maxcol >= len then Relative 0 else Relative (len - maxcol)+ builder = contentBuilder ind txt+ in+ -- Text has a single possibility and a relative ending position+ -- equal to its length+ Single {+ singleRender = Render { renderLines = 0, renderOverrun = overrun,+ renderBuilder = builder, renderIndent = None },+ singleCol = Relative len, singleUpper = maxcol - len+ }+ buildDynamic _ nesting _ Line {} =+ -- A newline starts at the nesting level, has no overrun, and an+ -- upper-bound equal to the maximum column width.+ --+ -- Note: the upper bound is adjusted elsewhere.+ Single {+ singleRender = Render { renderOverrun = Fixed { fixedOffset = 0 },+ renderIndent = Full, renderLines = 1,+ renderBuilder = const $! const $!+ fromChar '\n' },+ singleCol = nesting, singleUpper = maxcol+ }+ -- This is for an empty cat, ie. the empty document+ buildDynamic _ _ ind Cat { catDocs = [] } =+ -- The empty document has no content, no overrun, a relative end+ -- position of 0, and an upper-bound of maxcol.+ Single {+ singleRender = Render { renderOverrun = Fixed { fixedOffset = 0 },+ renderIndent = ind, renderLines = 0,+ renderBuilder = const mempty },+ singleCol = Relative { relOffset = 0 }, singleUpper = maxcol+ }+ buildDynamic sgr nesting ind Cat { catDocs = first : rest } =+ let+ -- Glue two Results together. This gets used in a fold.+ appendResults :: Result -> Doc -> Result+ -- The accumulated result is a Single.+ appendResults Single { singleRender =+ render1 @ Render { renderIndent = ind' },+ singleUpper = upper1, singleCol = col1 } doc' =+ -- Render the document.+ case buildDynamic sgr nesting ind' doc' of+ -- If there's a single result, it's easy; just use appendOne.+ Single { singleUpper = upper2, singleCol = col2,+ singleRender = render2 } ->+ let+ (newupper, newcol, newrender) =+ appendOne (upper1, col1, render1) (upper2, col2, render2)+ in+ Single { singleUpper = newupper, singleCol = newcol,+ singleRender = newrender }+ -- Otherwise, we have to fold over all the options and+ -- glue on the accumulated result.+ Multi { multiOptions = opts } ->+ let+ -- Level 2 fold function: glue the accumulated result+ -- on to an option.+ foldfun :: HashMap Offsets Render -> Offsets -> Render ->+ HashMap Offsets Render+ foldfun accum Offsets { offsetUpper = upper2,+ offsetCol = col2 } render2 =+ let+ (newupper, newcol, newrender) =+ appendOne (upper1, col1, render1) (upper2, col2, render2)+ in+ insertRender newupper newcol newrender accum+ in+ -- Fold it up, then use packResult.+ packResult (HashMap.foldlWithKey' foldfun HashMap.empty opts)+ -- If the accumulate result is a multi, then we'll need to+ -- glue the next render on to each option.+ appendResults Multi { multiOptions = opts } doc' =+ let+ -- Outer fold, over each option in the accumulated result,+ -- gluing on the next render.+ outerfold :: HashMap Offsets Render -> Offsets -> Render ->+ HashMap Offsets Render+ outerfold accum Offsets { offsetUpper = upper1,+ offsetCol = col1 }+ render1 @ Render { renderIndent = ind' } =+ case buildDynamic sgr nesting ind' doc' of+ -- If the render is a single result, then just glue it+ -- on to the current option.+ Single { singleUpper = upper2, singleCol = col2,+ singleRender = render2 } ->+ let+ (newupper, newcol, newrender) =+ appendOne (upper1, col1, render1) (upper2, col2, render2)+ in+ insertRender newupper newcol newrender accum+ -- If the render result is ALSO a Multi, then we need+ -- to do another level of fold to glue those options+ -- on to the current one.+ Multi { multiOptions = opts2 } ->+ let+ -- Innermost fold, glues two options together+ innerfold :: HashMap Offsets Render -> Offsets -> Render ->+ HashMap Offsets Render+ innerfold accum' Offsets { offsetUpper = upper2,+ offsetCol = col2 } render2 =+ let+ (newupper, newcol, newrender) =+ appendOne (upper1, col1, render1)+ (upper2, col2, render2)+ in+ insertRender newupper newcol newrender accum'+ in+ -- Don't bother calling packResult here, we'll do+ -- it at the end anyway.+ HashMap.foldlWithKey' innerfold accum opts2+ in+ -- Fold it up, then use packResult.+ packResult (HashMap.foldlWithKey' outerfold HashMap.empty opts)++ -- Build the first item+ firstres = buildDynamic sgr nesting ind first+ in+ -- Fold them all together with appendResults+ foldl appendResults firstres rest+ buildDynamic sgr nesting ind Nest { nestDelay = delay, nestDoc = inner,+ nestAlign = alignnest,+ nestLevel = lvl } =+ let+ -- Wrap up the render functions in code that alters the+ -- nesting and column numbers.+ updateRender =+ if alignnest+ -- If we're relative to the current column, then make the+ -- new nesting equal to the current column, plus an+ -- offset.+ then \r @ Render { renderBuilder = builder } ->+ r { renderBuilder = \_ c -> builder (c + lvl) c }+ -- Otherwise, make it relative to the current nesting level.+ else \r @ Render { renderBuilder = builder } ->+ r { renderBuilder = \n c -> builder (n + lvl) c }++ -- If we delay the indentation, don't alter the indent mode,+ -- otherwise, set it.+ newindent = if delay then ind else Partial++ res =+ if alignnest+ -- If we're aligning to the current column, the nesting+ -- becomes a relative offset.+ then buildDynamic sgr (Relative lvl) newindent inner+ -- Otherwise, we have to update the nesting level.+ else+ let+ -- Basically, increment everything by the nesting level.+ newnesting = case nesting of+ Fixed { fixedOffset = n } -> Fixed { fixedOffset = n + lvl }+ Relative { relOffset = n } -> Relative { relOffset = n + lvl }+ Maximum { maxFixed = fixed, maxRelative = rel } ->+ Maximum { maxFixed = fixed + lvl, maxRelative = rel + lvl }+ in+ buildDynamic sgr newnesting newindent inner+ in case res of+ -- Update the render for a Single.+ s @ Single { singleRender = r } -> s { singleRender = updateRender r }+ -- Update all renders for a Multi.+ m @ Multi { multiOptions = opts } ->+ m { multiOptions = HashMap.map updateRender opts }+ buildDynamic sgr nesting ind Choose { chooseOptions = options } =+ let+ -- Build up all the components+ results = map (buildDynamic sgr nesting ind) options+ in+ -- Now merge them into an minimal set of options+ foldl1 mergeResults results+ buildDynamic sgr1 nesting ind Graphics { graphicsSGR = sgr2,+ graphicsDoc = inner }+ -- Only do graphics if the ansiterm flag is set.+ | ansiterm =+ let+ -- Insert graphics control characters without updating+ -- column numbers, as they aren't visible.+ wrapBuilder r @ Render { renderBuilder = build } =+ r { renderBuilder = \n c -> switchGraphics sgr1 sgr2 `mappend`+ build n c `mappend`+ switchGraphics sgr2 sgr1 }+ in case buildDynamic sgr2 nesting ind inner of+ s @ Single { singleRender = render } ->+ s { singleRender = wrapBuilder render }+ m @ Multi { multiOptions = opts } ->+ m { multiOptions = HashMap.map wrapBuilder opts }+ -- Otherwise, skip it entirely+ | otherwise = buildDynamic sgr2 nesting ind inner++ -- Call buildDynamic, get the result, then pick the best one.+ Render { renderBuilder = result } =+ case buildDynamic Default Fixed { fixedOffset = 0 } None doc of+ Single { singleRender = render } -> render+ Multi opts -> bestRenderInOpts opts+ in+ result 0 0++-- | Render a 'Doc' as a lazy bytestring using an optimal layout+-- rendering engine. The engine will render the document in the+-- fewest number of lines possible without exceeding the maximum+-- column width.+renderOptimal :: Int+ -- ^ The maximum number of columns.+ -> Bool+ -- ^ Whether or not to render with ANSI terminal options.+ -> Doc+ -- ^ The document to render.+ -> Lazy.ByteString+renderOptimal cols color = toLazyByteString . buildOptimal cols color++-- | Output the entire 'Doc', as rendered by 'renderOptimal' to the+-- given 'Handle'.+putOptimal :: Handle+ -- ^ The 'Handle' to which to write output+ -> Int+ -- ^ The maximum number of columns.+ -> Bool+ -- ^ Whether or not to render with ANSI terminal options.+ -> Doc+ -- ^ The document to render.+ -> IO ()+putOptimal handle cols color =+ toByteStringIO (Strict.hPut handle) . buildOptimal cols color++-- | A class representing datatypes that can be formatted as 'Doc's.+class Format item where+ -- | Format an @item@ as a 'Doc'+ format :: item -> Doc++ -- | Format a list of @item@s as a 'Doc'+ formatList :: [item] -> Doc+ formatList = list . map format++-- | A class representing datatypes that can be formatted as 'Doc's+-- inside a monad.+class Monad m => FormatM m item where+ -- | Format an @item@ as a 'Doc' inside an @m@ monad+ formatM :: item -> m Doc++ -- | Format a list of @item@s as a 'Doc' inside an @m@ monad+ formatListM :: [item] -> m Doc+ formatListM = liftM list . mapM formatM++instance Format a => Format [a] where+ format = formatList++instance Format Doc where+ format = id++instance Format String where+ format = string++instance Format Strict.ByteString where+ format = bytestring++instance Format Lazy.ByteString where+ format = lazyBytestring++instance Format Int where+ format = string . show++instance Format Integer where+ format = string . show++instance Format Word where+ format = string . show++instance Format Float where+ format = string . show++instance Format Double where+ format = string . show
+ test/UnitTest.hs view
@@ -0,0 +1,43 @@+-- Copyright (c) 2014 Eric McCorkle. All rights reserved.+--+-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions+-- are met:+--+-- 1. Redistributions of source code must retain the above copyright+-- notice, this list of conditions and the following disclaimer.+--+-- 2. Redistributions in binary form must reproduce the above copyright+-- notice, this list of conditions and the following disclaimer in the+-- documentation and/or other materials provided with the distribution.+--+-- 3. Neither the name of the author nor the names of any contributors+-- may be used to endorse or promote products derived from this software+-- without specific prior written permission.+--+-- THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS ``AS IS''+-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED+-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A+-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS+-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+-- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+-- LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF+-- USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND+-- ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT+-- OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+-- SUCH DAMAGE.++module Main(main) where++import Test.HUnitPlus++import qualified Tests.Text as Text++tests = [ Text.tests ]++testsuite = TestSuite { suiteName = "UnitTests", suiteConcurrently = True,+ suiteTests = tests, suiteOptions = [] }++main :: IO ()+main = createMain [testsuite]