{-# 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 =
prettyPrintXml
PrettifyOpts
{ endOfLine = LF,
indentStyle = SPACE 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 opts xmlText = runReader (printAllTags tags) opts
where
tags = inputToTags $ T.concat $ T.lines xmlText
data TagType = IncTagType | DecTagType | StandaloneTagType
deriving stock (Ord, Eq, Enum)
type XmlText = T.Text
type TagContent = T.Text
type OneLineXmlText = XmlText
data XmlTag = XmlTag TagContent TagType
deriving stock (Ord, Eq)
inputToTags :: OneLineXmlText -> [XmlTag]
inputToTags "" = []
inputToTags xmlText = xtag : inputToTags xmlText'
where
(xtag, xmlText') = lexOne xmlText
lexOne :: OneLineXmlText -> (XmlTag, OneLineXmlText)
lexOne xmlText = case nextCharacter of
' ' -> (XmlTag "" StandaloneTagType, "")
'<' -> lexOneTag xmlText
_ -> lexNonTagged xmlText
where
nextWord = getWord xmlText
nextCharacter = T.head $ nextWord <> " "
lexNonTagged :: OneLineXmlText -> (XmlTag, OneLineXmlText)
lexNonTagged xmlText = (XmlTag tagContent tagType, remaining)
where
nextWord = getWord xmlText
(tagContent, remaining) = T.break (== '<') nextWord
tagType = StandaloneTagType
getWord :: T.Text -> T.Text
getWord = T.dropWhile isSpace
lexOneTag :: OneLineXmlText -> (XmlTag, OneLineXmlText)
lexOneTag xmlText = (XmlTag tagContent tagType, res)
where
afterTagStart = T.dropWhile (/= '<') xmlText
(tagContent', remaining) = T.span (/= '>') afterTagStart
tagContent = tagContent' <> (T.singleton . T.head) remaining
res = T.tail remaining
tagType = case (T.index tagContent 1, T.index tagContent (T.length tagContent - 2)) of
('/', _) -> DecTagType
(_, '/') -> StandaloneTagType
('!', _) -> StandaloneTagType
('?', _) -> StandaloneTagType
(_, _) -> IncTagType
printTag :: Int -> XmlTag -> Prettify (Int, XmlText)
printTag tagIdent (XmlTag content tagType) = do
identStyle <- asks indentStyle
let identText = showt identStyle
let (contentIdent, nextTagIdent) = case tagType of
IncTagType -> (tagIdent, tagIdent + 1)
DecTagType -> (tagIdent - 1, tagIdent - 1)
_ -> (tagIdent, tagIdent)
let outText = T.replicate contentIdent identText <> content
pure (nextTagIdent, outText)
printAllTags :: [XmlTag] -> Prettify XmlText
printAllTags = printTags 0
printTags :: Int -> [XmlTag] -> Prettify XmlText
printTags _ [] = pure ""
printTags ident (tag : tags) = do
eol <- asks endOfLine
(nextTagIdent, tagText) <- printTag ident tag
remainingTagText <- printTags nextTagIdent tags
pure $ T.intercalate (showt eol) [tagText, remainingTagText]