{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE OverloadedStrings #-}
-----------------------------------------------------------------------------
-- Based on Text.XML.Prettify by David M. Rosenberg
-- Copyright    : (c) 2010 David M. Rosenberg
-- License      : BSD3
-----------------------------------------------------------------------------
-- Module        :  Text.XML.Prettify
--
-- Maintained by :  Marc Jakobi, 2021-09-09
-- Modifications:
--                 - Update to Haskell 2010
--                 - Replace String with Data.Text
--                 - Encapsulate internals of module
--                 - Tweak performance
--
-- License       :  GPL2
--
-- Description   :  Pretty-print XML Text
-----------------------------------------------------------------------------
{-# LANGUAGE NoImplicitPrelude #-}

module Text.XML.Prettify
  ( XmlText,
    prettyPrintXml,
    prettyPrintXmlDefault,
    module Text.XML.Prettify.Options,
  )
where

import Control.Monad.Reader
import Data.Char (isSpace)
import qualified Data.Text as T
import Text.XML.Prettify.Options
import TextShow
import Prelude

type Prettify = Reader PrettifyOpts

-- | Pretty-print an XML text with the default options:
-- EndOfLine: LF
-- Indent style: 2 spaces
-- Returns: The pretty-printed XML
prettyPrintXmlDefault :: XmlText -> XmlText
prettyPrintXmlDefault :: XmlText -> XmlText
prettyPrintXmlDefault =
  PrettifyOpts -> XmlText -> XmlText
prettyPrintXml
    PrettifyOpts :: IndentStyle -> EndOfLine -> PrettifyOpts
PrettifyOpts
      { endOfLine :: EndOfLine
endOfLine = EndOfLine
LF,
        indentStyle :: IndentStyle
indentStyle = Int -> IndentStyle
SPACE Int
2
      }

-- | Pretty-print an XML text
-- opts: The output options
-- xmlText: xml text (e.g. on one line)
-- Returnms: The pretty-printed XML
prettyPrintXml :: PrettifyOpts -> XmlText -> XmlText
prettyPrintXml :: PrettifyOpts -> XmlText -> XmlText
prettyPrintXml PrettifyOpts
opts XmlText
xmlText = Reader PrettifyOpts XmlText -> PrettifyOpts -> XmlText
forall r a. Reader r a -> r -> a
runReader ([XmlTag] -> Reader PrettifyOpts XmlText
printAllTags [XmlTag]
tags) PrettifyOpts
opts
  where
    tags :: [XmlTag]
tags = XmlText -> [XmlTag]
inputToTags (XmlText -> [XmlTag]) -> XmlText -> [XmlTag]
forall a b. (a -> b) -> a -> b
$ [XmlText] -> XmlText
T.concat ([XmlText] -> XmlText) -> [XmlText] -> XmlText
forall a b. (a -> b) -> a -> b
$ XmlText -> [XmlText]
T.lines XmlText
xmlText

data TagType = IncTagType | DecTagType | StandaloneTagType
  deriving stock (Eq TagType
Eq TagType
-> (TagType -> TagType -> Ordering)
-> (TagType -> TagType -> Bool)
-> (TagType -> TagType -> Bool)
-> (TagType -> TagType -> Bool)
-> (TagType -> TagType -> Bool)
-> (TagType -> TagType -> TagType)
-> (TagType -> TagType -> TagType)
-> Ord TagType
TagType -> TagType -> Bool
TagType -> TagType -> Ordering
TagType -> TagType -> TagType
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: TagType -> TagType -> TagType
$cmin :: TagType -> TagType -> TagType
max :: TagType -> TagType -> TagType
$cmax :: TagType -> TagType -> TagType
>= :: TagType -> TagType -> Bool
$c>= :: TagType -> TagType -> Bool
> :: TagType -> TagType -> Bool
$c> :: TagType -> TagType -> Bool
<= :: TagType -> TagType -> Bool
$c<= :: TagType -> TagType -> Bool
< :: TagType -> TagType -> Bool
$c< :: TagType -> TagType -> Bool
compare :: TagType -> TagType -> Ordering
$ccompare :: TagType -> TagType -> Ordering
$cp1Ord :: Eq TagType
Ord, TagType -> TagType -> Bool
(TagType -> TagType -> Bool)
-> (TagType -> TagType -> Bool) -> Eq TagType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TagType -> TagType -> Bool
$c/= :: TagType -> TagType -> Bool
== :: TagType -> TagType -> Bool
$c== :: TagType -> TagType -> Bool
Eq, Int -> TagType
TagType -> Int
TagType -> [TagType]
TagType -> TagType
TagType -> TagType -> [TagType]
TagType -> TagType -> TagType -> [TagType]
(TagType -> TagType)
-> (TagType -> TagType)
-> (Int -> TagType)
-> (TagType -> Int)
-> (TagType -> [TagType])
-> (TagType -> TagType -> [TagType])
-> (TagType -> TagType -> [TagType])
-> (TagType -> TagType -> TagType -> [TagType])
-> Enum TagType
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: TagType -> TagType -> TagType -> [TagType]
$cenumFromThenTo :: TagType -> TagType -> TagType -> [TagType]
enumFromTo :: TagType -> TagType -> [TagType]
$cenumFromTo :: TagType -> TagType -> [TagType]
enumFromThen :: TagType -> TagType -> [TagType]
$cenumFromThen :: TagType -> TagType -> [TagType]
enumFrom :: TagType -> [TagType]
$cenumFrom :: TagType -> [TagType]
fromEnum :: TagType -> Int
$cfromEnum :: TagType -> Int
toEnum :: Int -> TagType
$ctoEnum :: Int -> TagType
pred :: TagType -> TagType
$cpred :: TagType -> TagType
succ :: TagType -> TagType
$csucc :: TagType -> TagType
Enum)

type XmlText = T.Text

type TagContent = T.Text

type OneLineXmlText = XmlText

data XmlTag = XmlTag TagContent TagType
  deriving stock (Eq XmlTag
Eq XmlTag
-> (XmlTag -> XmlTag -> Ordering)
-> (XmlTag -> XmlTag -> Bool)
-> (XmlTag -> XmlTag -> Bool)
-> (XmlTag -> XmlTag -> Bool)
-> (XmlTag -> XmlTag -> Bool)
-> (XmlTag -> XmlTag -> XmlTag)
-> (XmlTag -> XmlTag -> XmlTag)
-> Ord XmlTag
XmlTag -> XmlTag -> Bool
XmlTag -> XmlTag -> Ordering
XmlTag -> XmlTag -> XmlTag
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: XmlTag -> XmlTag -> XmlTag
$cmin :: XmlTag -> XmlTag -> XmlTag
max :: XmlTag -> XmlTag -> XmlTag
$cmax :: XmlTag -> XmlTag -> XmlTag
>= :: XmlTag -> XmlTag -> Bool
$c>= :: XmlTag -> XmlTag -> Bool
> :: XmlTag -> XmlTag -> Bool
$c> :: XmlTag -> XmlTag -> Bool
<= :: XmlTag -> XmlTag -> Bool
$c<= :: XmlTag -> XmlTag -> Bool
< :: XmlTag -> XmlTag -> Bool
$c< :: XmlTag -> XmlTag -> Bool
compare :: XmlTag -> XmlTag -> Ordering
$ccompare :: XmlTag -> XmlTag -> Ordering
$cp1Ord :: Eq XmlTag
Ord, XmlTag -> XmlTag -> Bool
(XmlTag -> XmlTag -> Bool)
-> (XmlTag -> XmlTag -> Bool) -> Eq XmlTag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: XmlTag -> XmlTag -> Bool
$c/= :: XmlTag -> XmlTag -> Bool
== :: XmlTag -> XmlTag -> Bool
$c== :: XmlTag -> XmlTag -> Bool
Eq)

inputToTags :: OneLineXmlText -> [XmlTag]
inputToTags :: XmlText -> [XmlTag]
inputToTags XmlText
"" = []
inputToTags XmlText
xmlText = XmlTag
xtag XmlTag -> [XmlTag] -> [XmlTag]
forall a. a -> [a] -> [a]
: XmlText -> [XmlTag]
inputToTags XmlText
xmlText'
  where
    (XmlTag
xtag, XmlText
xmlText') = XmlText -> (XmlTag, XmlText)
lexOne XmlText
xmlText

lexOne :: OneLineXmlText -> (XmlTag, OneLineXmlText)
lexOne :: XmlText -> (XmlTag, XmlText)
lexOne XmlText
xmlText = case Char
nextCharacter of
  Char
' ' -> (XmlText -> TagType -> XmlTag
XmlTag XmlText
"" TagType
StandaloneTagType, XmlText
"")
  Char
'<' -> XmlText -> (XmlTag, XmlText)
lexOneTag XmlText
xmlText
  Char
_ -> XmlText -> (XmlTag, XmlText)
lexNonTagged XmlText
xmlText
  where
    nextWord :: XmlText
nextWord = XmlText -> XmlText
getWord XmlText
xmlText
    nextCharacter :: Char
nextCharacter = XmlText -> Char
T.head (XmlText -> Char) -> XmlText -> Char
forall a b. (a -> b) -> a -> b
$ XmlText
nextWord XmlText -> XmlText -> XmlText
forall a. Semigroup a => a -> a -> a
<> XmlText
" "

lexNonTagged :: OneLineXmlText -> (XmlTag, OneLineXmlText)
lexNonTagged :: XmlText -> (XmlTag, XmlText)
lexNonTagged XmlText
xmlText = (XmlText -> TagType -> XmlTag
XmlTag XmlText
tagContent TagType
tagType, XmlText
remaining)
  where
    nextWord :: XmlText
nextWord = XmlText -> XmlText
getWord XmlText
xmlText
    (XmlText
tagContent, XmlText
remaining) = (Char -> Bool) -> XmlText -> (XmlText, XmlText)
T.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'<') XmlText
nextWord
    tagType :: TagType
tagType = TagType
StandaloneTagType

getWord :: T.Text -> T.Text
getWord :: XmlText -> XmlText
getWord = (Char -> Bool) -> XmlText -> XmlText
T.dropWhile Char -> Bool
isSpace

lexOneTag :: OneLineXmlText -> (XmlTag, OneLineXmlText)
lexOneTag :: XmlText -> (XmlTag, XmlText)
lexOneTag XmlText
xmlText = (XmlText -> TagType -> XmlTag
XmlTag XmlText
tagContent TagType
tagType, XmlText
res)
  where
    afterTagStart :: XmlText
afterTagStart = (Char -> Bool) -> XmlText -> XmlText
T.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'<') XmlText
xmlText
    (XmlText
tagContent', XmlText
remaining) = (Char -> Bool) -> XmlText -> (XmlText, XmlText)
T.span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'>') XmlText
afterTagStart
    tagContent :: XmlText
