{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module HaskellWorks.Data.Xml.RawValue
( RawValue(..)
, RawValueAt(..)
) where
import Data.ByteString (ByteString)
import Data.List
import Data.Text (Text)
import HaskellWorks.Data.Xml.Grammar
import HaskellWorks.Data.Xml.Internal.Show
import HaskellWorks.Data.Xml.Succinct.Index
import Prettyprinter
import qualified Data.Attoparsec.ByteString.Char8 as ABC
import qualified Data.ByteString as BS
import qualified Data.Text as T
data RawValue
= RawDocument [RawValue]
| RawText Text
| RawElement Text [RawValue]
| RawCData Text
| Text
| RawMeta Text [RawValue]
| RawAttrName Text
| RawAttrValue Text
| RawAttrList [RawValue]
| RawError Text
deriving (RawValue -> RawValue -> Bool
(RawValue -> RawValue -> Bool)
-> (RawValue -> RawValue -> Bool) -> Eq RawValue
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RawValue -> RawValue -> Bool
== :: RawValue -> RawValue -> Bool
$c/= :: RawValue -> RawValue -> Bool
/= :: RawValue -> RawValue -> Bool
Eq, Int -> RawValue -> ShowS
[RawValue] -> ShowS
RawValue -> String
(Int -> RawValue -> ShowS)
-> (RawValue -> String) -> ([RawValue] -> ShowS) -> Show RawValue
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RawValue -> ShowS
showsPrec :: Int -> RawValue -> ShowS
$cshow :: RawValue -> String
show :: RawValue -> String
$cshowList :: [RawValue] -> ShowS
showList :: [RawValue] -> ShowS
Show)
red :: Doc ann -> Doc ann
red :: forall ann. Doc ann -> Doc ann
red = Doc ann -> Doc ann
forall a. a -> a
id
dullwhite :: Doc ann -> Doc ann
dullwhite :: forall ann. Doc ann -> Doc ann
dullwhite = Doc ann -> Doc ann
forall a. a -> a
id
bold :: Doc ann -> Doc ann
bold :: forall ann. Doc ann -> Doc ann
bold = Doc ann -> Doc ann
forall a. a -> a
id
dullgreen :: Doc ann -> Doc ann
dullgreen :: forall ann. Doc ann -> Doc ann
dullgreen = Doc ann -> Doc ann
forall a. a -> a
id
instance Pretty RawValue where
pretty :: forall ann. RawValue -> Doc ann
pretty RawValue
mjpv = case RawValue
mjpv of
RawText Text
s -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
ctext (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Text -> String
T.unpack Text
s)
RawAttrName Text
s -> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Text -> String
T.unpack Text
s)
RawAttrValue Text
s -> (Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
ctext (Doc ann -> Doc ann) -> (String -> Doc ann) -> String -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
dquotes (Doc ann -> Doc ann) -> (String -> Doc ann) -> String -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty) (Text -> String
T.unpack Text
s)
RawAttrList [RawValue]
ats -> [RawValue] -> Doc ann
forall ann. [RawValue] -> Doc ann
formatAttrs [RawValue]
ats
RawComment Text
s -> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Doc ann) -> String -> Doc ann
forall a b. (a -> b) -> a -> b
$ String
"<!-- " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show Text
s String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"-->"
RawElement Text
s [RawValue]
xs -> String -> [RawValue] -> Doc ann
forall {a} {ann}. Pretty a => a -> [RawValue] -> Doc ann
formatElem (Text -> String
T.unpack Text
s) [RawValue]
xs
RawDocument [RawValue]
xs -> String -> String -> [RawValue] -> Doc ann
forall {ann}. String -> String -> [RawValue] -> Doc ann
formatMeta String
"?" String
"xml" [RawValue]
xs
RawError Text
s -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
red (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ Doc ann
"[error " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Text -> String
T.unpack Text
s) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"]"
RawCData Text
s -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
cangle Doc ann
"<!" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
ctag Doc ann
"[CDATA[" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Text -> String
T.unpack Text
s) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
cangle Doc ann
"]]>"
RawMeta Text
s [RawValue]
xs -> String -> String -> [RawValue] -> Doc ann
forall {ann}. String -> String -> [RawValue] -> Doc ann
formatMeta String
"!" (Text -> String
T.unpack Text
s) [RawValue]
xs
where
formatAttr :: RawValue -> Doc ann
formatAttr RawValue
at = case RawValue
at of
RawAttrName Text
a -> Doc ann
" " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> RawValue -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. RawValue -> Doc ann
pretty (Text -> RawValue
RawAttrName Text
a)
RawAttrValue Text
a -> Doc ann
"=" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> RawValue -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. RawValue -> Doc ann
pretty (Text -> RawValue
RawAttrValue Text
a)
RawAttrList [RawValue]
_ -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
red Doc ann
"ATTRS"
RawValue
_ -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
red Doc ann
"booo"
formatAttrs :: [RawValue] -> Doc ann
formatAttrs [RawValue]
ats = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hcat (RawValue -> Doc ann
forall ann. RawValue -> Doc ann
formatAttr (RawValue -> Doc ann) -> [RawValue] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [RawValue]
ats)
formatElem :: a -> [RawValue] -> Doc ann
formatElem a
s [RawValue]
xs =
let ([RawValue]
ats, [RawValue]
es) = (RawValue -> Bool) -> [RawValue] -> ([RawValue], [RawValue])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition RawValue -> Bool
isAttrL [RawValue]
xs
in Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
cangle Doc ann
forall ann. Doc ann
langle Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
ctag (a -> Doc ann
forall ann. a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a
s)
Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hcat (RawValue -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. RawValue -> Doc ann
pretty (RawValue -> Doc ann) -> [RawValue] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [RawValue]
ats)
Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
cangle Doc ann
forall ann. Doc ann
rangle
Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hcat (RawValue -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. RawValue -> Doc ann
pretty (RawValue -> Doc ann) -> [RawValue] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [RawValue]
es)
Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
cangle Doc ann
"</" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
ctag (a -> Doc ann
forall ann. a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a
s) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
cangle Doc ann
forall ann. Doc ann
rangle
formatMeta :: String -> String -> [RawValue] -> Doc ann
formatMeta String
b String
s [RawValue]
xs =
let ([RawValue]
ats, [RawValue]
es) = (RawValue -> Bool) -> [RawValue] -> ([RawValue], [RawValue])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition RawValue -> Bool
isAttr [RawValue]
xs
in Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
cangle (Doc ann
forall ann. Doc ann
langle Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty @String String
b) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
ctag (forall a ann. Pretty a => a -> Doc ann
pretty @String String
s)
Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hcat (RawValue -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. RawValue -> Doc ann
pretty (RawValue -> Doc ann) -> [RawValue] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [RawValue]
ats)
Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
cangle Doc ann
forall ann. Doc ann
rangle
Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hcat (RawValue -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. RawValue -> Doc ann
pretty (RawValue -> Doc ann) -> [RawValue] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [RawValue]
es)
class RawValueAt a where
rawValueAt :: a -> RawValue
instance RawValueAt XmlIndex where
rawValueAt :: XmlIndex -> RawValue
rawValueAt XmlIndex
i = case XmlIndex
i of
XmlIndexCData ByteString
s -> ByteString -> ByteString -> Either Text String
parseTextUntil ByteString
"]]>" ByteString
s `as` (Text -> RawValue
RawCData (Text -> RawValue) -> (String -> Text) -> String -> RawValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack)
XmlIndexComment ByteString
s -> ByteString -> ByteString -> Either Text String
parseTextUntil ByteString
"-->" ByteString
s `as` (Text -> RawValue
RawComment (Text -> RawValue) -> (String -> Text) -> String -> RawValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack)
XmlIndexMeta Text
s [XmlIndex]
cs -> Text -> [RawValue] -> RawValue
RawMeta Text
s (XmlIndex -> RawValue
forall a. RawValueAt a => a -> RawValue
rawValueAt (XmlIndex -> RawValue) -> [XmlIndex] -> [RawValue]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [XmlIndex]
cs)
XmlIndexElement Text
s [XmlIndex]
cs -> Text -> [RawValue] -> RawValue
RawElement Text
s (XmlIndex -> RawValue
forall a. RawValueAt a => a -> RawValue
rawValueAt (XmlIndex -> RawValue) -> [XmlIndex] -> [RawValue]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [XmlIndex]
cs)
XmlIndexDocument [XmlIndex]
cs -> [RawValue] -> RawValue
RawDocument (XmlIndex -> RawValue
forall a. RawValueAt a => a -> RawValue
rawValueAt (XmlIndex -> RawValue) -> [XmlIndex] -> [RawValue]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [XmlIndex]
cs)
XmlIndexAttrName ByteString
cs -> ByteString -> Either Text Text
parseAttrName ByteString
cs `as` Text -> RawValue
RawAttrName
XmlIndexAttrValue ByteString
cs -> ByteString -> Either Text Text
parseString ByteString
cs `as` Text -> RawValue
RawAttrValue
XmlIndexAttrList [XmlIndex]
cs -> [RawValue] -> RawValue
RawAttrList (XmlIndex -> RawValue
forall a. RawValueAt a => a -> RawValue
rawValueAt (XmlIndex -> RawValue) -> [XmlIndex] -> [RawValue]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [XmlIndex]
cs)
XmlIndexValue ByteString
s -> ByteString -> ByteString -> Either Text String
parseTextUntil ByteString
"<" ByteString
s `as` (Text -> RawValue
RawText (Text -> RawValue) -> (String -> Text) -> String -> RawValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack)
XmlIndexError Text
s -> Text -> RawValue
RawError Text
s
where
parseUntil :: ByteString -> Parser ByteString String
parseUntil ByteString
s = Parser ByteString Char
-> Parser ByteString ByteString -> Parser ByteString String
forall (f :: * -> *) a b. Alternative f => f a -> f b -> f [a]
ABC.manyTill Parser ByteString Char
ABC.anyChar (ByteString -> Parser ByteString ByteString
ABC.string ByteString
s)
parseTextUntil :: ByteString -> ByteString -> Either Text [Char]
parseTextUntil :: ByteString -> ByteString -> Either Text String
parseTextUntil ByteString
s ByteString
bs = case Parser ByteString String -> ByteString -> Result String
forall a. Parser a -> ByteString -> Result a
ABC.parse (ByteString -> Parser ByteString String
parseUntil ByteString
s) ByteString
bs of
ABC.Fail {} -> Text -> ByteString -> Either Text String
forall a. Text -> ByteString -> Either Text a
decodeErr (Text
"Unable to find " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
forall a. Show a => a -> Text
tshow ByteString
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".") ByteString
bs
ABC.Partial ByteString -> Result String
_ -> Text -> ByteString -> Either Text String
forall a. Text -> ByteString -> Either Text a
decodeErr (Text
"Unexpected end, expected " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
forall a. Show a => a -> Text
tshow ByteString
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".") ByteString
bs
ABC.Done ByteString
_ String
r -> String -> Either Text String
forall a b. b -> Either a b
Right String
r
parseString :: ByteString -> Either Text Text
parseString :: ByteString -> Either Text Text
parseString ByteString
bs = case Parser Text -> ByteString -> Result Text
forall a. Parser a -> ByteString -> Result a
ABC.parse Parser Text
forall t. Parser t Word8 => Parser t Text
parseXmlString ByteString
bs of
ABC.Fail {} -> Text -> ByteString -> Either Text Text
forall a. Text -> ByteString -> Either Text a
decodeErr Text
"Unable to parse string" ByteString
bs
ABC.Partial ByteString -> Result Text
_ -> Text -> ByteString -> Either Text Text
forall a. Text -> ByteString -> Either Text a
decodeErr Text
"Unexpected end of string, expected" ByteString
bs
ABC.Done ByteString
_ Text
r -> Text -> Either Text Text
forall a b. b -> Either a b
Right Text
r
parseAttrName :: ByteString -> Either Text Text
parseAttrName :: ByteString -> Either Text Text
parseAttrName ByteString
bs = case Parser Text -> ByteString -> Result Text
forall a. Parser a -> ByteString -> Result a
ABC.parse Parser Text
forall t. Parser t Word8 => Parser t Text
parseXmlAttributeName ByteString
bs of
ABC.Fail {} -> Text -> ByteString -> Either Text Text
forall a. Text -> ByteString -> Either Text a
decodeErr Text
"Unable to parse attribute name" ByteString
bs
ABC.Partial ByteString -> Result Text
_ -> Text -> ByteString -> Either Text Text
forall a. Text -> ByteString -> Either Text a
decodeErr Text
"Unexpected end of attr name, expected" ByteString
bs
ABC.Done ByteString
_ Text
r -> Text -> Either Text Text
forall a b. b -> Either a b
Right Text
r
cangle :: Doc ann -> Doc ann
cangle :: forall ann. Doc ann -> Doc ann
cangle = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
dullwhite
ctag :: Doc ann -> Doc ann
ctag :: forall ann. Doc ann -> Doc ann
ctag = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
bold
ctext :: Doc ann -> Doc ann
ctext :: forall ann. Doc ann -> Doc ann
ctext = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
dullgreen
isAttrL :: RawValue -> Bool
isAttrL :: RawValue -> Bool
isAttrL (RawAttrList [RawValue]
_) = Bool
True
isAttrL RawValue
_ = Bool
False
isAttr :: RawValue -> Bool
isAttr :: RawValue -> Bool
isAttr RawValue
v = case RawValue
v of
RawAttrName Text
_ -> Bool
True
RawAttrValue Text
_ -> Bool
True
RawAttrList [RawValue]
_ -> Bool
True
RawValue
_ -> Bool
False
as :: Either Text a -> (a -> RawValue) -> RawValue
as :: forall a. Either Text a -> (a -> RawValue) -> RawValue
as = ((a -> RawValue) -> Either Text a -> RawValue)
-> Either Text a -> (a -> RawValue) -> RawValue
forall a b c. (a -> b -> c) -> b -> a -> c
flip (((a -> RawValue) -> Either Text a -> RawValue)
-> Either Text a -> (a -> RawValue) -> RawValue)
-> ((a -> RawValue) -> Either Text a -> RawValue)
-> Either Text a
-> (a -> RawValue)
-> RawValue
forall a b. (a -> b) -> a -> b
$ (Text -> RawValue) -> (a -> RawValue) -> Either Text a -> RawValue
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> RawValue
RawError
decodeErr :: Text -> BS.ByteString -> Either Text a
decodeErr :: forall a. Text -> ByteString -> Either Text a
decodeErr Text
reason ByteString
bs = Text -> Either Text a
forall a b. a -> Either a b
Left (Text -> Either Text a) -> Text -> Either Text a
forall a b. (a -> b) -> a -> b
$ Text
reason Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
forall a. Show a => a -> Text
tshow (Int -> ByteString -> ByteString
BS.take Int
20 ByteString
bs) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"...)"