module Text.HTML.Tagchup.Tag (
T(..), Name(..),
mapName,
open, isOpen, maybeOpen,
close, isClose, maybeClose,
text, isText, maybeText, innerText,
comment, isComment, maybeComment,
special, isSpecial, maybeSpecial,
cdata, isCData, maybeCData,
processing, isProcessing, maybeProcessing,
warning, isWarning, maybeWarning,
formatOpen, formatClose,
textFromCData, concatTexts,
mapText, mapTextA,
) where
import qualified Text.HTML.Tagchup.Character as Chr
import qualified Text.XML.Basic.ProcessingInstruction as PI
import qualified Text.XML.Basic.Attribute as Attr
import qualified Text.XML.Basic.Name as Name
import qualified Text.XML.Basic.Format as Fmt
import Text.XML.Basic.Tag (Name(Name), cdataName, )
import Data.Tuple.HT (mapFst, )
import Data.Maybe (mapMaybe, fromMaybe, )
import Data.Monoid (Monoid, mempty, mappend, mconcat, )
import Control.Monad (guard, )
import Data.Foldable (Foldable(foldMap), )
import Data.Traversable (Traversable(sequenceA), traverse, )
import Control.Applicative (Applicative, pure, liftA, )
data T name string =
Open (Name name) [Attr.T name string]
| Close (Name name)
| Text string
| String
| Special (Name name) String
| Processing (Name name) (PI.T name string)
| Warning String
deriving (Int -> T name string -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall name string.
(Attribute name, Show name, Show string) =>
Int -> T name string -> ShowS
forall name string.
(Attribute name, Show name, Show string) =>
[T name string] -> ShowS
forall name string.
(Attribute name, Show name, Show string) =>
T name string -> String
showList :: [T name string] -> ShowS
$cshowList :: forall name string.
(Attribute name, Show name, Show string) =>
[T name string] -> ShowS
show :: T name string -> String
$cshow :: forall name string.
(Attribute name, Show name, Show string) =>
T name string -> String
showsPrec :: Int -> T name string -> ShowS
$cshowsPrec :: forall name string.
(Attribute name, Show name, Show string) =>
Int -> T name string -> ShowS
Show, T name string -> T name string -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall name string.
(Eq name, Eq string) =>
T name string -> T name string -> Bool
/= :: T name string -> T name string -> Bool
$c/= :: forall name string.
(Eq name, Eq string) =>
T name string -> T name string -> Bool
== :: T name string -> T name string -> Bool
$c== :: forall name string.
(Eq name, Eq string) =>
T name string -> T name string -> Bool
Eq, T name string -> T name string -> Ordering
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
forall {name} {string}.
(Ord name, Ord string) =>
Eq (T name string)
forall name string.
(Ord name, Ord string) =>
T name string -> T name string -> Bool
forall name string.
(Ord name, Ord string) =>
T name string -> T name string -> Ordering
forall name string.
(Ord name, Ord string) =>
T name string -> T name string -> T name string
min :: T name string -> T name string -> T name string
$cmin :: forall name string.
(Ord name, Ord string) =>
T name string -> T name string -> T name string
max :: T name string -> T name string -> T name string
$cmax :: forall name string.
(Ord name, Ord string) =>
T name string -> T name string -> T name string
>= :: T name string -> T name string -> Bool
$c>= :: forall name string.
(Ord name, Ord string) =>
T name string -> T name string -> Bool
> :: T name string -> T name string -> Bool
$c> :: forall name string.
(Ord name, Ord string) =>
T name string -> T name string -> Bool
<= :: T name string -> T name string -> Bool
$c<= :: forall name string.
(Ord name, Ord string) =>
T name string -> T name string -> Bool
< :: T name string -> T name string -> Bool
$c< :: forall name string.
(Ord name, Ord string) =>
T name string -> T name string -> Bool
compare :: T name string -> T name string -> Ordering
$ccompare :: forall name string.
(Ord name, Ord string) =>
T name string -> T name string -> Ordering
Ord)
instance Functor (T name) where
fmap :: forall a b. (a -> b) -> T name a -> T name b
fmap a -> b
f T name a
tag =
case T name a
tag of
Open Name name
name [T name a]
attrs -> forall name string. Name name -> [T name string] -> T name string
Open Name name
name forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) [T name a]
attrs
Close Name name
name -> forall name string. Name name -> T name string
Close Name name
name
Text a
string -> forall name string. string -> T name string
Text forall a b. (a -> b) -> a -> b
$ a -> b
f a
string
Comment String
string -> forall name string. String -> T name string
Comment String
string
Special Name name
name String
content -> forall name string. Name name -> String -> T name string
Special Name name
name String
content
Processing Name name
name T name a
proc -> forall name string. Name name -> T name string -> T name string
Processing Name name
name forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f T name a
proc
Warning String
string -> forall name string. String -> T name string
Warning String
string
instance Foldable (T name) where
foldMap :: forall m a. Monoid m => (a -> m) -> T name a -> m
foldMap a -> m
f T name a
tag =
case T name a
tag of
Open Name name
_name [T name a]
attrs -> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f) [T name a]
attrs
Close Name name
_name -> forall a. Monoid a => a
mempty
Text a
string -> a -> m
f a
string
Comment String
_text -> forall a. Monoid a => a
mempty
Special Name name
_name String
_content -> forall a. Monoid a => a
mempty
Processing Name name
_name T name a
proc -> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f T name a
proc
Warning String
_text -> forall a. Monoid a => a
mempty
instance Traversable (T name) where
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
T name (f a) -> f (T name a)
sequenceA T name (f a)
tag =
case T name (f a)
tag of
Open Name name
name [T name (f a)]
attrs -> forall (f :: * -> *) a b. Applicative f => (a -> b) -> f a -> f b
liftA (forall name string. Name name -> [T name string] -> T name string
Open Name name
name) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA [T name (f a)]
attrs
Close Name name
name -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall name string. Name name -> T name string
Close Name name
name
Text f a
string -> forall (f :: * -> *) a b. Applicative f => (a -> b) -> f a -> f b
liftA forall name string. string -> T name string
Text forall a b. (a -> b) -> a -> b
$ f a
string
Comment String
string -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall name string. String -> T name string
Comment String
string
Special Name name
name String
content -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall name string. Name name -> String -> T name string
Special Name name
name String
content
Processing Name name
name T name (f a)
proc -> forall (f :: * -> *) a b. Applicative f => (a -> b) -> f a -> f b
liftA (forall name string. Name name -> T name string -> T name string
Processing Name name
name) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA T name (f a)
proc
Warning String
string -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall name string. String -> T name string
Warning String
string
mapName ::
(Name name0 -> Name name1) ->
(Attr.Name name0 -> Attr.Name name1) ->
T name0 string -> T name1 string
mapName :: forall name0 name1 string.
(Name name0 -> Name name1)
-> (Name name0 -> Name name1) -> T name0 string -> T name1 string
mapName Name name0 -> Name name1
f Name name0 -> Name name1
g T name0 string
tag =
case T name0 string
tag of
Open Name name0
name [T name0 string]
attrs -> forall name string. Name name -> [T name string] -> T name string
Open (Name name0 -> Name name1
f Name name0
name) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall name0 name1 string.
(Name name0 -> Name name1) -> T name0 string -> T name1 string
Attr.mapName Name name0 -> Name name1
g) [T name0 string]
attrs
Close Name name0
name -> forall name string. Name name -> T name string
Close (Name name0 -> Name name1
f Name name0
name)
Text string
string -> forall name string. string -> T name string
Text string
string
Comment String
string -> forall name string. String -> T name string
Comment String
string
Special Name name0
name String
content -> forall name string. Name name -> String -> T name string
Special (Name name0 -> Name name1
f Name name0
name) String
content
Processing Name name0
name T name0 string
proc -> forall name string. Name name -> T name string -> T name string
Processing (Name name0 -> Name name1
f Name name0
name) forall a b. (a -> b) -> a -> b
$ forall name0 name1 string.
(Name name0 -> Name name1) -> T name0 string -> T name1 string
PI.mapName Name name0 -> Name name1
g T name0 string
proc
Warning String
string -> forall name string. String -> T name string
Warning String
string
instance (Name.Tag name, Name.Attribute name, Fmt.C string) =>
Fmt.C (T name string) where
run :: T name string -> ShowS
run T name string
t =
case T name string
t of
Open Name name
name [T name string]
attrs -> forall name string.
(Tag name, Attribute name, C string) =>
Bool -> Name name -> [T name string] -> ShowS
formatOpen Bool
False Name name
name [T name string]
attrs
Close Name name
name -> forall name. Tag name => Name name -> ShowS
formatClose Name name
name
Text string
str -> forall object. C object => object -> ShowS
Fmt.run string
str
Comment String
c ->
String -> ShowS
showString String
"<!--" forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
c forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"-->"
Warning String
e ->
String -> ShowS
showString String
"<!-- Warning: " forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
e forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" -->"
Special Name name
name String
str ->
ShowS -> ShowS
Fmt.angle forall a b. (a -> b) -> a -> b
$
ShowS
Fmt.exclam forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall name. C name => name -> ShowS
Fmt.name Name name
name forall b c a. (b -> c) -> (a -> b) -> a -> c
.
if forall name. Tag name => Name name
cdataName forall a. Eq a => a -> a -> Bool
== Name name
name
then String -> ShowS
showString String
str forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"]]"
else ShowS
Fmt.blank forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
str
Processing Name name
name T name string
p ->
ShowS -> ShowS
Fmt.angle forall a b. (a -> b) -> a -> b
$
ShowS
Fmt.quest forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall name. C name => name -> ShowS
Fmt.name Name name
name forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall object. C object => object -> ShowS
Fmt.run T name string
p forall b c a. (b -> c) -> (a -> b) -> a -> c
.
ShowS
Fmt.quest
formatOpen :: (Name.Tag name, Name.Attribute name, Fmt.C string) =>
Bool -> Name name -> [Attr.T name string] -> ShowS
formatOpen :: forall name string.
(Tag name, Attribute name, C string) =>
Bool -> Name name -> [T name string] -> ShowS
formatOpen Bool
selfClosing Name name
name [T name string]
attrs =
ShowS -> ShowS
Fmt.angle forall a b. (a -> b) -> a -> b
$
forall name. C name => name -> ShowS
Fmt.name Name name
name forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall name string.
(Attribute name, C string) =>
[T name string] -> ShowS
Attr.formatListBlankHead [T name string]
attrs forall b c a. (b -> c) -> (a -> b) -> a -> c
.
if Bool
selfClosing then ShowS
Fmt.slash else forall a. a -> a
id
formatClose :: (Name.Tag name) =>
Name name -> ShowS
formatClose :: forall name. Tag name => Name name -> ShowS
formatClose Name name
name =
ShowS -> ShowS
Fmt.angle forall a b. (a -> b) -> a -> b
$
ShowS
Fmt.slash forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall name. C name => name -> ShowS
Fmt.name Name name
name
open :: Name name -> [Attr.T name string] -> T name string
open :: forall name string. Name name -> [T name string] -> T name string
open = forall name string. Name name -> [T name string] -> T name string
Open
close :: Name name -> T name string
close :: forall name string. Name name -> T name string
close = forall name string. Name name -> T name string
Close
text :: string -> T name string
text :: forall string name. string -> T name string
text = forall name string. string -> T name string
Text
comment :: String -> T name string
= forall name string. String -> T name string
Comment
special :: Name name -> String -> T name string
special :: forall name string. Name name -> String -> T name string
special = forall name string. Name name -> String -> T name string
Special
cdata :: (Name.Tag name) => String -> T name string
cdata :: forall name string. Tag name => String -> T name string
cdata = forall name string. Name name -> String -> T name string
special forall name. Tag name => Name name
cdataName
processing :: Name name -> PI.T name string -> T name string
processing :: forall name string. Name name -> T name string -> T name string
processing = forall name string. Name name -> T name string -> T name string
Processing
warning :: String -> T name string
warning :: forall name string. String -> T name string
warning = forall name string. String -> T name string
Warning
isOpen :: T name string -> Bool
isOpen :: forall name a. T name a -> Bool
isOpen T name string
tag = case T name string
tag of (Open {}) -> Bool
True; T name string
_ -> Bool
False
maybeOpen :: T name string -> Maybe (Name name, [Attr.T name string])
maybeOpen :: forall name string.
T name string -> Maybe (Name name, [T name string])
maybeOpen T name string
tag = case T name string
tag of Open Name name
name [T name string]
attrs -> forall a. a -> Maybe a
Just (Name name
name, [T name string]
attrs); T name string
_ -> forall a. Maybe a
Nothing
isClose :: T name string -> Bool
isClose :: forall name a. T name a -> Bool
isClose T name string
tag = case T name string
tag of (Close {}) -> Bool
True; T name string
_ -> Bool
False
maybeClose :: T name string -> Maybe (Name name)
maybeClose :: forall name string. T name string -> Maybe (Name name)
maybeClose T name string
tag = case T name string
tag of Close Name name
x -> forall a. a -> Maybe a
Just Name name
x; T name string
_ -> forall a. Maybe a
Nothing
isText :: T name string -> Bool
isText :: forall name a. T name a -> Bool
isText T name string
tag = case T name string
tag of (Text {}) -> Bool
True; T name string
_ -> Bool
False
maybeText :: T name string -> Maybe string
maybeText :: forall name string. T name string -> Maybe string
maybeText T name string
tag = case T name string
tag of Text string
x -> forall a. a -> Maybe a
Just string
x; T name string
_ -> forall a. Maybe a
Nothing
innerText :: (Monoid string) => [T name string] -> string
innerText :: forall string name. Monoid string => [T name string] -> string
innerText = forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall name string. T name string -> Maybe string
maybeText
isComment :: T name string -> Bool
T name string
tag = case T name string
tag of (Comment {}) -> Bool
True; T name string
_ -> Bool
False
maybeComment :: T name string -> Maybe String
T name string
tag = case T name string
tag of Comment String
x -> forall a. a -> Maybe a
Just String
x; T name string
_ -> forall a. Maybe a
Nothing
isSpecial :: T name string -> Bool
isSpecial :: forall name a. T name a -> Bool
isSpecial T name string
tag = case T name string
tag of (Special {}) -> Bool
True; T name string
_ -> Bool
False
maybeSpecial :: T name string -> Maybe (Name name, String)
maybeSpecial :: forall name string. T name string -> Maybe (Name name, String)
maybeSpecial T name string
tag = case T name string
tag of Special Name name
name String
content -> forall a. a -> Maybe a
Just (Name name
name, String
content); T name string
_ -> forall a. Maybe a
Nothing
isCData ::
(Name.Tag name) =>
T name string -> Bool
isCData :: forall name string. Tag name => T name string -> Bool
isCData T name string
tag = case T name string
tag of (Special Name name
name String
_) -> forall name. Tag name => Name name
cdataName forall a. Eq a => a -> a -> Bool
== Name name
name; T name string
_ -> Bool
False
maybeCData ::
(Name.Tag name) =>
T name string -> Maybe String
maybeCData :: forall name string. Tag name => T name string -> Maybe String
maybeCData T name string
tag =
do (Name name
name, String
content) <- forall name string. T name string -> Maybe (Name name, String)
maybeSpecial T name string
tag
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (forall name. Tag name => Name name
cdataName forall a. Eq a => a -> a -> Bool
== Name name
name)
forall (m :: * -> *) a. Monad m => a -> m a
return String
content
isProcessing :: T name string -> Bool
isProcessing :: forall name a. T name a -> Bool
isProcessing T name string
tag = case T name string
tag of (Processing {}) -> Bool
True; T name string
_ -> Bool
False
maybeProcessing :: T name string -> Maybe (Name name, PI.T name string)
maybeProcessing :: forall name string.
T name string -> Maybe (Name name, T name string)
maybeProcessing T name string
tag = case T name string
tag of Processing Name name
target T name string
instr -> forall a. a -> Maybe a
Just (Name name
target, T name string
instr); T name string
_ -> forall a. Maybe a
Nothing
isWarning :: T name string -> Bool
isWarning :: forall name a. T name a -> Bool
isWarning T name string
tag = case T name string
tag of (Warning {}) -> Bool
True; T name string
_ -> Bool
False
maybeWarning :: T name string -> Maybe String
maybeWarning :: forall name string. T name string -> Maybe String
maybeWarning T name string
tag = case T name string
tag of Warning String
x -> forall a. a -> Maybe a
Just String
x; T name string
_ -> forall a. Maybe a
Nothing
textFromCData ::
(Name.Tag name, Chr.C char) =>
T name [char] -> T name [char]
textFromCData :: forall name char.
(Tag name, C char) =>
T name [char] -> T name [char]
textFromCData T name [char]
t =
forall a. a -> Maybe a -> a
fromMaybe T name [char]
t forall a b. (a -> b) -> a -> b
$
do (Name name
name, String
content) <- forall name string. T name string -> Maybe (Name name, String)
maybeSpecial T name [char]
t
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (forall name. Tag name => Name name
cdataName forall a. Eq a => a -> a -> Bool
== Name name
name)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall name string. string -> T name string
Text forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall char. C char => Char -> char
Chr.fromChar String
content
concatTexts ::
Monoid string =>
[T name string] -> [T name string]
concatTexts :: forall string name.
Monoid string =>
[T name string] -> [T name string]
concatTexts =
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
(\T name string
t [T name string]
ts ->
case T name string
t of
Text string
str0 ->
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (:) forall a b. (a -> b) -> a -> b
$
forall a c b. (a -> c) -> (a, b) -> (c, b)
mapFst (forall name string. string -> T name string
Text forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => a -> a -> a
mappend string
str0) forall a b. (a -> b) -> a -> b
$
case [T name string]
ts of
Text string
str1 : [T name string]
rest -> (string
str1,[T name string]
rest)
[T name string]
_ -> (forall a. Monoid a => a
mempty,[T name string]
ts)
T name string
_ -> T name string
tforall a. a -> [a] -> [a]
:[T name string]
ts)
[]
mapText ::
(Name.Tag name) =>
(String -> String) ->
T name String -> T name String
mapText :: forall name. Tag name => ShowS -> T name String -> T name String
mapText ShowS
f T name String
t =
case T name String
t of
Text String
s -> forall name string. string -> T name string
Text forall a b. (a -> b) -> a -> b
$ ShowS
f String
s
Special Name name
name String
s ->
forall name string. Name name -> String -> T name string
Special Name name
name forall a b. (a -> b) -> a -> b
$
if forall name. Tag name => Name name
cdataName forall a. Eq a => a -> a -> Bool
== Name name
name
then ShowS
f String
s
else String
s
T name String
_ -> T name String
t
mapTextA ::
(Name.Tag name, Applicative f) =>
(String -> f String) ->
T name String -> f (T name String)
mapTextA :: forall name (f :: * -> *).
(Tag name, Applicative f) =>
(String -> f String) -> T name String -> f (T name String)
mapTextA String -> f String
f T name String
t =
case T name String
t of
Text String
s -> forall (f :: * -> *) a b. Applicative f => (a -> b) -> f a -> f b
liftA forall name string. string -> T name string
Text forall a b. (a -> b) -> a -> b
$ String -> f String
f String
s
Special Name name
name String
s ->
forall (f :: * -> *) a b. Applicative f => (a -> b) -> f a -> f b
liftA (forall name string. Name name -> String -> T name string
Special Name name
name) forall a b. (a -> b) -> a -> b
$
if forall name. Tag name => Name name
cdataName forall a. Eq a => a -> a -> Bool
== Name name
name
then String -> f String
f String
s
else forall (f :: * -> *) a. Applicative f => a -> f a
pure String
s
T name String
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure T name String
t