Print.hs 17 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465
  1. {-# LANGUAGE RecordWildCards #-}
  2. {-# LANGUAGE OverloadedStrings #-}
  3. {-# LANGUAGE ScopedTypeVariables #-}
  4. module Data.SCargot.Print
  5. ( -- * Pretty-Printing
  6. encodeOne
  7. , encode
  8. , encodeOneLazy
  9. , encodeLazy
  10. -- * Pretty-Printing Control
  11. , SExprPrinter
  12. , Indent(..)
  13. , setFromCarrier
  14. , setMaxWidth
  15. , removeMaxWidth
  16. , setIndentAmount
  17. , setIndentStrategy
  18. -- * Default Printing Strategies
  19. , basicPrint
  20. , flatPrint
  21. , unconstrainedPrint
  22. ) where
  23. import qualified Data.Foldable as F
  24. import Data.Monoid ((<>))
  25. import qualified Data.Sequence as Seq
  26. import Data.Text (Text)
  27. import qualified Data.Text as T
  28. import qualified Data.Text.Lazy as TL
  29. import qualified Data.Text.Lazy.Builder as B
  30. import qualified Data.Traversable as T
  31. import Data.SCargot.Repr
  32. -- | The 'Indent' type is used to determine how to indent subsequent
  33. -- s-expressions in a list, after printing the head of the list.
  34. data Indent
  35. = Swing -- ^ A 'Swing' indent will indent subsequent exprs some fixed
  36. -- amount more than the current line.
  37. --
  38. -- > (foo
  39. -- > bar
  40. -- > baz
  41. -- > quux)
  42. | SwingAfter Int -- ^ A 'SwingAfter' @n@ indent will try to print the
  43. -- first @n@ expressions after the head on the same
  44. -- line as the head, and all after will be swung.
  45. -- 'SwingAfter' @0@ is equivalent to 'Swing'.
  46. --
  47. -- > (foo bar
  48. -- > baz
  49. -- > quux)
  50. | Align -- ^ An 'Align' indent will print the first expression after
  51. -- the head on the same line, and subsequent expressions will
  52. -- be aligned with that one.
  53. --
  54. -- > (foo bar
  55. -- > baz
  56. -- > quux)
  57. deriving (Eq, Show)
  58. -- | A 'SExprPrinter' value describes how to print a given value as an
  59. -- s-expression. The @carrier@ type parameter indicates the value
  60. -- that will be printed, and the @atom@ parameter indicates the type
  61. -- that will represent tokens in an s-expression structure.
  62. data SExprPrinter atom carrier = SExprPrinter
  63. { atomPrinter :: atom -> Text
  64. -- ^ How to serialize a given atom to 'Text'.
  65. , fromCarrier :: carrier -> SExpr atom
  66. -- ^ How to turn a carrier type back into a 'Sexpr'.
  67. , swingIndent :: SExpr atom -> Indent
  68. -- ^ How to indent subsequent expressions, as determined by
  69. -- the head of the list.
  70. , indentAmount :: Int
  71. -- ^ How much to indent after a swung indentation.
  72. , maxWidth :: Maybe Int
  73. -- ^ The maximum width (if any) If this is 'None' then the
  74. -- resulting s-expression might be printed on one line (if
  75. -- 'indentPrint' is 'False') and might be pretty-printed in
  76. -- the most naive way possible (if 'indentPrint' is 'True').
  77. , indentPrint :: Bool
  78. -- ^ Whether to indent or not. This has been retrofitted onto
  79. }
  80. -- | A default 'SExprPrinter' struct that will always print a 'SExpr'
  81. -- as a single line.
  82. flatPrint :: (atom -> Text) -> SExprPrinter atom (SExpr atom)
  83. flatPrint printer = SExprPrinter
  84. { atomPrinter = printer
  85. , fromCarrier = id
  86. , swingIndent = const Swing
  87. , indentAmount = 2
  88. , maxWidth = Nothing
  89. , indentPrint = False
  90. }
  91. -- | A default 'SExprPrinter' struct that will always swing subsequent
  92. -- expressions onto later lines if they're too long, indenting them
  93. -- by two spaces, and uses a soft maximum width of 80 characters
  94. basicPrint :: (atom -> Text) -> SExprPrinter atom (SExpr atom)
  95. basicPrint printer = SExprPrinter
  96. { atomPrinter = printer
  97. , fromCarrier = id
  98. , swingIndent = const Swing
  99. , indentAmount = 2
  100. , maxWidth = Just 80
  101. , indentPrint = True
  102. }
  103. -- | A default 'SExprPrinter' struct that will always swing subsequent
  104. -- expressions onto later lines if they're too long, indenting them by
  105. -- two spaces, but makes no effort to keep the pretty-printed sources
  106. -- inside a maximum width. In the case that we want indented printing
  107. -- but don't care about a "maximum" width, we can print more
  108. -- efficiently than in other situations.
  109. unconstrainedPrint :: (atom -> Text) -> SExprPrinter atom (SExpr atom)
  110. unconstrainedPrint printer = SExprPrinter
  111. { atomPrinter = printer
  112. , fromCarrier = id
  113. , swingIndent = const Swing
  114. , indentAmount = 2
  115. , maxWidth = Nothing
  116. , indentPrint = True
  117. }
  118. data Size = Size
  119. { sizeSum :: !Int
  120. , sizeMax :: !Int
  121. } deriving (Show)
  122. -- | This is an intermediate representation which is like (but not
  123. -- identical to) a RichSExpr representation. In particular, it has a
  124. -- special case for empty lists, and it also keeps a single piece of
  125. -- indent information around for each list
  126. data Intermediate
  127. = IAtom Text
  128. -- ^ An atom, already serialized
  129. | IList Indent Size Intermediate (Seq.Seq Intermediate) (Maybe Text)
  130. -- ^ A (possibly-improper) list, with the intended indentation
  131. -- strategy, the head of the list, the main set of elements, and the
  132. -- final improper element (if it exists)
  133. | IEmpty
  134. -- ^ An empty list
  135. sizeOf :: Intermediate -> Size
  136. sizeOf IEmpty = Size 2 2
  137. sizeOf (IAtom t) = Size len len where len = T.length t
  138. sizeOf (IList _ s _ _ _) = s
  139. concatSize :: Size -> Size -> Size
  140. concatSize l r = Size
  141. { sizeSum = sizeSum l + 1 + sizeSum r
  142. , sizeMax = sizeMax l `max` sizeMax r
  143. }
  144. toIntermediate :: SExprPrinter a (SExpr a) -> SExpr a -> Intermediate
  145. toIntermediate
  146. SExprPrinter { atomPrinter = printAtom
  147. , swingIndent = swing
  148. } = headOf
  149. where
  150. headOf (SAtom a) = IAtom (printAtom a)
  151. headOf SNil = IEmpty
  152. headOf (SCons x xs) =
  153. gather (swing x) hd Seq.empty xs (sizeOf hd) where hd = headOf x
  154. gather sw hd rs SNil sz =
  155. IList sw sz hd rs Nothing
  156. gather sw hd rs (SAtom a) sz =
  157. IList sw (sz `concatSize` aSize) hd rs (Just aStr)
  158. where aSize = Size (T.length aStr) (T.length aStr)
  159. aStr = printAtom a
  160. gather sw hd rs (SCons x xs) sz =
  161. gather sw hd (rs Seq.|> x') xs (sz `concatSize` sizeOf x')
  162. where x' = headOf x
  163. unboundIndentPrintSExpr :: SExprPrinter a (SExpr a) -> SExpr a -> TL.Text
  164. unboundIndentPrintSExpr spec = finalize . go . toIntermediate spec
  165. where
  166. finalize = B.toLazyText . joinLinesS
  167. go :: Intermediate -> Seq.Seq B.Builder
  168. go (IAtom t) = Seq.singleton (B.fromText t)
  169. go IEmpty = Seq.singleton (B.fromString "()")
  170. -- this case should never be called with an empty argument to
  171. -- @values@, as that should have been translated to @IEmpty@
  172. -- instead.
  173. go (IList iv _ initial values rest)
  174. -- if we're looking at an s-expression that has no nested
  175. -- s-expressions, then we might as well consider it flat and let
  176. -- it take the whole line
  177. | Just strings <- T.traverse ppBasic (initial Seq.<| values) =
  178. Seq.singleton (B.fromString "(" <> buildUnwords strings <> pTail rest)
  179. -- it's not "flat", so we might want to swing after the first thing
  180. | Swing <- iv =
  181. -- if this match fails, then it means we've failed to
  182. -- convert to an Intermediate correctly!
  183. let butLast = insertParen (go initial) <> fmap doIndent (F.foldMap go values)
  184. in handleTail rest butLast
  185. -- ...or after several things
  186. | SwingAfter n <- iv =
  187. let (hs, xs) = Seq.splitAt n (initial Seq.<| values)
  188. hd = B.fromString "(" <> buildUnwords (F.foldMap go hs)
  189. butLast = hd Seq.<| fmap doIndent (F.foldMap go xs)
  190. in handleTail rest butLast
  191. -- the 'align' choice is clunkier because we need to know how
  192. -- deep to indent, so we have to force the first builder to grab its size
  193. | otherwise =
  194. let -- so we grab that and figure out its length plus two (for
  195. -- the leading paren and the following space). This uses a
  196. -- max because it's possible the first thing is itself a
  197. -- multi-line s-expression (in which case it seems like
  198. -- using the Align strategy is a terrible idea, but who am
  199. -- I to quarrel with the wild fruits upon the Tree of
  200. -- Life?)
  201. len = 2 + F.maximum (fmap (TL.length . B.toLazyText) (go initial))
  202. in case Seq.viewl values of
  203. -- if there's nothing after the head of the expression, then
  204. -- we simply close it
  205. Seq.EmptyL -> insertParen (insertCloseParen (go initial))
  206. -- otherwise, we put the first two things on the same line
  207. -- with spaces and everything else gets indended the
  208. -- forementioned length
  209. y Seq.:< ys ->
  210. let hd = B.fromString "(" <> buildUnwords (F.foldMap go (Seq.fromList [initial, y]))
  211. butLast = hd Seq.<| fmap (doIndentOf (fromIntegral len)) (F.foldMap go ys)
  212. in handleTail rest butLast
  213. doIndent :: B.Builder -> B.Builder
  214. doIndent = doIndentOf (indentAmount spec)
  215. doIndentOf :: Int -> B.Builder -> B.Builder
  216. doIndentOf n b = B.fromText (T.replicate n " ") <> b
  217. insertParen :: Seq.Seq B.Builder -> Seq.Seq B.Builder
  218. insertParen s = case Seq.viewl s of
  219. Seq.EmptyL -> s
  220. x Seq.:< xs -> (B.fromString "(" <> x) Seq.<| xs
  221. handleTail :: Maybe Text -> Seq.Seq B.Builder -> Seq.Seq B.Builder
  222. handleTail Nothing = insertCloseParen
  223. handleTail (Just t) =
  224. (Seq.|> (B.fromString " . " <> B.fromText t <> B.fromString ")"))
  225. insertCloseParen :: Seq.Seq B.Builder -> Seq.Seq B.Builder
  226. insertCloseParen s = case Seq.viewr s of
  227. Seq.EmptyR -> Seq.singleton (B.fromString ")")
  228. xs Seq.:> x -> xs Seq.|> (x <> B.fromString ")")
  229. buildUnwords sq =
  230. case Seq.viewl sq of
  231. Seq.EmptyL -> mempty
  232. t Seq.:< ts -> t <> F.foldMap (\ x -> B.fromString " " <> x) ts
  233. pTail Nothing = B.fromString ")"
  234. pTail (Just t) = B.fromString " . " <> B.fromText t <> B.fromString ")"
  235. ppBasic (IAtom t) = Just (B.fromText t)
  236. ppBasic (IEmpty) = Just (B.fromString "()")
  237. ppBasic _ = Nothing
  238. -- | Modify the carrier type of a 'SExprPrinter' by describing how
  239. -- to convert the new type back to the previous type. For example,
  240. -- to pretty-print a well-formed s-expression, we can modify the
  241. -- 'SExprPrinter' value as follows:
  242. --
  243. -- >>> let printer = setFromCarrier fromWellFormed (basicPrint id)
  244. -- >>> encodeOne printer (WFSList [WFSAtom "ele", WFSAtom "phant"])
  245. -- "(ele phant)"
  246. setFromCarrier :: (c -> b) -> SExprPrinter a b -> SExprPrinter a c
  247. setFromCarrier fc pr = pr { fromCarrier = fromCarrier pr . fc }
  248. -- | Dictate a maximum width for pretty-printed s-expressions.
  249. --
  250. -- >>> let printer = setMaxWidth 8 (basicPrint id)
  251. -- >>> encodeOne printer (L [A "one", A "two", A "three"])
  252. -- "(one \n two\n three)"
  253. setMaxWidth :: Int -> SExprPrinter atom carrier -> SExprPrinter atom carrier
  254. setMaxWidth n pr = pr { maxWidth = Just n }
  255. -- | Allow the serialized s-expression to be arbitrarily wide. This
  256. -- makes all pretty-printing happen on a single line.
  257. --
  258. -- >>> let printer = removeMaxWidth (basicPrint id)
  259. -- >>> encodeOne printer (L [A "one", A "two", A "three"])
  260. -- "(one two three)"
  261. removeMaxWidth :: SExprPrinter atom carrier -> SExprPrinter atom carrier
  262. removeMaxWidth pr = pr { maxWidth = Nothing }
  263. -- | Set the number of spaces that a subsequent line will be indented
  264. -- after a swing indentation.
  265. --
  266. -- >>> let printer = setMaxWidth 12 (basicPrint id)
  267. -- >>> encodeOne printer (L [A "elephant", A "pachyderm"])
  268. -- "(elephant \n pachyderm)"
  269. -- >>> encodeOne (setIndentAmount 4) (L [A "elephant", A "pachyderm"])
  270. -- "(elephant \n pachyderm)"
  271. setIndentAmount :: Int -> SExprPrinter atom carrier -> SExprPrinter atom carrier
  272. setIndentAmount n pr = pr { indentAmount = n }
  273. -- | Dictate how to indent subsequent lines based on the leading
  274. -- subexpression in an s-expression. For details on how this works,
  275. -- consult the documentation of the 'Indent' type.
  276. --
  277. -- >>> let indent (A "def") = SwingAfter 1; indent _ = Swing
  278. -- >>> let printer = setIndentStrategy indent (setMaxWidth 8 (basicPrint id))
  279. -- >>> encodeOne printer (L [ A "def", L [ A "func", A "arg" ], A "body" ])
  280. -- "(def (func arg)\n body)"
  281. -- >>> encodeOne printer (L [ A "elephant", A "among", A "pachyderms" ])
  282. -- "(elephant \n among\n pachyderms)"
  283. setIndentStrategy :: (SExpr atom -> Indent) -> SExprPrinter atom carrier -> SExprPrinter atom carrier
  284. setIndentStrategy st pr = pr { swingIndent = st }
  285. -- Indents a line by n spaces
  286. indent :: Int -> B.Builder -> B.Builder
  287. indent n ts = B.fromText (T.replicate n " ") <> ts
  288. -- Sort of like 'unlines' but without the trailing newline
  289. joinLinesS :: Seq.Seq B.Builder -> B.Builder
  290. joinLinesS s = case Seq.viewl s of
  291. Seq.EmptyL -> ""
  292. t Seq.:< ts
  293. | F.null ts -> t
  294. | otherwise -> t <> B.fromString "\n" <> joinLinesS ts
  295. -- Sort of like 'unlines' but without the trailing newline
  296. unwordsS :: Seq.Seq B.Builder -> B.Builder
  297. unwordsS s = case Seq.viewl s of
  298. Seq.EmptyL -> ""
  299. t Seq.:< ts
  300. | F.null ts -> t
  301. | otherwise -> t <> " " <> joinLinesS ts
  302. -- Indents every line n spaces, and adds a newline to the beginning
  303. -- used in swung indents
  304. indentAllS :: Int -> Seq.Seq B.Builder -> B.Builder
  305. indentAllS n = ("\n" <>) . joinLinesS . fmap (indent n)
  306. -- Indents every line but the first by some amount
  307. -- used in aligned indents
  308. indentSubsequentS :: Int -> Seq.Seq B.Builder -> B.Builder
  309. indentSubsequentS n s = case Seq.viewl s of
  310. Seq.EmptyL -> ""
  311. t Seq.:< ts
  312. | F.null ts -> t
  313. | otherwise -> joinLinesS (t Seq.<| fmap (indent n) ts)
  314. -- oh god this code is so disgusting
  315. -- i'm sorry to everyone i let down by writing this
  316. -- i swear i'll do better in the future i promise i have to
  317. -- for my sake and for everyone's
  318. -- | Pretty-print a 'SExpr' according to the options in a
  319. -- 'LayoutOptions' value.
  320. prettyPrintSExpr :: SExprPrinter a (SExpr a) -> SExpr a -> TL.Text
  321. prettyPrintSExpr pr@SExprPrinter { .. } expr = case maxWidth of
  322. Nothing
  323. | indentPrint -> unboundIndentPrintSExpr pr (fromCarrier expr)
  324. | otherwise -> flatPrintSExpr (fmap atomPrinter (fromCarrier expr))
  325. Just w -> indentPrintSExpr' w pr expr
  326. indentPrintSExpr' :: Int -> SExprPrinter a (SExpr a) -> SExpr a -> TL.Text
  327. indentPrintSExpr' maxAmt pr@SExprPrinter { .. } = B.toLazyText . pp 0 . toIntermediate pr
  328. where
  329. pp _ IEmpty = B.fromString "()"
  330. pp _ (IAtom t) = B.fromText t
  331. pp ind (IList i sz h values end) =
  332. -- we always are going to have a head, a (possibly empty) body,
  333. -- and a (possibly empty) tail in our list formats
  334. B.fromString "(" <> hd <> body <> tl <> B.fromString ")"
  335. where
  336. -- the tail is either nothing, or the final dotted pair
  337. tl = case end of
  338. Nothing -> mempty
  339. Just x -> B.fromString " . " <> B.fromText x
  340. -- the head is the pretty-printed head, with an ambient
  341. -- indentation of +1 to account for the left paren
  342. hd = pp (ind+1) h
  343. headWidth = sizeSum (sizeOf h)
  344. indented =
  345. case i of
  346. SwingAfter n ->
  347. let (l, ls) = Seq.splitAt n values
  348. t = unwordsS (fmap (pp (ind+1)) l)
  349. ts = indentAllS (ind + indentAmount)
  350. (fmap (pp (ind + indentAmount)) ls)
  351. in t <> ts
  352. Swing ->
  353. indentAllS (ind + indentAmount)
  354. (fmap (pp (ind + indentAmount)) values)
  355. Align ->
  356. indentSubsequentS (ind + headWidth + 1)
  357. (fmap (pp (ind + headWidth + 1)) values)
  358. body
  359. -- if there's nothing here, then we don't have anything to
  360. -- indent
  361. | length values == 0 = mempty
  362. -- if we can't fit the whole next s-expression on the same
  363. -- line, then we use the indented form
  364. | sizeSum sz + ind > maxAmt = B.fromString " " <> indented
  365. | otherwise =
  366. -- otherwise we print the whole thing on one line!
  367. B.fromString " " <> unwordsS (fmap (pp (ind + 1)) values)
  368. -- if we don't indent anything, then we can ignore a bunch of the
  369. -- details above
  370. flatPrintSExpr :: SExpr Text -> TL.Text
  371. flatPrintSExpr = B.toLazyText . pHead
  372. where
  373. pHead (SCons x xs) =
  374. B.fromString "(" <> pHead x <> pTail xs
  375. pHead (SAtom t) =
  376. B.fromText t
  377. pHead SNil =
  378. B.fromString "()"
  379. pTail (SCons x xs) =
  380. B.fromString " " <> pHead x <> pTail xs
  381. pTail (SAtom t) =
  382. B.fromString " . " <> B.fromText t <> B.fromString ")"
  383. pTail SNil =
  384. B.fromString ")"
  385. -- | Turn a single s-expression into a string according to a given
  386. -- 'SExprPrinter'.
  387. encodeOne :: SExprPrinter atom carrier -> carrier -> Text
  388. encodeOne s@(SExprPrinter { .. }) =
  389. TL.toStrict . prettyPrintSExpr (s { fromCarrier = id }) . fromCarrier
  390. -- | Turn a list of s-expressions into a single string according to
  391. -- a given 'SExprPrinter'.
  392. encode :: SExprPrinter atom carrier -> [carrier] -> Text
  393. encode spec =
  394. T.intercalate "\n\n" . map (encodeOne spec)
  395. -- | Turn a single s-expression into a lazy 'Text' according to a given
  396. -- 'SExprPrinter'.
  397. encodeOneLazy :: SExprPrinter atom carrier -> carrier -> TL.Text
  398. encodeOneLazy s@(SExprPrinter { .. }) =
  399. prettyPrintSExpr (s { fromCarrier = id }) . fromCarrier
  400. -- | Turn a list of s-expressions into a lazy 'Text' according to
  401. -- a given 'SExprPrinter'.
  402. encodeLazy :: SExprPrinter atom carrier -> [carrier] -> TL.Text
  403. encodeLazy spec = TL.intercalate "\n\n" . map (encodeOneLazy spec)