{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module KDL.Render (
  render,

  -- * Rendering components
  renderValue,
  renderValueData,
  renderIdentifier,
) where

import Data.Char (isDigit)
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Data.Text qualified as Text
import KDL.Types (
  Ann (..),
  AnnExtension (..),
  AnnFormat (..),
  Document,
  Entry (..),
  EntryExtension (..),
  EntryFormat (..),
  Identifier (..),
  IdentifierExtension (..),
  IdentifierFormat (..),
  Node (..),
  NodeExtension (..),
  NodeFormat (..),
  NodeList (..),
  NodeListExtension (..),
  NodeListFormat (..),
  Value (..),
  ValueData (..),
  ValueExtension (..),
  ValueFormat (..),
 )

render :: Document -> Text
render :: NodeList -> Text
render = IndentLevel -> NodeList -> Text
renderNodeList IndentLevel
0

type IndentLevel = Int

renderNodeList :: IndentLevel -> NodeList -> Text
renderNodeList :: IndentLevel -> NodeList -> Text
renderNodeList IndentLevel
lvl NodeList{[Node]
NodeListExtension
nodes :: [Node]
ext :: NodeListExtension
ext :: NodeList -> NodeListExtension
nodes :: NodeList -> [Node]
..} =
  [Text] -> Text
Text.concat
    [ Text -> (NodeListFormat -> Text) -> Maybe NodeListFormat -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (if IndentLevel
lvl IndentLevel -> IndentLevel -> Bool
forall a. Ord a => a -> a -> Bool
> IndentLevel
0 then Text
"\n" else Text
"") (.leading) NodeListExtension
ext.format
    , (Node -> Text) -> [Node] -> Text
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (IndentLevel -> Node -> Text
renderNode IndentLevel
lvl) [Node]
nodes
    , Text -> (NodeListFormat -> Text) -> Maybe NodeListFormat -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (IndentLevel -> Text
indent (IndentLevel
lvl IndentLevel -> IndentLevel -> IndentLevel
forall a. Num a => a -> a -> a
- IndentLevel
1)) (.trailing) NodeListExtension
ext.format
    ]

renderNode :: IndentLevel -> Node -> Text
renderNode :: IndentLevel -> Node -> Text
renderNode IndentLevel
lvl Node{[Entry]
Maybe Ann
Maybe NodeList
Identifier
NodeExtension
ann :: Maybe Ann
name :: Identifier
entries :: [Entry]
children :: Maybe NodeList
ext :: NodeExtension
ext :: Node -> NodeExtension
children :: Node -> Maybe NodeList
entries :: Node -> [Entry]
name :: Node -> Identifier
ann :: Node -> Maybe Ann
..} =
  [Text] -> Text
Text.concat
    [ Text -> (NodeFormat -> Text) -> Maybe NodeFormat -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (IndentLevel -> Text
indent IndentLevel
lvl) (.leading) NodeExtension
ext.format
    , Text -> (Ann -> Text) -> Maybe Ann -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" Ann -> Text
renderAnn Maybe Ann
ann
    , Identifier -> Text
renderIdentifier Identifier
name
    , (Entry -> Text) -> [Entry] -> Text
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Entry -> Text
renderEntry [Entry]
entries
    , let def_ :: Text
def_ = if Maybe NodeList
children Maybe NodeList -> Maybe NodeList -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe NodeList
forall a. Maybe a
Nothing then Text
"" else Text
" "
       in Text -> (NodeFormat -> Text) -> Maybe NodeFormat -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
def_ (.beforeChildren) NodeExtension
ext.format
    , case Maybe NodeList
children of
        Maybe NodeList
Nothing -> Text
""
        Just NodeList
nodes -> IndentLevel -> NodeList -> Text
renderChildren IndentLevel
lvl NodeList
nodes
    , Text -> (NodeFormat -> Text) -> Maybe NodeFormat -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" (.beforeTerminator) NodeExtension
ext.format
    , Text -> (NodeFormat -> Text) -> Maybe NodeFormat -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"\n" (.terminator) NodeExtension
ext.format
    , Text -> (NodeFormat -> Text) -> Maybe NodeFormat -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" (.trailing) NodeExtension
ext.format
    ]

renderChildren :: IndentLevel -> NodeList -> Text
renderChildren :: IndentLevel -> NodeList -> Text
renderChildren IndentLevel
lvl NodeList
nodeList =
  case NodeList
nodeList.ext.format of
    -- Special case empty node list to render as "{}"
    Maybe NodeListFormat
Nothing | [Node] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null NodeList
nodeList.nodes -> Text
"{}"
    Maybe NodeListFormat
_ -> Text
"{" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> IndentLevel -> NodeList -> Text
renderNodeList (IndentLevel
lvl IndentLevel -> IndentLevel -> IndentLevel
forall a. Num a => a -> a -> a
+ IndentLevel
1) NodeList
nodeList Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"}"

indent :: IndentLevel -> Text
indent :: IndentLevel -> Text
indent IndentLevel
lvl = IndentLevel -> Text -> Text
Text.replicate IndentLevel
lvl Text
"  "

renderEntry :: Entry -> Text
renderEntry :: Entry -> Text
renderEntry Entry{Maybe Identifier
Value
EntryExtension
name :: Maybe Identifier
value :: Value
ext :: EntryExtension
ext :: Entry -> EntryExtension
value :: Entry -> Value
name :: Entry -> Maybe Identifier
..} =
  [Text] -> Text
Text.concat
    [ Text -> (EntryFormat -> Text) -> Maybe EntryFormat -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
" " (.leading) EntryExtension
ext.format
    , case Maybe Identifier
name of
        Maybe Identifier
Nothing -> Value -> Text
renderValue Value
value
        Just Identifier
nameId ->
          [Text] -> Text
Text.concat
            [ Identifier -> Text
renderIdentifier Identifier
nameId
            , Text -> (EntryFormat -> Text) -> Maybe EntryFormat -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" (.afterKey) EntryExtension
ext.format
            , Text
"="
            , Text -> (EntryFormat -> Text) -> Maybe EntryFormat -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" (.afterEq) EntryExtension
ext.format
            , Value -> Text
renderValue Value
value
            ]
    , Text -> (EntryFormat -> Text) -> Maybe EntryFormat -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" (.trailing) EntryExtension
ext.format
    ]

renderAnn :: Ann -> Text
renderAnn :: Ann -> Text
renderAnn Ann{Identifier
AnnExtension
identifier :: Identifier
ext :: AnnExtension
ext :: Ann -> AnnExtension
identifier :: Ann -> Identifier
..} =
  [Text] -> Text
Text.concat
    [ Text -> (AnnFormat -> Text) -> Maybe AnnFormat -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" (.leading) AnnExtension
ext.format
    , Text
"("
    , Text -> (AnnFormat -> Text) -> Maybe AnnFormat -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" (.beforeId) AnnExtension
ext.format
    , Identifier -> Text
renderIdentifier Identifier
identifier
    , Text -> (AnnFormat -> Text) -> Maybe AnnFormat -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" (.afterId) AnnExtension
ext.format
    , Text
")"
    , Text -> (AnnFormat -> Text) -> Maybe AnnFormat -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" (.trailing) AnnExtension
ext.format
    ]

renderValue :: Value -> Text
renderValue :: Value -> Text
renderValue Value{Maybe Ann
ValueData
ValueExtension
ann :: Maybe Ann
data_ :: ValueData
ext :: ValueExtension
ext :: Value -> ValueExtension
data_ :: Value -> ValueData
ann :: Value -> Maybe Ann
..} =
  [Text] -> Text
Text.concat
    [ Text -> (Ann -> Text) -> Maybe Ann -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" Ann -> Text
renderAnn Maybe Ann
ann
    , Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe (ValueData -> Text
renderValueData ValueData
data_) (ValueExtension
ext.format Maybe ValueFormat -> (ValueFormat -> Maybe Text) -> Maybe Text
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (.repr))
    ]

renderValueData :: ValueData -> Text
renderValueData :: ValueData -> Text
renderValueData = \case
  String Text
s -> Text -> Text
renderString Text
s
  Number Scientific
x -> (String -> Text
Text.pack (String -> Text) -> (Scientific -> String) -> Scientific -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scientific -> String
forall a. Show a => a -> String
show) Scientific
x
  Bool Bool
b -> if Bool
b then Text
"#true" else Text
"#false"
  ValueData
Inf -> Text
"#inf"
  ValueData
NegInf -> Text
"#-inf"
  ValueData
NaN -> Text
"#nan"
  ValueData
Null -> Text
"#null"
 where
  renderString :: Text -> Text
renderString Text
s = if Text -> Bool
isPlainIdent Text
s then Text
s else Text
"\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Char -> Text) -> Text -> Text
Text.concatMap Char -> Text
escapeChar Text
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\""
  isPlainIdent :: Text -> Bool
isPlainIdent Text
s =
    [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> ([Bool] -> [Bool]) -> [Bool] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Bool) -> [Bool] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map Bool -> Bool
not ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$
      [ (Char -> Bool) -> Text -> Bool
Text.any Char -> Bool
isDisallowedChar Text
s
      , case (Text -> Maybe (Char, Text))
-> (Char, Text) -> (Char, Maybe (Char, Text))
forall a b. (a -> b) -> (Char, a) -> (Char, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Maybe (Char, Text)
Text.uncons ((Char, Text) -> (Char, Maybe (Char, Text)))
-> Maybe (Char, Text) -> Maybe (Char, Maybe (Char, Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe (Char, Text)
Text.uncons Text
s of
          Just (Char
c, Maybe (Char, Text)
_) | Char -> Bool
isDigit Char
c -> Bool
True
          Just (Char
c0, Just (Char
c1, Text
_))
            | Char
c0 Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'.', Char
'-', Char
'+']
            , Char -> Bool
isDigit Char
c1 ->
                Bool
True
          Maybe (Char, Maybe (Char, Text))
_ -> Bool
False
      , Text
s Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"inf", Text
"-inf", Text
"nan", Text
"true", Text
"false", Text
"null"]
      ]
  isDisallowedChar :: Char -> Bool
isDisallowedChar Char
c =
    [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or
      [ Char
c Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
disallowedIdentChars
      , (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Char
c `Text.elem`) [Text]
newlines
      , Char
c Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
unicodeSpaces
      , Char -> Bool
isDisallowedUnicode Char
c
      , Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'='
      ]
  disallowedIdentChars :: String
disallowedIdentChars = [Char
'\\', Char
'/', Char
'(', Char
')', Char
'{', Char
'}', Char
'[', Char
']', Char
';', Char
'"', Char
'#']
  newlines :: [Text]
newlines =
    [ Text
"\x000D\x000A"
    , Text
"\x000D"
    , Text
"\x000A"
    , Text
"\x0085"
    , Text
"\x000B"
    , Text
"\x000C"
    , Text
"\x2028"
    , Text
"\x2029"
    ]
  unicodeSpaces :: String
unicodeSpaces =
    [ Char
'\x0009'
    , Char
'\x0020'
    , Char
'\x00A0'
    , Char
'\x1680'
    , Char
'\x2000'
    , Char
'\x2001'
    , Char
'\x2002'
    , Char
'\x2003'
    , Char
'\x2004'
    , Char
'\x2005'
    , Char
'\x2006'
    , Char
'\x2007'
    , Char
'\x2008'
    , Char
'\x2009'
    , Char
'\x200A'
    , Char
'\x202F'
    , Char
'\x205F'
    , Char
'\x3000'
    ]
  isDisallowedUnicode :: Char -> Bool
isDisallowedUnicode Char
c =
    [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or
      [ Char
'\x0000' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
< Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\x0008'
      , Char
'\x000E' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
< Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\x001F'
      , Char
'\x200E' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
< Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\x200F'
      , Char
'\x202A' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
< Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\x202E'
      , Char
'\x2066' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
< Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\x2069'
      , Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\xFEFF'
      ]
  escapeChar :: Char -> Text
escapeChar = \case
    Char
'\\' -> Text
"\\\\"
    Char
'"' -> Text
"\\\""
    Char
'\n' -> Text
"\\n"
    Char
'\r' -> Text
"\\r"
    Char
'\t' -> Text
"\\t"
    Char
'\x08' -> Text
"\\b"
    Char
'\x0C' -> Text
"\\f"
    Char
c -> Char -> Text
Text.singleton Char
c

renderIdentifier :: Identifier -> Text
renderIdentifier :: Identifier -> Text
renderIdentifier Identifier
ident = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Identifier
ident.value (Identifier
ident.ext.format Maybe IdentifierFormat
-> (IdentifierFormat -> Maybe Text) -> Maybe Text
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (.repr))