tagContent = XmlText
tagContent' XmlText -> XmlText -> XmlText
forall a. Semigroup a => a -> a -> a
<> (Char -> XmlText
T.singleton (Char -> XmlText) -> (XmlText -> Char) -> XmlText -> XmlText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmlText -> Char
T.head) XmlText
remaining
    res :: XmlText
res = XmlText -> XmlText
T.tail XmlText
remaining
    tagType :: TagType
tagType = case (XmlText -> Int -> Char
T.index XmlText
tagContent Int
1, XmlText -> Int -> Char
T.index XmlText
tagContent (XmlText -> Int
T.length XmlText
tagContent Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2)) of
      (Char
'/', Char
_) -> TagType
DecTagType
      (Char
_, Char
'/') -> TagType
StandaloneTagType
      (Char
'!', Char
_) -> TagType
StandaloneTagType
      (Char
'?', Char
_) -> TagType
StandaloneTagType
      (Char
_, Char
_) -> TagType
IncTagType

printTag :: Int -> XmlTag -> Prettify (Int, XmlText)
printTag :: Int -> XmlTag -> Prettify (Int, XmlText)
printTag Int
tagIdent (XmlTag XmlText
content TagType
tagType) = do
  IndentStyle
identStyle <- (PrettifyOpts -> IndentStyle)
-> ReaderT PrettifyOpts Identity IndentStyle
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PrettifyOpts -> IndentStyle
indentStyle
  let identText :: XmlText
