gdritter repos s-cargot / 4b4652d
Rework the inefficient pretty-printer to use Intermediate too Getty Ritter 7 years ago
3 changed file(s) with 91 addition(s) and 113 deletion(s). Collapse all Expand all
+89
-111
Data/SCargot/Print.hs less more
1717 -- * Default Printing Strategies
1818 , basicPrint
1919 , flatPrint
20 , unboundIndentPrint
20 , unconstrainedPrint
2121 ) where
2222
2323 import qualified Data.Foldable as F
9898
9999 -- | A default 'SExprPrinter' struct that will always swing subsequent
100100 -- expressions onto later lines if they're too long, indenting them
101 -- by two spaces.
101 -- by two spaces, and uses a soft maximum width of 80 characters
102102 basicPrint :: (atom -> Text) -> SExprPrinter atom (SExpr atom)
103103 basicPrint printer = SExprPrinter
104104 { atomPrinter = printer
109109 , indentPrint = True
110110 }
111111
112 unboundIndentPrint :: (atom -> Text) -> SExprPrinter atom (SExpr atom)
113 unboundIndentPrint printer = SExprPrinter
112 -- | A default 'SExprPrinter' struct that will always swing subsequent
113 -- expressions onto later lines if they're too long, indenting them by
114 -- two spaces, but makes no effort to keep the pretty-printed sources
115 -- inside a maximum width. In the case that we want indented printing
116 -- but don't care about a "maximum" width, we can print more
117 -- efficiently than in other situations.
118 unconstrainedPrint :: (atom -> Text) -> SExprPrinter atom (SExpr atom)
119 unconstrainedPrint printer = SExprPrinter
114120 { atomPrinter = printer
115121 , fromCarrier = id
116122 , swingIndent = const Swing
125131 -- indent information around for each list
126132 data Intermediate
127133 = IAtom Text
128 | IList Indent (Seq.Seq Intermediate) (Maybe Text)
134 | IList Indent Intermediate (Seq.Seq Intermediate) (Maybe Text)
129135 | IEmpty
130136
131137
138144 headOf (SAtom a) = IAtom (printAtom a)
139145 headOf SNil = IEmpty
140146 headOf (SCons x xs) =
141 gather (swing x) (Seq.singleton (headOf x)) xs
142 gather sw rs SNil =
143 IList sw rs Nothing
144 gather sw rs (SAtom a) =
145 IList sw rs (Just (printAtom a))
146 gather sw rs (SCons x xs) =
147 gather sw (rs Seq.|> headOf x) xs
147 gather (swing x) (headOf x) (Seq.empty) xs
148 gather sw hd rs SNil =
149 IList sw hd rs Nothing
150 gather sw hd rs (SAtom a) =
151 IList sw hd rs (Just (printAtom a))
152 gather sw hd rs (SCons x xs) =
153 gather sw hd (rs Seq.|> headOf x) xs
148154
149155
150156 unboundIndentPrintSExpr :: SExprPrinter a (SExpr a) -> SExpr a -> TL.Text
158164 -- this case should never be called with an empty argument to
159165 -- @values@, as that should have been translated to @IEmpty@
160166 -- instead.
161 go (IList iv values rest)
167 go (IList iv initial values rest)
162168 -- if we're looking at an s-expression that has no nested
163169 -- s-expressions, then we might as well consider it flat and let
164170 -- it take the whole line
165 | Just strings <- T.traverse ppBasic values =
171 | Just strings <- T.traverse ppBasic (initial Seq.<| values) =
166172 Seq.singleton (B.fromString "(" <> buildUnwords strings <> pTail rest)
167173
168174 -- it's not "flat", so we might want to swing after the first thing
169175 | Swing <- iv =
170176 -- if this match fails, then it means we've failed to
171177 -- convert to an Intermediate correctly!
172 let x Seq.:< xs = Seq.viewl values
173 butLast = insertParen (go x) <> fmap doIndent (F.foldMap go xs)
178 let butLast = insertParen (go initial) <> fmap doIndent (F.foldMap go values)
174179 in handleTail rest butLast
175180
176181 -- ...or after several things
177182 | SwingAfter n <- iv =
178 let (hs, xs) = Seq.splitAt n values
183 let (hs, xs) = Seq.splitAt n (initial Seq.<| values)
179184 hd = B.fromString "(" <> buildUnwords (F.foldMap go hs)
180185 butLast = hd Seq.<| fmap doIndent (F.foldMap go xs)
181186 in handleTail rest butLast
183188 -- the 'align' choice is clunkier because we need to know how
184189 -- deep to indent, so we have to force the first builder to grab its size
185190 | otherwise =
186 let x Seq.:< xs = Seq.viewl values
187 -- so we grab that and figure out its length plus two (for
191 let -- so we grab that and figure out its length plus two (for
188192 -- the leading paren and the following space). This uses a
189193 -- max because it's possible the first thing is itself a
190194 -- multi-line s-expression (in which case it seems like
191195 -- using the Align strategy is a terrible idea, but who am
192196 -- I to quarrel with the wild fruits upon the Tree of
193197 -- Life?)
194 len = 2 + F.maximum (fmap (TL.length . B.toLazyText) (go x))
195 in case Seq.viewl xs of
198 len = 2 + F.maximum (fmap (TL.length . B.toLazyText) (go initial))
199 in case Seq.viewl values of
196200 -- if there's nothing after the head of the expression, then
197201 -- we simply close it
198 Seq.EmptyL -> insertParen (insertCloseParen (go x))
202 Seq.EmptyL -> insertParen (insertCloseParen (go initial))
199203 -- otherwise, we put the first two things on the same line
200204 -- with spaces and everything else gets indended the
201205 -- forementioned length
202206 y Seq.:< ys ->
203 let hd = B.fromString "(" <> buildUnwords (F.foldMap go (Seq.fromList [x, y]))
207 let hd = B.fromString "(" <> buildUnwords (F.foldMap go (Seq.fromList [initial, y]))
204208 butLast = hd Seq.<| fmap (doIndentOf (fromIntegral len)) (F.foldMap go ys)
205209 in handleTail rest butLast
206210 -- B.fromString "(" <> buildUnwords (F.foldMap go (Seq.fromList [x, y]))
297301 setIndentStrategy st pr = pr { swingIndent = st }
298302
299303
300 -- Sort of like 'unlines' but without the trailing newline
301 joinLines :: [Text] -> Text
302 joinLines = T.intercalate "\n"
303
304
305304 -- Indents a line by n spaces
306305 indent :: Int -> Text -> Text
307306 indent n ts = T.replicate n " " <> ts
308307
309308
309 -- Sort of like 'unlines' but without the trailing newline
310 joinLinesS :: Seq.Seq Text -> Text
311 joinLinesS s = case Seq.viewl s of
312 Seq.EmptyL -> ""
313 t Seq.:< ts
314 | F.null ts -> t
315 | otherwise -> t <> "\n" <> joinLinesS ts
316
317
318 -- Sort of like 'unlines' but without the trailing newline
319 unwordsS :: Seq.Seq Text -> Text
320 unwordsS s = case Seq.viewl s of
321 Seq.EmptyL -> ""
322 t Seq.:< ts
323 | F.null ts -> t
324 | otherwise -> t <> " " <> joinLinesS ts
325
326
310327 -- Indents every line n spaces, and adds a newline to the beginning
311328 -- used in swung indents
312 indentAll :: Int -> [Text] -> Text
313 indentAll n = ("\n" <>) . joinLines . map (indent n)
329 indentAllS :: Int -> Seq.Seq Text -> Text
330 indentAllS n = ("\n" <>) . joinLinesS . fmap (indent n)
314331
315332
316333 -- Indents every line but the first by some amount
317334 -- used in aligned indents
318 indentSubsequent :: Int -> [Text] -> Text
319 indentSubsequent _ [] = ""
320 indentSubsequent _ [t] = t
321 indentSubsequent n (t:ts) = joinLines (t : go ts)
322 where go = map (indent n)
335 indentSubsequentS :: Int -> Seq.Seq Text -> Text
336 indentSubsequentS n s = case Seq.viewl s of
337 Seq.EmptyL -> ""
338 t Seq.:< ts
339 | F.null ts -> t
340 | otherwise -> joinLinesS (t Seq.<| fmap (indent n) ts)
341 -- where go = fmap (indent n)
323342
324343
325344 -- oh god this code is so disgusting
334353 Nothing
335354 | indentPrint -> TL.toStrict (unboundIndentPrintSExpr pr (fromCarrier expr))
336355 | otherwise -> flatPrintSExpr (fmap atomPrinter (fromCarrier expr))
337 Just _ -> indentPrintSExpr pr expr
338
339
340 indentPrintSExpr :: SExprPrinter a (SExpr a) -> SExpr a -> Text
341 indentPrintSExpr SExprPrinter { .. } = pHead 0
356 Just _ -> indentPrintSExpr' pr expr
357
358
359 indentPrintSExpr' :: SExprPrinter a (SExpr a) -> SExpr a -> Text
360 indentPrintSExpr' pr@SExprPrinter { .. } = pp 0 . toIntermediate pr
342361 where
343 pHead _ SNil = "()"
344 pHead _ (SAtom a) = atomPrinter a
345 pHead ind (SCons x xs) = gather ind x xs id
346 gather ind h (SCons x xs) k = gather ind h xs (k . (x:))
347 gather ind h end k = "(" <> hd <> body <> tl <> ")"
348 where tl = case end of
349 SNil -> ""
350 SAtom a -> " . " <> atomPrinter a
351 SCons _ _ -> error "[unreachable]"
352 hd = indentSubsequent ind [pHead (ind+1) h]
353 lst = k []
354 flat = T.unwords (map (pHead (ind+1)) lst)
355 headWidth = T.length hd + 1
356 indented =
357 case swingIndent h of
358 SwingAfter n ->
359 let (l, ls) = splitAt n lst
360 t = T.unwords (map (pHead (ind+1)) l)
361 ts = indentAll (ind + indentAmount)
362 (map (pHead (ind + indentAmount)) ls)
363 in t <> ts
364 Swing ->
365 indentAll (ind + indentAmount)
366 (map (pHead (ind + indentAmount)) lst)
367 Align ->
368 indentSubsequent (ind + headWidth + 1)
369 (map (pHead (ind + headWidth + 1)) lst)
370 body
371 | length lst == 0 = ""
372 | Just maxAmt <- maxWidth
373 , T.length flat + ind > maxAmt = " " <> indented
374 | otherwise = " " <> flat
375
376 -- where
377 -- -- this is the base-case that knows how to print empty lists and
378 -- -- atoms
379 -- pHead _ SNil = B.fromString "()"
380 -- pHead _ (SAtom a) = B.fromText a
381 -- pHead ind (SCons x xs) = gather ind x xs id 0
382
383 -- -- otherwise, we trawl through the list grabbing every element...
384 -- gather ind h (SCons x xs) k r = gather ind h xs (k . (x:)) (r + T.length x)
385 -- gather ind h end k r = B.fromString "(" <> hd <> body <> tl <> B.fromString ")"
386 -- where
387 -- tl = case end of
388 -- SNil -> mempty
389 -- SAtom a -> B.fromString " . " <> B.fromText a
390 -- SCons _ _ -> error "[unreachable]"
391 -- hd = indentSubsequent ind [pHead (ind+1) h]
392 -- lst = k []
393 -- flat = T.unwords (map (pHead (ind+1)) lst)
394 -- headWidth = T.length hd + 1
395 -- indented =
396 -- case swingIndent h of
397 -- SwingAfter n ->
398 -- let (l, ls) = splitAt n lst
399 -- t = T.unwords (map (pHead (ind+1)) l)
400 -- ts = indentAll (ind + indentAmount)
401 -- (map (pHead (ind + indentAmount)) ls)
402 -- in t <> ts
403 -- Swing ->
404 -- indentAll (ind + indentAmount)
405 -- (map (pHead (ind + indentAmount)) lst)
406 -- Align ->
407 -- indentSubsequent (ind + headWidth + 1)
408 -- (map (pHead (ind + headWidth + 1)) lst)
409 -- body
410 -- | length lst == 0 = B.fromString ""
411 -- | Just maxAmt <- maxWidth
412 -- , T.length flat + ind > maxAmt = B.fromString " " <> indented
413 -- | otherwise = B.fromString " " <> flat
362 pp _ IEmpty = "()"
363 pp _ (IAtom t) = t
364 pp ind (IList i h values end) = "(" <> hd <> body <> tl <> ")"
365 where
366 tl = case end of
367 Nothing -> ""
368 Just x -> " . " <> x
369 hd = pp (ind+1) h
370 flat = unwordsS (fmap (pp (ind + 1)) values)
371 headWidth = T.length hd + 1
372 indented =
373 case i of
374 SwingAfter n ->
375 let (l, ls) = Seq.splitAt n values
376 t = unwordsS (fmap (pp (ind+1)) l)
377 ts = indentAllS (ind + indentAmount)
378 (fmap (pp (ind + indentAmount)) ls)
379 in t <> ts
380 Swing ->
381 indentAllS (ind + indentAmount)
382 (fmap (pp (ind + indentAmount)) values)
383 Align ->
384 indentSubsequentS (ind + headWidth + 1)
385 (fmap (pp (ind + headWidth + 1)) values)
386 body
387 | length values == 0 = ""
388 | Just maxAmt <- maxWidth
389 , T.length flat + ind > maxAmt = " " <> indented
390 | otherwise = " " <> flat
391
414392
415393 -- if we don't indent anything, then we can ignore a bunch of the
416394 -- details above
+1
-1
Data/SCargot.hs less more
2626 , Indent(..)
2727 , basicPrint
2828 , flatPrint
29 , unboundIndentPrint
29 , unconstrainedPrint
3030 , setFromCarrier
3131 , setMaxWidth
3232 , removeMaxWidth
+1
-1
test/SCargotQC.hs less more
7474 prettyPrinter = basicPrint (const "X")
7575
7676 widePrinter :: SExprPrinter () (SExpr ())
77 widePrinter = unboundIndentPrint (const "X")
77 widePrinter = unconstrainedPrint (const "X")
7878
7979
8080 richIso :: SExpr () -> Bool