{-# 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 :: forall ann. Atom -> Doc ann
pretty = \case
    AtomNumber Scientific
a
      | Scientific -> Bool
isInteger Scientific
a -> forall a ann. Pretty a => a -> Doc ann
pretty forall a b. (a -> b) -> a -> b
$ FPFormat -> Maybe Int -> Scientific -> String
formatScientific FPFormat
Fixed (forall a. a -> Maybe a
Just Int
0) Scientific
a
      | Bool
otherwise   -> forall a ann. Pretty a => a -> Doc ann
pretty forall a b. (a -> b) -> a -> b
$ FPFormat -> Maybe Int -> Scientific -> String
formatScientific FPFormat
Fixed forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ Scientific
a
    AtomString Text
a  -> forall ann. Doc ann -> Doc ann
dquotes (forall ann. Text -> Doc ann
unsafeTextWithoutNewlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
escape forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.fromStrict forall a b. (a -> b) -> a -> b
$ Text
a)
    AtomSymbol Text
a  -> forall a ann. Pretty a => a -> Doc ann
pretty Text
a

ppList :: [(Fix SexpF, Doc ann)] -> Doc ann
ppList :: forall ann. [(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)]
_) ->
    forall ann. Doc ann -> Doc ann
group forall a b. (a -> b) -> a -> b
$ forall ann. Doc ann -> Doc ann
align forall a b. (a -> b) -> a -> b
$ forall ann. Int -> Doc ann -> Doc ann
nest Int
1 forall a b. (a -> b) -> a -> b
$ forall ann. [Doc ann] -> Doc ann
vsep forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Fix SexpF, Doc ann)]
ls
  [(Fix SexpF, Doc ann)]
_other ->
    forall ann. Doc ann -> Doc ann
group forall a b. (a -> b) -> a -> b
$ forall ann. Doc ann -> Doc ann
align forall a b. (a -> b) -> a -> b
$ forall ann. [Doc ann] -> Doc ann
vsep forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Fix SexpF, Doc ann)]
ls

ppSexp :: Fix SexpF -> Doc ann
ppSexp :: forall ann. Fix SexpF -> Doc ann
ppSexp = forall t a. Recursive t => (Base t (t, a) -> a) -> t -> a
para forall a b. (a -> b) -> a -> b
$ \case
  AtomF Atom
a          -> forall a ann. Pretty a => a -> Doc ann
pretty Atom
a
  ParenListF [(Fix SexpF, Doc ann)]
ss    -> forall ann. Doc ann -> Doc ann
parens forall a b. (a -> b) -> a -> b
$ forall ann. [(Fix SexpF, Doc ann)] -> Doc ann
ppList [(Fix SexpF, Doc ann)]
ss
  BracketListF [(Fix SexpF, Doc ann)]
ss  -> forall ann. Doc ann -> Doc ann
brackets forall a b. (a -> b) -> a -> b
$ forall ann. [(Fix SexpF, Doc ann)] -> Doc ann
ppList [(Fix SexpF, Doc ann)]
ss
  BraceListF [(Fix SexpF, Doc ann)]
ss    -> forall ann. Doc ann -> Doc ann
braces forall a b. (a -> b) -> a -> b
$ forall ann. [(Fix SexpF, Doc ann)] -> Doc ann
ppList [(Fix SexpF, Doc ann)]
ss
  ModifiedF Prefix
q (Fix SexpF, Doc ann)
a    ->
    case Prefix
q of
      Prefix
Quote    -> Doc ann
"'"  forall a. Semigroup a => a -> a -> a
<> forall a b. (a, b) -> b
snd (Fix SexpF, Doc ann)
a
      Prefix
Backtick -> Doc ann
"`"  forall a. Semigroup a => a -> a -> a
<> forall a b. (a, b) -> b
snd (Fix SexpF, Doc ann)
a
      Prefix
Comma    -> Doc ann
","  forall a. Semigroup a => a -> a -> a
<> forall a b. (a, b) -> b
snd (Fix SexpF, Doc ann)
a
      Prefix
CommaAt  -> Doc ann
",@" forall a. Semigroup a => a -> a -> a
<> forall a b. (a, b) -> b
snd (Fix SexpF, Doc ann)
a
      Prefix
Hash     -> Doc ann
"#"  forall a. Semigroup a => a -> a -> a
<> forall a b. (a, b) -> b
snd (Fix SexpF, Doc ann)
a

instance Pretty (Fix SexpF) where
  pretty :: forall ann. Fix SexpF -> Doc ann
pretty = 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    forall ann. SimpleDocStream ann -> Text
Render.renderLazy forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutSmart (PageWidth -> LayoutOptions
LayoutOptions (Int -> Double -> PageWidth
AvailablePerLine Int
79 Double
0.75)) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        forall ann. Fix SexpF -> Doc ann
ppSexp