diff --git a/FPretty.cabal b/FPretty.cabal new file mode 100644 --- /dev/null +++ b/FPretty.cabal @@ -0,0 +1,22 @@ +name: FPretty +version: 1.0 +synopsis: Efficient simple pretty printing combinators +description: A pretty printer turns a tree structure into indented text, + such that the indentation reflects the tree structure. To keep + text short, substructures are put into a single line as far as + possible. The library provides combinators for building + pretty printers. It emphasizes simplicity and efficiency. +homepage: http://www.cs.kent.ac.uk/~oc/pretty.html +license: BSD3 +license-file: LICENSE +author: Olaf Chitil +maintainer: O.Chitil@kent.ac.uk +-- copyright: +category: Text.PrettyPrint +build-type: Simple +cabal-version: >=1.8 + +library + exposed-modules: Text.PrettyPrint.FPretty + -- other-modules: + build-depends: base >=4.5 && < 5, containers >= 0.4 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2012, Olaf Chitil + +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 Olaf Chitil nor the names of other + 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 +OWNER 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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Text/PrettyPrint/FPretty.hs b/Text/PrettyPrint/FPretty.hs new file mode 100644 --- /dev/null +++ b/Text/PrettyPrint/FPretty.hs @@ -0,0 +1,391 @@ +{-# LANGUAGE Safe #-} + +-- | +-- Module : Text.PrettyPrint.FPretty +-- License : BSD3 +-- Maintainer : Olaf Chitil +-- Portability : portable +-- +-- Fast pretty-printing library +-- +-- A pretty printer turns a tree structure into indented text, such that the +-- indentation reflects the tree structure. To minimise the number of lines, +-- substructures are put on a single line as far as possible within the given +-- line-width limit. +-- +-- An pretty-printed example with 35 characters line-width: +-- +-- > if True +-- > then if True then True else True +-- > else +-- > if False +-- > then False +-- > else False +-- +-- To obtain the above the user of a library only has to convert their tree +-- structure into a document of type 'Doc'. +-- +-- > data Exp = ETrue | EFalse | If Exp Exp Exp +-- > +-- > toDoc :: Exp -> Doc +-- > toDoc ETrue = text "True" +-- > toDoc EFalse = text "False" +-- > toDoc (If e1 e2 e3) = +-- > group (nest 3 ( +-- > group (nest 3 (text "if" <> line <> toDoc e1)) <> line <> +-- > group (nest 3 (text "then" <> line <> toDoc e2)) <> line <> +-- > group (nest 3 (text "else" <> line <> toDoc e3)))) +-- +-- A document represents a set of layouts. The function 'pretty' then takes +-- a desired maximal printing width and a document and selects the layout that fits +-- best. +-- +-- Another example filling lines with elements of a list: +-- +-- > list2Doc :: Show a => [a] -> Doc +-- > list2Doc xs = text "[" <> go xs <> text "]" +-- > where +-- > go [] = empty +-- > go [x] = text (show x) +-- > go (x:y:ys) = text (show x) text ", " <> go (y:ys) +-- > +-- > main = putStrLn (pretty 40 (list2Doc [1..20])) +-- +-- The output is +-- +-- > [1 , 2 , 3 , 4 , 5 , 6 , 7 , 8 , 9 , 10 +-- > , 11 , 12 , 13 , 14 , 15 , 16 , 17 , 18 +-- > , 19 , 20] +-- +-- FPretty is an implementation of the simple combinators designed by Phil Wadler. +-- The library uses a single associative combinator '<>' to concatenate documents with +-- 'empty' as identity. There is a primitive document for potential line breaks, i.e., +-- its two layouts are both a line break and a space. The 'group' combinator then +-- enforces that all potential line breaks within a document must be layouted in the +-- same way, i.e. either line breaks or spaces. +-- +-- The time complexity is linear in the output size. +-- In contrast, all other pretty printing libraries +-- (original Phil Wadler, PPrint by Leijen, Hughes / Peyton Jones) +-- use more or less backtracking, and their speed depends unpredictably on the +-- desired output width. +-- +-- Also FPretty provides both relative and absolute indentation via +-- nest and align, whereas HughesPJ provides only relative indentation. +-- +-- Unlike other libraries, FPretty does not provide several rendering modes, +-- but could be extended to do so. +-- +-- The combinators are a subset of those of PPrint and are similar to HughesPJ +-- to make moving from one library to the other as painless as possible. +-- +-- For more implementation notes see or +-- Doitse Swierstra and Olaf Chitil: Linear, bounded, functional pretty-printing. +-- Journal of Functional Programming, 19(1):1-16, January 2009. + +-- The implementation could be speeded up further by specialisation of the interpreter +-- for dequeues of size 0, 1 and >1. + +module Text.PrettyPrint.FPretty + ( + -- * The type of documents + Doc + -- * Pretty printing + ,pretty + -- * Basic documents + ,empty,text + -- * Basic documents with several layouts + ,line,linebreak,softline,softbreak + -- * Combining two documents + -- ** The base binary combinator + ,(<>) + -- ** Derived binary combinators + ,(<+>),(<$>),(<$$>),(),() + -- * Modifying the layouts of one document + ,group,nest,align,hang + -- * Combining many documents + ,hsep,vsep,fillSep,sep,hcat,vcat,fillCat,cat) where + +import Data.Sequence as Dequeue (Seq, (<|), viewl, viewr, ViewL(..), ViewR(..)) +import qualified Data.Sequence as Dequeue (empty) + -- Originally used Banker's dequeue from Okasaki's book + -- on Functional Data Structures. + -- Efficiency probably similar, but Data.Sequence is part of the standard Haskell + -- libraries. + +infixr 6 <>,<+> +infixr 5 <$>,<$$>,, + +---------------------- +-- derived combinators + +-- | A space, if the following still fits on the current line, otherwise newline. +softline :: Doc +softline = group line + +-- | Nothing, if the following still fits on the current line, otherwise newline. +softbreak :: Doc +softbreak = group linebreak + +-- | Increase identation relative to the *current* column. +hang :: Int -> Doc -> Doc +hang i x = align (nest i x) + +-- | Combine with a space in between. +(<+>) :: Doc -> Doc -> Doc +dl <+> dr = dl <> text " " <> dr + +-- | Combine with a 'line' in between. +(<$>) :: Doc -> Doc -> Doc +dl <$> dr = dl <> line <> dr + +-- | Combine with a 'linebreak' in between. +(<$$>) :: Doc -> Doc -> Doc +dl <$$> dr = dl <> linebreak <> dr + +-- | Combine with a 'softline' in between. +() :: Doc -> Doc -> Doc +dl dr = dl <> softline <> dr + +-- | Combine with a 'softbreak' in between. +() :: Doc -> Doc -> Doc +dl dr = dl <> softbreak <> dr + +-- ** Combining lists of documents +-- These combinators all assume a non-empty list of documents +-- and they do not start a new line at the end (unlike PPrint). + +-- | Combine non-empty list of documents with '<+>', i.e., a space separator. +hsep :: [Doc] -> Doc +hsep = foldr1 (<+>) -- differs from PPrint + +-- | Combine non-empty list of documents with '<$>', i.e., a 'line' separator. +vsep :: [Doc] -> Doc +vsep = foldr1 (<$>) -- differs from PPrint + +-- | Combine non-empty list of documents with '', i.e., a 'softline' separator. +fillSep :: [Doc] -> Doc +fillSep = foldr1 () -- differs from PPrint + +-- | Combine non-empty list of documents vertically as a group. +-- Seperated by space instead if all fit on one line. +sep :: [Doc] -> Doc +sep xs = group (vsep xs) -- differs from PPrint + +-- | Combine non-empty list of documents with '<>'. +hcat :: [Doc] -> Doc +hcat = foldr1 (<>) -- differs from PPrint + +-- | Combine non-empty list of documents with '<$$>', i.e., a 'linebreak' separator. +vcat :: [Doc] -> Doc +vcat = foldr1 (<$$>) -- differs from PPrint + +-- | Combine non-empty list of documents with '', i.e., a 'softbreak' separator. +fillCat :: [Doc] -> Doc +fillCat = foldr1 () -- differs from PPrint + +-- | Combine non-empty list of documents, filling lines as far as possible. +cat :: [Doc] -> Doc +cat xs = group (vcat xs) -- differs from PPrint + +------------------- +-- basic combinators + +-- | The empty document; equal to text \"\". +empty :: Doc + +-- | Atomic document consisting of just the given text. +-- There should be no newline \\n in the string. +text :: String -> Doc + +-- | Either a space or a new line. +line :: Doc + +-- | Either nothing ('empty') or a new line. +linebreak :: Doc + +-- | Horizontal composition of two documents. +-- Is associative with identity 'empty'. +(<>) :: Doc -> Doc -> Doc + +-- | Mark document as group, that is, layout as a single line if possible. +-- Within a group for all basic documents with several layouts the same layout +-- is chosen, that is, they are all horizontal or all new lines. +-- Within a vertical group there can be a horizontal group, but within a +-- horizontal group all groups are also layouted horizontally. +group :: Doc -> Doc + +-- | Increases current indentation level (absolute). Assumes argument >= 0. +nest :: Int -> Doc -> Doc + +-- | Set indentation to current column. +align :: Doc -> Doc + +-- | Pretty print within given width. +-- Selects from the *set* of layouts that the document represents the widest +-- that fits within the given width. +-- If no such layout exists, then it will choose the narrowest that exceeds the given +-- width. +pretty :: Int -> Doc -> String + +-- | A Document represents a *set* of layouts. +data Doc = Text Int String -- includes length of text string + | Nil + | Line Int String -- includes length of optional text + | Doc :<> Doc + | Group Doc + | Nest Int Doc -- increase current indentation + | Align Int Doc -- set indentation to current column plus increment + +empty = Nil +text t = Text (length t) t +line = Line 1 " " +linebreak = Line 0 "" +(<>) = (:<>) +group = Group +nest = Nest +align = Align 0 +pretty w d = interpret (normalise d) w (\p dq r i -> "") 0 Dequeue.empty w 0 + + +-- semantic-preserving transformation that ensures that between every end +-- of group and a subsequent line there is no text +normalise :: Doc -> Doc +normalise d = td :<> sd + where + (td,sd) = go d Nil + -- Assume second argument only built from text,nil and <>. + -- Ensures first component of result built only from text,nil and <>. + -- go d tt = (td,sd) implies d <> tt and td <> sd denote the same set of + -- layouts. + go :: Doc -> Doc -> (Doc,Doc) + go Nil tt = (tt,Nil) + go (Text l t) tt = (Text l t :<> tt,Nil) + go (Line l t) tt = (Nil,Line l t :<> tt) + go (dl :<> dr) tt = let (tdl,sdl) = go dl tdr + (tdr,sdr) = go dr tt + in (tdl,sdl :<> sdr) + go (Group d) tt = let (td,sd) = go d tt in (td,Group sd) + go (Nest i d) tt = let (td,sd) = go d tt in (td,Nest i sd) + go (Align i d) tt = let (td,sd) = go d tt in (td,Align (i - docLength td) sd) + +-- Determine length of a document consisting only of text,nil and <>. +-- To ensure linear complexity for align should actually keep track +-- of document length within go function itself. +docLength :: Doc -> Int +docLength Nil = 0 +docLength (Text l _) = l +docLength (dl :<> dr) = docLength dl + docLength dr + +type Width = Int +type Position = Int +type Indentation = Int +type Horizontal = Bool +type Remaining = Int +type Out = Remaining -> Indentation -> String + -- indentation needed here because of align combinator +type OutGroup = Horizontal -> Out -> Out +type TreeCont = Position -> Dequeue.Seq (Position,OutGroup) -> Out + + +interpret :: Doc -> Width -> TreeCont -> TreeCont +interpret Nil w tc p ds = tc p ds +interpret (Text l t) w tc p ds = + extendFrontGroup id prune outText tc (p+l) ds + where + outText :: OutGroup + outText h c r i = t ++ c (r-l) i +interpret (Line l t) w tc p ds = + extendFrontGroup id prune outLine tc (p+l) ds + where + outLine :: OutGroup + outLine h c r i = if h then t ++ c (r-l) i + else '\n' : replicate i ' ' ++ c (w-i) i +interpret (dl :<> dr) w tc p ds = + interpret dl w (interpret dr w tc) p ds +interpret (Group d) w tc p ds = + interpret d w (leaveGroup tc) p ((p,\h c -> c) <| ds) +interpret (Nest j d) w tc p ds = + extendFrontGroup (interpret d w) (interpret d w) outNest tc p ds + where + outNest :: OutGroup + outNest h c r i = c r (i+j) +interpret (Align j d) w tc p ds = + extendFrontGroup (interpret d w) (interpret d w) outAlign tc p ds + where + outAlign :: OutGroup + outAlign h c r i = c r (w-r+j) + + +-- If no pending groups, then do out directly, +-- otherwise add out to pending group, applying given prune function. +-- This extracts an otherwise repeated pattern of the interpret function. +extendFrontGroup :: (TreeCont -> TreeCont) -> (TreeCont -> TreeCont) -> + OutGroup -> TreeCont -> TreeCont +extendFrontGroup cont1 cont2 out tc p ds = + case viewl ds of + EmptyL -> out False (cont1 tc p ds) + (s,outGrp) :< ds' -> + cont2 tc p ((s,\h c -> outGrp h (out h c)) <| ds') + + +leaveGroup :: TreeCont -> TreeCont +leaveGroup tc p ds = + case viewl ds of + EmptyL -> tc p ds + (s1,outGrp1) :< ds1 -> + case viewl ds1 of + EmptyL -> outGrp1 True (tc p Dequeue.empty) + (s2,outGrp2) :< ds2 -> + tc p ((s2, \f c -> outGrp2 f (\r1 -> outGrp1 (p <= s2+r1) c r1)) <| ds2) + + +prune :: TreeCont -> TreeCont +prune tc p ds = + case viewr ds of + EmptyR -> tc p ds + ds' :> (s,outGrp) -> \r -> if p > s+r + then outGrp False (prune tc p ds') r + else tc p ds r + + +-- ------------------------------------------- +-- Properties for testing. All should be True. + +prop0 = pretty 6 (group (text "Hi" <> line <> text "you") <> text "!") == + "Hi\nyou!" +prop1 = pretty 4 (group (text "hi" <> line <> text "world")) == + "hi\nworld" +prop2 = + pretty 8 (group (text "hi" <> line <> text "world") <> text "liness") == + "hi\nworldliness" +prop3 = + take 6 (pretty 4 (group (text "hi" <> line <> text "you" <> undefined))) == + "hi\nyou" +prop4 = + take 6 (pretty 4 (group (text "hi" <> line) <> + group (text "you" <> line) <> undefined)) == + "hi\nyou" +prop5 = + take 6 (pretty 4 (group (text "hi" <> + group (line <> text "you" <> undefined)))) == + "hi\nyou" +prop6 = + take 7 (pretty 3 (group (text "hi" <> line <> + group (line <> text "you" <> undefined)))) == + "hi\n\nyou" +prop7 = + pretty 10 (group (text "what" <> + align (group (text "do" <> line <> text "you" <> line <> + text "do" <> align (line <> text "now?"))))) == + "whatdo\n you\n do\n now?" + +prop8 = + pretty 10 (group (text "one " <> (align (line <> text "two" <> + align (line <> text "three"))))) == + "one \n two\n three" + +prop9 = + pretty 10 (group (text "one " <> (nest 2 (line <> text "two" <> + nest 3 (line <> text "three"))))) == + "one \n two\n three"