{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE FlexibleInstances #-}

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

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