module Text.XML.WraXML.Document.TagSoup where

import qualified Text.XML.WraXML.Tree.TagSoup as TreeTagSoup
import qualified Text.XML.WraXML.Document as XmlDoc
-- import qualified Text.XML.WraXML.Tree     as XmlTree

import Text.XML.WraXML.Tree.TagSoup (PosTag, )

import qualified Text.HTML.TagSoup as Tag

import Text.HTML.TagSoup (Tag(..), )

import qualified Text.XML.Basic.Position as Position

import qualified Text.XML.Basic.Attribute as Attr
import qualified Text.XML.Basic.Name.MixedCase as NameMC
import qualified Text.XML.Basic.Name.LowerCase as NameLC
import qualified Text.XML.Basic.Name as Name

import Control.Monad.Trans.State (State, state, evalState, modify, gets, )

import Data.Char (isSpace, )



dropSpace ::[PosTag] -> [PosTag]
dropSpace :: [PosTag] -> [PosTag]
dropSpace =
   forall a. (a -> Bool) -> [a] -> [a]
dropWhile
      (\PosTag
tag ->
          case forall a b. (a, b) -> b
snd PosTag
tag of
             Tag.TagText String
text -> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
text
             Tag String
_ -> Bool
False)

withoutLeadingSpace ::
   ([PosTag] -> (a, [PosTag])) ->
   State [PosTag] a
withoutLeadingSpace :: forall a. ([PosTag] -> (a, [PosTag])) -> State [PosTag] a
withoutLeadingSpace [PosTag] -> (a, [PosTag])
f =
   forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify [PosTag] -> [PosTag]
dropSpace forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
state [PosTag] -> (a, [PosTag])
f

toXmlDocument ::
   (Name.Tag name, Name.Attribute name) =>
   [Tag String] -> XmlDoc.T Position.T name String
toXmlDocument :: forall name.
(Tag name, Attribute name) =>
[Tag String] -> T T name String
toXmlDocument [Tag String]
ts =
   forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. State s a -> s -> a
evalState
      ([PosTag] -> [PosTag]
TreeTagSoup.removeMetaPos
          ([Tag String] -> [PosTag]
TreeTagSoup.attachPos
              (forall str. StringLike str => [Tag str] -> [Tag str]
Tag.canonicalizeTags [Tag String]
ts))) forall a b. (a -> b) -> a -> b
$
   do Maybe [T name String]
xml <- forall a. ([PosTag] -> (a, [PosTag])) -> State [PosTag] a
withoutLeadingSpace forall a b. (a -> b) -> a -> b
$ \[PosTag]
ts0 ->
         case [PosTag]
ts0 of
            (T
_, Tag.TagOpen String
"?xml" [Attribute String]
attrs):[PosTag]
ts1 ->
                 (forall a. a -> Maybe a
Just (forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall name string.
Attribute name =>
String -> string -> T name string
Attr.new) [Attribute String]
attrs), [PosTag]
ts1)
            [PosTag]
_ -> (forall a. Maybe a
Nothing, [PosTag]
ts0)
      Maybe String
docType <- forall a. ([PosTag] -> (a, [PosTag])) -> State [PosTag] a
withoutLeadingSpace forall a b. (a -> b) -> a -> b
$ \[PosTag]
ts0 ->
         case [PosTag]
ts0 of
            (T
_, Tag.TagOpen String
"!DOCTYPE" [Attribute String]
dtd):[PosTag]
ts1 ->
                 (forall a. a -> Maybe a
Just (forall name string.
(Attribute name, C string) =>
[T name string] -> ShowS
Attr.formatListBlankHead
                         (forall a b. (a -> b) -> [a] -> [b]
map (forall name string.
Attribute name =>
(String, string) -> T name string
Attr.fromPair :: (String,String) -> Attr.T NameMC.T String) [Attribute String]
dtd) String
""), [PosTag]
ts1)
            [PosTag]
_ -> (forall a. Maybe a
Nothing, [PosTag]
ts0)
      forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets (forall i name str.
Maybe [T name str]
-> Maybe String -> [T i name str] -> T i name str
XmlDoc.Cons Maybe [T name String]
xml Maybe String
docType forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall name.
(Tag name, Attribute name) =>
[PosTag] -> [XmlTree name String]
TreeTagSoup.toXmlTreesAux)

{-
toXmlDocument =
   Tag.canonicalizeTags .
   XmlDoc.Cons Nothing .
   TreeTagSoup.toXmlTreesAux
-}

toXmlDocumentString ::
   (Name.Tag name, Name.Attribute name) =>
   [Tag String] -> XmlDoc.T Position.T name String
toXmlDocumentString :: forall name.
(Tag name, Attribute name) =>
[Tag String] -> T T name String
toXmlDocumentString =
   forall name.
(Tag name, Attribute name) =>
[Tag String] -> T T name String
toXmlDocument
{- this would only work for String, because of isSpace
   let cts = Tag.canonicalizePosTags ts
   in  case dropWhile (Match.tagText (all isSpace) . snd) cts of
          (_, Tag.TagSpecial "DOCTYPE" dtd):rest ->
               XmlDoc.Cons (Just dtd) (TreeTagSoup.toXmlTreesAux rest)
          _ -> XmlDoc.Cons Nothing    (TreeTagSoup.toXmlTreesAux cts)
-}


example :: IO ()
example :: IO ()
example =
  forall a. Show a => a -> IO ()
print forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  (forall name.
(Tag name, Attribute name) =>
[Tag String] -> T T name String
toXmlDocumentString :: [Tag String] -> XmlDoc.T Position.T NameLC.T String) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  forall str. StringLike str => ParseOptions str -> str -> [Tag str]
Tag.parseTagsOptions ParseOptions String
TreeTagSoup.parseOptions
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO String
readFile String
"/home/thielema/public_html/index.html"