{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# 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
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
}
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]