John D. Ramsdell wrote:
On Nov 17, 2007 3:04 PM, apfelmus
{-# LANGUAGE BangPatterns #-}
-- Author: Chris Kuklewicz -- -- This is a rewrite of John D. Ramsdell Pretty.hs code on -- haskell-cafe mailing list
-- Changelog from Pretty.hs -- All Pretty elements have a length field (lazy at the moment) -- Inlined logic of 'blanks' and used new 'prepend' instead -- Replaced blocksize by startColumn == margin - blocksize -- Replaced space by colunmIn == margin-space -- Documented what 'after' means module Blocks(Pretty,str,brk,spc,blo,cat,pr) where
-- All of the len's are non-negative, guaranteed by smart constructors data Pretty = Str { len :: Int, string :: String} | Brk { len :: Int } | Blo { len :: Int, indentBy :: Int, parts :: [Pretty] }
str s = Str (length s) s
brk n | n < 0 = error ("Cannot have negative width brk! n = " ++ show n) | otherwise = Brk n
spc = brk 1
blo indent es | indent < 0 = error ("Cannot have negative width blo! indent = " ++ show indent) | otherwise = Blo (sum (map len es)) indent es
cat = blo 0
{-# INLINE pr #-} pr :: Int -> Pretty -> (String->String) pr margin e sRest = let {startColumn = 0; after = 0; columnIn = 0} in snd (printing margin startColumn after [e] (columnIn, sRest))
{-# INLINE printing #-} printing :: Int -> Int -> Int -> [Pretty] -> (Int,String) -> (Int,String) -- margin is the desired maximum line length and must be non-negative -- startColumn, columnIn, column', and columnOut are all non-negative, -- but any of them may be greater than margin printing margin | margin < 0 = error ("Cannot have non-positive margin! margin == "++show margin) | otherwise = block where
-- startColumn is the "current amount of indent after newline" -- after is how much must be laid after the (e:es) and before the next break, non-negative block !startColumn !after = layout where
-- (e:es) are the items to layout before 'sIn' -- columnIn is the starting column for laying out 'e' -- columnOut is the column after the (e:es) have been laid out layout [] columnIn'sIn'pair = columnIn'sIn'pair layout (e:es) (!columnIn,sIn) = (columnOut,sOut) where
(columnOut,s') = layout es (column',sIn)
-- column' is the column to use after when laying out es, after laying out e (column',sOut) = case e of Str n str -> (columnIn+n, showString str s') Brk n | columnIn + n + breakDist es after <= margin -> (columnIn+n, prepend n ' ' s') | 0 <= startColumn -> (startColumn, '\n':prepend startColumn ' ' s') | otherwise -> (0, '\n':s') Blo _n indent es' -> let startColumn' = indent + columnIn after' = breakDist es after in block startColumn' after' es' (columnIn,s')
-- Trivial helper function to prepend 'n' copies of character 'c' {-# INLINE prepend #-} prepend n c s | n < 0 = error ("prepend called with "++show n++" < 0 !") | otherwise = loop n where loop 0 = s loop n = c : loop (pred n)
-- after >=0 implies breakDist _ after >= 0 -- Note that contained Blo's are assumed to layout in one line without using any internal breaks. breakDist :: [Pretty] -> Int -> Int breakDist esIn !after = accum esIn 0 where accum [] beforeBrk = beforeBrk + after accum (Brk {}:_) beforeBrk = beforeBrk accum (e : es) beforeBrk = accum es (beforeBrk + len e)
test1 = putStrLn $ pr 5 (blo 3 [str "Hello",spc,str "World!" ,blo 3 [str "Goodbye",spc,str "Space!"] ,spc,cat [str "The",spc,str "End"]]) ""
test2 = putStrLn $ pr 12 (blo 3 [str "Hello",spc,str "World!",spc ,blo 3 [str "Goodbye",spc,str "Space!"] ,spc,cat [str "The",spc,str "End"]]) ""
test3 = putStrLn $ pr 12 (blo 3 [str "Hello",spc,str "World!" ,blo 3 [str "Goodbye",spc,str "Space!"] ,spc,cat [str "The",spc,str "End"]]) ""
{- *Blocks> test1 Hello World!Goodbye Space! The End *Blocks> test2 Hello World! Goodbye Space! The End *Blocks> test3 Hello World!Goodbye Space! The End -}