157 lines
4.3 KiB
Agda
157 lines
4.3 KiB
Agda
-- A prettier printer, Philip Wadler
|
||
-- https://homepages.inf.ed.ac.uk/wadler/papers/prettier/prettier.pdf
|
||
module Prettier
|
||
|
||
import Prelude
|
||
|
||
-- `Doc` is a pretty printing document. Constructors are private, use
|
||
-- methods below. `Alt` in particular has some invariants on it, see paper
|
||
-- for details. (Something along the lines of "the first line of left is not
|
||
-- bigger than the first line of the right".)
|
||
|
||
|
||
-- data Doc = Empty | Line | Text String | Nest Nat Doc | Seq Doc Doc | Alt Doc Doc
|
||
data Doc : U where
|
||
Empty Line : Doc
|
||
Text : String -> Doc
|
||
Nest : Nat -> Doc -> Doc
|
||
Seq : Doc -> Doc -> Doc
|
||
Alt : Doc -> Doc -> Doc
|
||
|
||
|
||
-- The original paper had a List-like structure Doc (the above was DOC) which
|
||
-- had Empty and a tail on Text and Line.
|
||
-- data Item = TEXT String | LINE Nat
|
||
data Item : U where
|
||
TEXT : String -> Item
|
||
LINE : Nat -> Item
|
||
|
||
empty : Doc
|
||
empty = Empty
|
||
|
||
flatten : Doc -> Doc
|
||
flatten Empty = Empty
|
||
flatten (Seq x y) = Seq (flatten x) (flatten y)
|
||
flatten (Nest i x) = flatten x
|
||
flatten Line = Text " "
|
||
flatten (Text str) = Text str
|
||
flatten (Alt x y) = flatten x
|
||
|
||
group : Doc -> Doc
|
||
group x = Alt (flatten x) x
|
||
|
||
-- TODO - we can accumulate snoc and cat all at once
|
||
layout : List Item -> SnocList String -> String
|
||
layout Nil acc = fastConcat $ acc <>> Nil
|
||
layout (LINE k :: x) acc = layout x (acc :< "\n" :< replicate k ' ')
|
||
layout (TEXT str :: x) acc = layout x (acc :< str)
|
||
|
||
-- Whether a documents first line fits.
|
||
fits : Nat -> List Item -> Bool
|
||
fits 0 x = False
|
||
fits w ((TEXT s) :: xs) = fits (w - length s) xs
|
||
fits w _ = True
|
||
|
||
-- vs Wadler, we're collecting the left side as a SnocList to prevent
|
||
-- blowing out the stack on the Text case. The original had DOC as
|
||
-- a Linked-List like structure (now List Item)
|
||
|
||
-- I've now added a `fit` boolean to indicate if we should cut when we hit the line length
|
||
-- Wadler was relying on laziness to stop the first branch before LINE if necessary
|
||
be : Bool -> SnocList Item -> Nat -> Nat -> List (Nat × Doc) -> Maybe (List Item)
|
||
be fit acc w k Nil = Just (acc <>> Nil)
|
||
be fit acc w k ((i, Empty) :: xs) = be fit acc w k xs
|
||
be fit acc w k ((i, Line) :: xs) = (be False (acc :< LINE i) w i xs)
|
||
be fit acc w k ((i, (Text s)) :: xs) =
|
||
case not fit || (k + length s < w) of
|
||
True => (be fit (acc :< TEXT s) w (k + length s) xs)
|
||
False => Nothing
|
||
be fit acc w k ((i, (Nest j x)) :: xs) = be fit acc w k ((i + j, x):: xs)
|
||
be fit acc w k ((i, (Seq x y)) :: xs) = be fit acc w k ((i,x) :: (i,y) :: xs)
|
||
be fit acc w k ((i, (Alt x y)) :: xs) =
|
||
(_<>>_ acc) <$> (be True Lin w k ((i,x) :: xs) <|> be fit Lin w k ((i, y) :: xs))
|
||
|
||
best : Nat -> Nat -> Doc -> List Item
|
||
best w k x = fromMaybe Nil $ be False Lin w k ((Z,x) :: Nil)
|
||
|
||
-- interface Pretty a where
|
||
-- pretty : a -> Doc
|
||
|
||
data Pretty : U -> U where
|
||
MkPretty : {a} → (a → Doc) → Pretty a
|
||
|
||
pretty : {a} {{Pretty a}} → a → Doc
|
||
pretty {{MkPretty p}} x = p x
|
||
|
||
render : Nat -> Doc -> String
|
||
render w x = layout (best w Z x) Lin
|
||
|
||
SemigroupDoc : Semigroup Doc
|
||
SemigroupDoc = MkSemi (\ x y => Seq x (Seq (Text " ") y))
|
||
|
||
-- Match System.File so we don't get warnings
|
||
|
||
line : Doc
|
||
line = Line
|
||
|
||
text : String -> Doc
|
||
text = Text
|
||
|
||
nest : Nat -> Doc -> Doc
|
||
nest = Nest
|
||
|
||
infixl 7 _++_
|
||
_++_ : Doc -> Doc -> Doc
|
||
x ++ y = Seq x y
|
||
|
||
infixl 5 _</>_
|
||
_</>_ : Doc -> Doc -> Doc
|
||
x </> y = x ++ line ++ y
|
||
|
||
-- fold, but doesn't emit extra nil
|
||
folddoc : (Doc -> Doc -> Doc) -> List Doc -> Doc
|
||
folddoc f Nil = Empty
|
||
folddoc f (x :: Nil) = x
|
||
folddoc f (x :: xs) = f x (folddoc f xs)
|
||
|
||
-- separate with space
|
||
spread : List Doc -> Doc
|
||
spread = folddoc _<+>_
|
||
|
||
-- separate with new lines
|
||
stack : List Doc -> Doc
|
||
stack = folddoc _</>_
|
||
|
||
-- bracket x with l and r, indenting contents on new line
|
||
bracket : String -> Doc -> String -> Doc
|
||
bracket l x r = group (text l ++ nest (S (S Z)) (line ++ x) ++ line ++ text r)
|
||
|
||
infixl 5 _<+/>_
|
||
|
||
-- Either space or newline
|
||
|
||
_<+/>_ : Doc -> Doc -> Doc
|
||
x <+/> y = x ++ Alt (text " ") line ++ y
|
||
|
||
-- Reformat some docs to fill. Not sure if I want this precise behavior or not.
|
||
fill : List Doc -> Doc
|
||
fill Nil = Empty
|
||
fill (x :: Nil) = x
|
||
fill (x :: y :: xs) = Alt (flatten x <+> fill (flatten y :: xs)) (x </> fill (y :: xs))
|
||
|
||
-- separate with space
|
||
commaSep : List Doc -> Doc
|
||
commaSep = folddoc (\a b => a ++ text "," <+/> b)
|
||
|
||
/-
|
||
|
||
FromString Doc where
|
||
fromString = text
|
||
|
||
-- If we stick Doc into a String, try to avoid line-breaks via `flatten`
|
||
|
||
Interpolation Doc where
|
||
interpolate = render 80 . flatten
|
||
|
||
-/
|