{-# 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
  | 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
$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)

-- TODO use colors and styles

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
    --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 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
"...)"