{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Language.Sexp.Pretty
( format
) where
import Data.ByteString.Lazy.Char8 (ByteString)
import Data.Functor.Foldable (para)
import Data.Scientific
import qualified Data.Text.Lazy as TL
import Data.Text.Lazy.Encoding (encodeUtf8)
#if MIN_VERSION_prettyprinter(1,7,0)
import Prettyprinter
import Prettyprinter.Internal (unsafeTextWithoutNewlines)
import qualified Prettyprinter.Render.Text as Render
#else
import Data.Text.Prettyprint.Doc
import Data.Text.Prettyprint.Doc.Internal (unsafeTextWithoutNewlines)
import qualified Data.Text.Prettyprint.Doc.Render.Text as Render
#endif
import Language.Sexp.Types
import Language.Sexp.Token (escape)
instance Pretty Atom where
pretty :: Atom -> Doc ann
pretty = \case
AtomNumber Scientific
a
| Scientific -> Bool
isInteger Scientific
a -> String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Doc ann) -> String -> Doc ann
forall a b. (a -> b) -> a -> b
$ FPFormat -> Maybe Int -> Scientific -> String
formatScientific FPFormat
Fixed (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0) Scientific
a
| Bool
otherwise -> String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Doc ann) -> String -> Doc ann
forall a b. (a -> b) -> a -> b
$ FPFormat -> Maybe Int -> Scientific -> String
formatScientific FPFormat
Fixed Maybe Int
forall a. Maybe a
Nothing (Scientific -> String) -> Scientific -> String
forall a b. (a -> b) -> a -> b
$ Scientific
a
AtomString Text
a -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
dquotes (Text -> Doc ann
forall ann. Text -> Doc ann
unsafeTextWithoutNewlines (Text -> Doc ann) -> (Text -> Text) -> Text -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.toStrict (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
escape (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.fromStrict (Text -> Doc ann) -> Text -> Doc ann
forall a b. (a -> b) -> a -> b
$ Text
a)
AtomSymbol Text
a -> Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
a
ppList :: [(Fix SexpF, Doc ann)] -> Doc ann
ppList :: [(Fix SexpF, Doc ann)] -> Doc ann
ppList [(Fix SexpF, Doc ann)]
ls = case [(Fix SexpF, Doc ann)]
ls of
((Fix (AtomF Atom
_),Doc ann
_) : [(Fix SexpF, Doc ann)]
_) ->
Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
group (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
align (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
1 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ ((Fix SexpF, Doc ann) -> Doc ann)
-> [(Fix SexpF, Doc ann)] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map (Fix SexpF, Doc ann) -> Doc ann
forall a b. (a, b) -> b
snd [(Fix SexpF, Doc ann)]
ls
[(Fix SexpF, Doc ann)]
_other ->
Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
group (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
align (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ ((Fix SexpF, Doc ann) -> Doc ann)
-> [(Fix SexpF, Doc ann)] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map (Fix SexpF, Doc ann) -> Doc ann
forall a b. (a, b) -> b
snd [(Fix SexpF, Doc ann)]
ls
ppSexp :: Fix SexpF -> Doc ann
ppSexp :: Fix SexpF -> Doc ann
ppSexp = (Base (Fix SexpF) (Fix SexpF, Doc ann) -> Doc ann)
-> Fix SexpF -> Doc ann
forall t a. Recursive t => (Base t (t, a) -> a) -> t -> a
para ((Base (Fix SexpF) (Fix SexpF, Doc ann) -> Doc ann)
-> Fix SexpF -> Doc ann)
-> (Base (Fix SexpF) (Fix SexpF, Doc ann) -> Doc ann)
-> Fix SexpF
-> Doc ann
forall a b. (a -> b) -> a -> b
$ \case
AtomF a -> Atom -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Atom
a
ParenListF ss -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [(Fix SexpF, Doc ann)] -> Doc ann
forall ann. [(Fix SexpF, Doc ann)] -> Doc ann
ppList [(Fix SexpF, Doc ann)]
ss
BracketListF ss -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
brackets (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [(Fix SexpF, Doc ann)] -> Doc ann
forall ann. [(Fix SexpF, Doc ann)] -> Doc ann
ppList [(Fix SexpF, Doc ann)]
ss
BraceListF ss -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
braces (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [(Fix SexpF, Doc ann)] -> Doc ann
forall ann. [(Fix SexpF, Doc ann)] -> Doc ann
ppList [(Fix SexpF, Doc ann)]
ss
ModifiedF q a ->
case Prefix
q of
Prefix
Quote -> Doc ann
"'" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> (Fix SexpF, Doc ann) -> Doc ann
forall a b. (a, b) -> b
snd (Fix SexpF, Doc ann)
a
Prefix
Backtick -> Doc ann
"`" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> (Fix SexpF, Doc ann) -> Doc ann
forall a b. (a, b) -> b
snd (Fix SexpF, Doc ann)
a
Prefix
Comma -> Doc ann
"," Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> (Fix SexpF, Doc ann) -> Doc ann
forall a b. (a, b) -> b
snd (Fix SexpF, Doc ann)
a
Prefix
CommaAt -> Doc ann
",@" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> (Fix SexpF, Doc ann) -> Doc ann
forall a b. (a, b) -> b
snd (Fix SexpF, Doc ann)
a
Prefix
Hash -> Doc ann
"#" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> (Fix SexpF, Doc ann) -> Doc ann
forall a b. (a, b) -> b
snd (Fix SexpF, Doc ann)
a
instance Pretty (Fix SexpF) where
pretty :: Fix SexpF -> Doc ann
pretty = Fix SexpF -> Doc ann
forall ann. Fix SexpF -> Doc ann
ppSexp
format :: Fix SexpF -> ByteString
format :: Fix SexpF -> ByteString
format =
Text -> ByteString
encodeUtf8 (Text -> ByteString)
-> (Fix SexpF -> Text) -> Fix SexpF -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
SimpleDocStream Any -> Text
forall ann. SimpleDocStream ann -> Text
Render.renderLazy (SimpleDocStream Any -> Text)
-> (Fix SexpF -> SimpleDocStream Any) -> Fix SexpF -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
LayoutOptions -> Doc Any -> SimpleDocStream Any
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutSmart (PageWidth -> LayoutOptions
LayoutOptions (Int -> Double -> PageWidth
AvailablePerLine Int
79 Double
0.75)) (Doc Any -> SimpleDocStream Any)
-> (Fix SexpF -> Doc Any) -> Fix SexpF -> SimpleDocStream Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
Fix SexpF -> Doc Any
forall ann. Fix SexpF -> Doc ann
ppSexp