{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

module Data.EDN.AST.Printer
  ( renderText
  , prettyTaggedValue
  , prettyValue
  ) where

import Data.Char (ord)
import Data.Foldable (toList)
#if MIN_VERSION_base(4,13,0)
#else
import Data.Semigroup ((<>))
#endif
import Data.Text (Text)
import Text.Printf (printf)

import qualified Data.Map as Map
import qualified Data.Text as Text
#if MIN_VERSION_prettyprinter(1,7,1)
import Prettyprinter (Doc, pretty, (<+>))
import qualified Prettyprinter as PP
import qualified Prettyprinter.Render.Text as PP
#else
import Data.Text.Prettyprint.Doc (Doc, pretty, (<+>))
import qualified Data.Text.Prettyprint.Doc as PP
import qualified Data.Text.Prettyprint.Doc.Render.Text as PP
#endif

import qualified Data.EDN.AST.Types as EDN

-- | Render EDN document to 'Text'
renderText :: EDN.TaggedValue -> Text
renderText :: TaggedValue -> Text
renderText =
  SimpleDocStream Any -> Text
forall ann. SimpleDocStream ann -> Text
PP.renderStrict (SimpleDocStream Any -> Text)
-> (TaggedValue -> SimpleDocStream Any) -> TaggedValue -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayoutOptions -> Doc Any -> SimpleDocStream Any
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
PP.layoutPretty LayoutOptions
options (Doc Any -> SimpleDocStream Any)
-> (TaggedValue -> Doc Any) -> TaggedValue -> SimpleDocStream Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TaggedValue -> Doc Any
forall a. TaggedValue -> Doc a
prettyTaggedValue
  where
    options :: LayoutOptions
options = LayoutOptions
PP.defaultLayoutOptions

-- | Prepare 'EDN.TaggedValue'
prettyTaggedValue :: EDN.TaggedValue -> Doc a
prettyTaggedValue :: TaggedValue -> Doc a
prettyTaggedValue = \case
  EDN.Tagged Text
"" Text
tag Value
value ->
    Doc a
"#" Doc a -> Doc a -> Doc a
forall a. Semigroup a => a -> a -> a
<> Text -> Doc a
forall a ann. Pretty a => a -> Doc ann
pretty Text
tag Doc a -> Doc a -> Doc a
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Value -> Doc a
forall a. Value -> Doc a
prettyValue Value
value
  EDN.Tagged Text
ns Text
tag Value
value ->
    Doc a
"#" Doc a -> Doc a -> Doc a
forall a. Semigroup a => a -> a -> a
<> Text -> Doc a
forall a ann. Pretty a => a -> Doc ann
pretty Text
ns Doc a -> Doc a -> Doc a
forall a. Semigroup a => a -> a -> a
<> Doc a
"/" Doc a -> Doc a -> Doc a
forall a. Semigroup a => a -> a -> a
<> Text -> Doc a
forall a ann. Pretty a => a -> Doc ann
pretty Text
tag Doc a -> Doc a -> Doc a
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Value -> Doc a
forall a. Value -> Doc a
prettyValue Value
value
  EDN.NoTag Value
value ->
    Value -> Doc a
forall a. Value -> Doc a
prettyValue Value
value

-- | Prepare 'EDN.Value'
prettyValue :: EDN.Value -> Doc a
prettyValue :: Value -> Doc a
prettyValue = FusionDepth -> Doc a -> Doc a
forall ann. FusionDepth -> Doc ann -> Doc ann
PP.fuse FusionDepth
PP.Shallow (Doc a -> Doc a) -> (Value -> Doc a) -> Value -> Doc a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
  Value
EDN.Nil ->
    Doc a
"nil"
  EDN.Boolean Bool
bool ->
    if Bool
bool then Doc a
"true" else Doc a
"false"
  EDN.Character Char
char ->
    Doc a -> Doc a -> Doc a
forall a. Monoid a => a -> a -> a
mappend Doc a
"\\" (Doc a -> Doc a) -> Doc a -> Doc a
forall a b. (a -> b) -> a -> b
$ case Char
char of
      Char
'\n' -> Doc a
"newline"
      Char
'\t' -> Doc a
"tab"
      Char
'\r' -> Doc a
"return"
      Char
' '  -> Doc a
"space"
      Char
_ ->
        case Char -> String
forall a. Show a => a -> String
show Char
char of
          Char
'\'' : Char
'\\' : String
_ ->
            String -> Doc a
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Int -> String
forall r. PrintfType r => String -> r
printf String
"u%04X" (Char -> Int
ord Char
char) :: String)
          String
_ ->
            Char -> Doc a
forall a ann. Pretty a => a -> Doc ann
pretty Char
char
  EDN.Symbol Text
"" Text
name ->
    Text -> Doc a
forall a ann. Pretty a => a -> Doc ann
pretty Text
name
  EDN.Symbol Text
ns Text
name ->
    Text -> Doc a
forall a ann. Pretty a => a -> Doc ann
pretty Text
ns Doc a -> Doc a -> Doc a
forall a. Semigroup a => a -> a -> a
<> Doc a
"/" Doc a -> Doc a -> Doc a
forall a. Semigroup a => a -> a -> a
<> Text -> Doc a
forall a ann. Pretty a => a -> Doc ann
pretty Text
name
  EDN.Keyword Text
