{-# 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

-- | Serialize a 'Sexp' into a pretty-printed string
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