identText = IndentStyle -> XmlText
forall a. TextShow a => a -> XmlText
showt IndentStyle
identStyle
  let (Int
contentIdent, Int
nextTagIdent) = case TagType
tagType of
        TagType
IncTagType -> (Int
tagIdent, Int
tagIdent Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
        TagType
DecTagType -> (Int
tagIdent Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1, Int
tagIdent Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
        TagType
_ -> (Int
tagIdent, Int
tagIdent)
  let outText :: XmlText
outText = Int -> XmlText -> XmlText
T.replicate Int
contentIdent XmlText
identText XmlText -> XmlText -> XmlText
forall a. Semigroup a => a -> a -> a
<> XmlText
content
  (Int, XmlText) -> Prettify (Int, XmlText)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
nextTagIdent, XmlText
outText)

printAllTags :: [XmlTag] -> Prettify XmlText
printAllTags :: [XmlTag] -> Reader PrettifyOpts XmlText
printAllTags = Int -> [XmlTag] -> Reader PrettifyOpts XmlText
printTags Int
0

printTags :: Int -> [XmlTag] -> Prettify XmlText
printTags :: Int -> [XmlTag] -> Reader PrettifyOpts XmlText
printTags Int
_ [] = XmlText -> Reader PrettifyOpts XmlText
forall (f :: * -> *) a. Applicative f => a -> f a
pure XmlText
""
printTags Int
ident (XmlTag
tag : [XmlTag]
tags) = do
  EndOfLine
eol <- (PrettifyOpts -> EndOfLine)
-> ReaderT PrettifyOpts Identity EndOfLine
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PrettifyOpts -> EndOfLine
endOfLine
  (Int
nextTagIdent, XmlText
tagText) <- Int -> XmlTag -> Prettify (Int, XmlText)
printTag Int
ident XmlTag
tag
  XmlText
remainingTagText <- Int -> [XmlTag] -> Reader PrettifyOpts XmlText
printTags Int
nextTagIdent [XmlTag]
tags
  XmlText -> Reader PrettifyOpts XmlText
forall (f :: * -> *) a. Applicative f => a -> f a
pure (XmlText -> Reader PrettifyOpts XmlText)
-> XmlText -> Reader PrettifyOpts XmlText
forall a b. (a -> b) -> a -> b
$ XmlText -> [XmlText] -> XmlText
T.intercalate (EndOfLine -> XmlText
forall a. TextShow a => a -> XmlText
showt EndOfLine
eol) [XmlText
tagText, XmlText
remainingTagText]