{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE InstanceSigs          #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE ScopedTypeVariables   #-}

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 Text.PrettyPrint.ANSI.Leijen         hiding ((<$>), (<>))

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
  | RawComment 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
/= :: RawValue -> RawValue -> Bool
$c/= :: RawValue -> RawValue -> Bool
== :: RawValue -> RawValue -> Bool
$c== :: 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
showList :: [RawValue] -> ShowS
$cshowList :: [RawValue] -> ShowS
show :: RawValue -> String
$cshow :: RawValue -> String
showsPrec :: Int -> RawValue -> ShowS
$cshowsPrec :: Int -> RawValue -> ShowS
Show)

instance Pretty RawValue where
  pretty :: RawValue -> Doc
pretty RawValue
mjpv = case RawValue
mjpv of
    RawText Text
s       -> Doc -> Doc
ctext (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
text (Text -> String
T.unpack Text
s)
    RawAttrName Text
s   -> String -> Doc
text (Text -> String
T.unpack Text
s)
    RawAttrValue Text
s  -> (Doc -> Doc
ctext (Doc -> Doc) -> (String -> Doc) -> String -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Doc
dquotes (Doc -> Doc) -> (String -> Doc) -> String -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
text) (Text -> String
T.unpack Text
s)
    RawAttrList [RawValue]
ats -> [RawValue] -> Doc
formatAttrs [RawValue]
ats
    RawComment Text
s    -> String -> Doc
text (String -> Doc) -> String -> Doc
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
formatElem (Text -> String
T.unpack Text
s) [RawValue]
xs
    RawDocument [RawValue]
xs  -> String -> String -> [RawValue] -> Doc
formatMeta String
"?" String
"xml" [RawValue]
xs
    RawError Text
s      -> Doc -> Doc
red (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"[error " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
text (Text -> String
T.unpack Text
s) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
text String
"]"
    RawCData Text
s      -> Doc -> Doc
cangle Doc
"<!" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
ctag (String -> Doc
text String
"[CDATA[") Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
text (Text -> String
T.unpack Text
s) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
cangle (String -> Doc
text String
"]]>")
    RawMeta Text
s [RawValue]
xs    -> String -> String -> [RawValue] -> Doc
formatMeta String
"!" (Text -> String
T.unpack Text
s) [RawValue]
xs
    where
      formatAttr :: RawValue -> Doc
formatAttr RawValue
at = case RawValue
at of
        RawAttrName Text
a  -> String -> Doc
text String
" " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> RawValue -> Doc
forall a. Pretty a => a -> Doc
pretty (Text -> RawValue
RawAttrName Text
a)
        RawAttrValue Text
a -> String -> Doc
text String
"=" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> RawValue -> Doc
forall a. Pretty a => a -> Doc
pretty (Text -> RawValue
RawAttrValue Text
a)
        RawAttrList [RawValue]
_  -> Doc -> Doc
red (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"ATTRS"
        RawValue
_              -> Doc -> Doc
red (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"booo"
      formatAttrs :: [RawValue] -> Doc
formatAttrs [RawValue]
ats = [Doc] -> Doc
hcat (RawValue -> Doc
formatAttr (RawValue -> Doc) -> [RawValue] -> [Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [RawValue]
ats)
      formatElem :: String -> [RawValue] -> Doc
formatElem String
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 -> Doc
cangle Doc
langle Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
ctag (String -> Doc
text String
s)
              Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> [Doc] -> Doc
hcat (RawValue -> Doc
forall a. Pretty a => a -> Doc
pretty (RawValue -> Doc) -> [RawValue] -> [Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [RawValue]
ats)
              Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
cangle Doc
rangle
              Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> [Doc] -> Doc
hcat (RawValue -> Doc
forall a. Pretty a => a -> Doc
pretty (RawValue -> Doc) -> [RawValue] -> [Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [RawValue]
es)
              Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
cangle (String -> Doc
text String
"</") Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
ctag (String -> Doc
text String
s) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
cangle Doc
rangle
      formatMeta :: String -> String -> [RawValue] -> Doc
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 -> Doc
cangle (Doc
langle Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
text String
b) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
ctag (String -> Doc
text String
s)
              Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> [Doc] -> Doc
hcat (RawValue -> Doc
forall a. Pretty a => a -> Doc
pretty (RawValue -> Doc) -> [RawValue] -> [Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [RawValue]
ats)
              Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
cangle Doc
rangle
              Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> [Doc] -> Doc
hcat (RawValue -> Doc
forall a. Pretty a => a -> Doc
pretty (RawValue -> Doc) -> [RawValue] -> [Doc]
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
    --unknown                -> XmlError ("Not yet supported: " <> show unknown)
    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 -> Doc
cangle :: Doc -> Doc
cangle = Doc -> Doc
dullwhite

ctag :: Doc -> Doc
ctag :: Doc -> Doc
ctag = Doc -> Doc
bold

ctext :: Doc -> Doc
ctext :: Doc -> Doc
ctext = Doc -> Doc
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 :: 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 :: 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
"...)"