{-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- -- | -- Module : Text.PrettyPrint.JoinPrint.Core -- Copyright : (c) Stephen Tetley 2009-2010 -- License : BSD3 -- -- Maintainer : Stephen Tetley -- Stability : highly unstable -- Portability : to be determined. -- -- Printing with /join-strings/. -- -------------------------------------------------------------------------------- module Text.PrettyPrint.JoinPrint.Core ( Doc , VDoc , empty , null , length -- * Compose Docs , (<>) , (<+>) , hcat , hsep -- * Compose VDocs , vcat , vsep , vcons , vsnoc , vconcat , vconcatSep -- * Primitive Docs , text , char , int , integer , integral , float , double , sglspace , dblspace , comma , semicolon , punctuate , enclose , squotes , dquotes , parens , brackets , braces , angles , lparen , rparen , lbracket , rbracket , lbrace , rbrace , langle , rangle , replicateChar , spacer -- * Padding and truncation , padl , padr , truncl , truncr -- * Output , render , renderIO ) where import Text.PrettyPrint.JoinPrint.JoinString ( JoinString, (++) ) import qualified Text.PrettyPrint.JoinPrint.JoinString as JS import Data.List ( foldl' ) import Data.Monoid import Prelude hiding ( (++), null, length ) -- | Doc is the abstract data type respresenting single line -- documents. -- -- JoinPrint ditinguishes between single-line and multi-line -- documents. Single-line, horizontal documents support some -- operations not multi-line documents, e.g. padding, see 'padl' -- and 'padr' and truncating 'truncl' and 'truncr'. -- newtype Doc = Doc { getDoc :: JoinString } -- | VDoc is the abstract data type respresenting multi-line -- documents. -- -- Multi-line documents have a limited set of operations -- (basically concatenation with or without a blank line -- inbetween) compared to single line docs which support e.g. -- padding and truncating. -- newtype VDoc = VDoc { getVDoc :: ShowS } -------------------------------------------------------------------------------- instance Show Doc where show = render instance Show VDoc where show = renderV instance Monoid Doc where mempty = empty mappend = (<>) instance Monoid VDoc where mempty = VDoc id (VDoc f) `mappend` (VDoc g) = VDoc (f . showChar '\n' . g) -------------------------------------------------------------------------------- infixr 6 <>, <+> -- | Create an empty, zero length document. -- empty :: Doc empty = Doc $ JS.empty -- | Test if the doc is empty. -- null :: Doc -> Bool null = JS.null . getDoc -- | Get the length of the Doc. -- -- Length is cached in the document\'s data type so this -- operation is O(1). -- length :: Doc -> Int length = JS.length . getDoc -- | Horizontally concatenate two documents with no space -- between them. -- (<>) :: Doc -> Doc -> Doc Doc a <> Doc b = Doc $ a ++ b -- | Horizontally concatenate two documents with a single space -- between them. -- (<+>) :: Doc -> Doc -> Doc Doc a <+> Doc b = Doc (a ++ JS.cons1 ' ' b) -- | Horizontally concatenate a list of documents with @(\<\>)@. -- hcat :: [Doc] -> Doc hcat = foldr (<>) empty -- | Horizontally concatenate a list of documents with @(\<+\>)@. -- hsep :: [Doc] -> Doc hsep = foldr (<+>) empty -- Vertically concatenation is different to PPrint or Hughes-PJ. -- Because the Doc type tracks (horizontal) length, vertically -- concat cannot use the same type as there is no reasonable -- horizontal length (max length, length of first, length of -- last?) -- -- | Vertically concatenate a list of documents, one doc per -- line. -- -- Note - this function produces a 'VDoc' rather than a 'Doc'. -- vcat :: [Doc] -> VDoc vcat [] = VDoc id vcat [a] = VDoc (renderS a) vcat (a:as) = VDoc $ foldl' fn (renderS a) as where fn f d = f . showChar '\n' . renderS d -- | Vertically concatenate a list of documents, one doc per -- line with a blank line inbetween. -- -- Note - this function produces a 'VDoc' rather than a 'Doc'. -- vsep :: [Doc] -> VDoc vsep [] = VDoc id vsep [a] = VDoc (renderS a) vsep (a:as) = VDoc $ foldl' fn (renderS a) as where fn f d = f . showString "\n\n" . renderS d -- | Prefix the 'Doc' to the start of the 'VDoc'. -- vcons :: Doc -> VDoc -> VDoc vcons d (VDoc f) = VDoc (renderS d . showChar '\n' . f) -- | Suffix the 'VDoc' with the 'Doc'. -- vsnoc :: VDoc -> Doc -> VDoc vsnoc (VDoc f) d = VDoc (f . showChar '\n' . renderS d) -- | Concatenate a list of 'VDoc'. -- vconcat :: [VDoc] -> VDoc vconcat [] = VDoc id vconcat [a] = a vconcat (VDoc a:as) = VDoc (a . showChar '\n' . getVDoc (vconcat as)) -- | Concatenate a list of 'VDoc' with a blank line separating -- them. -- vconcatSep :: [VDoc] -> VDoc vconcatSep [] = VDoc id vconcatSep [a] = a vconcatSep (VDoc a:as) = VDoc (a . showString "\n\n" . getVDoc (vconcatSep as)) -- | Create a document from a literal string. -- -- The string should not contain tabs or newlines (though this -- is not enforced). To allow padding and truncating the -- horizontal width of a 'Doc' is cached in the datatype, -- building a Doc containing tabs or newlines leads to -- unspecified behaviour. -- text :: String -> Doc text = Doc . (JS.text) -- | Create a document from a literal character. -- -- The char should not be a tab or newline. See 'text' for the -- rational. -- char :: Char -> Doc char = Doc . (JS.text) . return -- | Show the Int as a Doc. -- -- > int = text . show -- int :: Int -> Doc int = text . show -- | Show the Integer as a Doc. -- integer :: Integer -> Doc integer = text . show -- | Show an \"integral value\" as a Doc via 'fromIntegral'. -- integral :: Integral a => a -> Doc integral = integer . fromIntegral -- | Show the Float as a Doc. -- float :: Double -> Doc float = text . show -- | Show the Double as a Doc. -- double :: Double -> Doc double = text . show -- | Create a Doc containing a single space character. -- sglspace :: Doc sglspace = char ' ' -- | Create a Doc containing a two-space characters. -- dblspace :: Doc dblspace = text " " -- | Create a Doc containing a comma, \",\". -- comma :: Doc comma = char ',' -- | Create a Doc containing a semi colon, \";\". -- semicolon :: Doc semicolon = char ';' -------------------------------------------------------------------------------- -- | Punctuate the Doc list with the separator, producing a Doc. -- punctuate :: Doc -> [Doc] -> Doc punctuate _ [] = empty punctuate _ [x] = x punctuate s (x:xs) = x <> s <> punctuate s xs -- | Enclose the final Doc within the first two. -- -- There are no spaces between the documents: -- -- > enclose l r d = l <> d <> r -- enclose :: Doc -> Doc -> Doc -> Doc enclose l r d = l <> d <> r -- | Enclose the Doc within single quotes. -- squotes :: Doc -> Doc squotes = enclose (char '\'') (char '\'') -- | Enclose the Doc within double quotes. -- dquotes :: Doc -> Doc dquotes = enclose (char '"') (char '"') -- | Enclose the Doc within parens @()@. -- parens :: Doc -> Doc parens = enclose lparen rparen -- | Enclose the Doc within square brackets @[]@. -- brackets :: Doc -> Doc brackets = enclose lbracket rbracket -- | Enclose the Doc within curly braces @{}@. -- braces :: Doc -> Doc braces = enclose lbrace rbrace -- | Enclose the Doc within angle brackets @\<\>@. -- angles :: Doc -> Doc angles = enclose langle rangle -- | Create a Doc containing a left paren, \'(\'. -- lparen :: Doc lparen = char '(' -- | Create a Doc containing a right paren, \')\'. -- rparen :: Doc rparen = char ')' -- | Create a Doc containing a left square bracket, \'[\'. -- lbracket :: Doc lbracket = char '[' -- | Create a Doc containing a right square bracket, \']\'. -- rbracket :: Doc rbracket = char ']' -- | Create a Doc containing a left curly brace, \'{\'. -- lbrace :: Doc lbrace = char '{' -- | Create a Doc containing a right curly brace, \'}\'. -- rbrace :: Doc rbrace = char '}' -- | Create a Doc containing a left angle bracket, \'\<\'. -- langle :: Doc langle = char '<' -- | Create a Doc containing a right angle bracket, \'\>\'. -- rangle :: Doc rangle = char '>' -------------------------------------------------------------------------------- -- | 'replicateChar' : @ n * ch -> Doc@ -- -- Repeat the supplied char (@ch@), @n@ times. -- replicateChar :: Int -> Char -> Doc replicateChar i = Doc . (JS.text) . replicate i -- | Create a list of space characters of length @n@. -- spacer :: Int -> Doc spacer = replicateChar `flip` ' ' -- | 'padl' : @ width * ch * doc -> Doc @ -- -- Pad the supplied Doc to fit @width@ using the char @ch@. -- Padding is performed at the left, right-justifying the Doc. -- -- If the doc is already wider than supplied width it is returned -- as-is (no truncation takes place). -- padl :: Int -> Char -> Doc -> Doc padl i c d = step (length d) where step dl | dl >= i = d | otherwise = replicateChar (i-dl) c <> d -- | 'padr' : @ width * ch * doc -> Doc @ -- -- Pad the supplied Doc to fit @width@ using the char @ch@. -- Padding is performed at the right, left-justifying the Doc. -- -- If the doc is already wider than supplied width it is returned -- as-is (no truncation takes place). -- padr :: Int -> Char -> Doc -> Doc padr i c d = step (length d) where step dl | dl >= i = d | otherwise = d <> replicateChar (i-dl) c -- | 'truncl' : @width * doc -> Doc@ -- -- Truncate a doc to the supplied @width@. Characters are dropped -- from the left until the document fits. If the document is -- shorter than the supplied width it is returned as is (no -- padding takes place). -- truncl :: Int -> Doc -> Doc truncl i d = step (length d) where step dl | dl > i = Doc $ JS.dropLeft i (getDoc d) | otherwise = d -- | 'truncr' : @width * doc -> Doc@ -- -- Truncate a doc to the supplied @width@. Characters are dropped -- from the right until the document fits. If the document is -- shorter than the supplied width it is returned as is (no -- padding takes place). -- truncr :: Int -> Doc -> Doc truncr i d = step (length d) where step dl | dl > i = Doc $ JS.dropRight i (getDoc d) | otherwise = d -- | Rendering the Doc to a String. This is the same as using 'show'. -- render :: Doc -> String render = JS.toString . getDoc renderS :: Doc -> ShowS renderS = showString . render renderV :: VDoc -> String renderV = ($ "") . getVDoc -- | Print the Doc. -- -- > renderIO = putStrLn . render -- renderIO :: Doc -> IO () renderIO = putStrLn . render