ident ->
    Doc a
":" Doc a -> Doc a -> Doc a
forall a. Semigroup a => a -> a -> a
<> Text -> Doc a
forall a ann. Pretty a => a -> Doc ann
pretty Text
ident
  EDN.Integer Int
int ->
    Int -> Doc a
forall a ann. Pretty a => a -> Doc ann
pretty Int
int
  EDN.Floating Double
double ->
    Double -> Doc a
forall a ann. Pretty a => a -> Doc ann
pretty Double
double
  EDN.String Text
str ->
    Doc a -> Doc a -> Doc a -> Doc a
forall ann. Doc ann -> Doc ann -> Doc ann -> Doc ann
PP.enclose Doc a
"\"" Doc a
"\"" (Doc a -> Doc a) -> (Text -> Doc a) -> Text -> Doc a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Doc a
forall a ann. Pretty a => a -> Doc ann
pretty (Text -> Doc a) -> Text -> Doc a
forall a b. (a -> b) -> a -> b
$ Text -> Text
escapeText Text
str
  EDN.List EDNList
items ->
    Doc a -> Doc a
forall ann. Doc ann -> Doc ann
PP.parens (Doc a -> Doc a) -> ([Doc a] -> Doc a) -> [Doc a] -> Doc a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc a] -> Doc a
forall ann. [Doc ann] -> Doc ann
PP.hsep ([Doc a] -> Doc a) -> [Doc a] -> Doc a
forall a b. (a -> b) -> a -> b
$
      (TaggedValue -> Doc a) -> EDNList -> [Doc a]
forall a b. (a -> b) -> [a] -> [b]
map TaggedValue -> Doc a
forall a. TaggedValue -> Doc a
prettyTaggedValue EDNList
items
  EDN.Vec EDNVec
items ->
    Doc a -> Doc a
forall ann. Doc ann -> Doc ann
PP.brackets (Doc a -> Doc a) -> ([Doc a] -> Doc a) -> [Doc a] -> Doc a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc a] -> Doc a
forall ann. [Doc ann] -> Doc ann
PP.hsep ([Doc a] -> Doc a) -> [Doc a] -> Doc a
forall a b. (a -> b) -> a -> b
$
      (TaggedValue -> Doc a) -> EDNList -> [Doc a]
forall a b. (a -> b) -> [a] -> [b]
map TaggedValue -> Doc a
forall a. TaggedValue -> Doc a
prettyTaggedValue (EDNVec -> EDNList
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList EDNVec
items)
  EDN.Set EDNSet
items ->
    Doc a -> Doc a -> Doc a
forall a. Monoid a => a -> a -> a
mappend Doc a
"#" (Doc a -> Doc a) -> ([Doc a] -> Doc a) -> [Doc a] -> Doc a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc a -> Doc a
forall ann. Doc ann -> Doc ann
PP.braces (Doc a -> Doc a) -> ([Doc a] -> Doc a) -> [Doc a] -> Doc a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc a] -> Doc a
forall ann. [Doc ann] -> Doc ann
PP.hsep ([Doc a] -> Doc a) -> [Doc a] -> Doc a
forall a b. (a -> b) -> a -> b
$
      (TaggedValue -> Doc a) -> EDNList -> [Doc a]
forall a b. (a -> b) -> [a] -> [b]
map TaggedValue -> Doc a
forall a. TaggedValue -> Doc a
prettyTaggedValue (EDNSet -> EDNList
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList EDNSet
items)
  EDN.Map EDNMap
pairs ->
    Doc a -> Doc a
forall ann. Doc ann -> Doc ann
PP.braces (Doc a -> Doc a) -> ([Doc a] -> Doc a) -> [Doc a] -> Doc a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc a] -> Doc a
forall ann. [Doc ann] -> Doc ann
PP.hsep ([Doc a] -> Doc a) -> [Doc a] -> Doc a
forall a b. (a -> b) -> a -> b
$
      [ TaggedValue -> Doc a
forall a. TaggedValue -> Doc a
prettyTaggedValue TaggedValue
k Doc a -> Doc a -> Doc a
forall ann. Doc ann -> Doc ann -> Doc ann
<+> TaggedValue -> Doc a
forall a. TaggedValue -> Doc a
prettyTaggedValue TaggedValue
v
      | (TaggedValue
k, TaggedValue
v) <- EDNMap -> [(TaggedValue, TaggedValue)]
forall k a. Map k a -> [(k, a)]
Map.toList EDNMap
pairs
      ]

escapeText :: Text -> Text
escapeText :: Text -> Text
escapeText = (Char -> Text) -> Text -> Text
Text.concatMap Char -> Text
escape
  where
    escape :: Char -> Text
escape = \case
      Char
'\n' -> Text
"\\n"
      Char
'\r' -> Text
"\\r"
      Char
'\t' -> Text
"\\t"
      Char
'"'  -> Text
"\\\""
      Char
c    -> Char -> Text
Text.singleton Char
c