{-# 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)
import Prettyprinter
import Prettyprinter.Internal (unsafeTextWithoutNewlines)
import qualified Prettyprinter.Render.Text as Render

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