-- | These are just some common abbreviations for generating HTML
--   content within the XML transformation framework defined
--   by "Text.Xml.HaXml.Combinators".
module Text.XML.HaXml.Html.Generate
  ( -- * HTML construction filters
  -- ** Containers
    html
  , hhead
  , htitle
  , hbody
  , h1, h2, h3, h4
  , hpara
  , hdiv, hspan, margin
  -- ** Anchors
  , anchor, makehref, anchorname
  -- ** Text style
  , hpre
  , hcentre
  , hem, htt, hbold
  , parens, bullet
  -- ** Tables
  , htable, hrow, hcol
  -- ** Breaks, lines
  , hbr, hhr
  -- ** Attributes
  , showattr, (!), (?)
  -- * A simple HTML pretty-printer
  , htmlprint
  ) where

import Data.Char (isSpace)

import Text.XML.HaXml.Types
import Text.XML.HaXml.Namespaces
import Text.XML.HaXml.Combinators
import qualified Text.PrettyPrint.HughesPJ as Pretty

---- Constructor functions

html, hhead, htitle, hbody, h1, h2, h3, h4, hpara, hpre, hcentre,
    hem, htt, hbold, htable, hrow, hcol, hdiv, hspan, margin
       :: [CFilter i] -> CFilter i
html :: forall i. [CFilter i] -> CFilter i
html    = forall i. String -> [CFilter i] -> CFilter i
mkElem String
"html"
hhead :: forall i. [CFilter i] -> CFilter i
hhead   = forall i. String -> [CFilter i] -> CFilter i
mkElem String
"head"
htitle :: forall i. [CFilter i] -> CFilter i
htitle  = forall i. String -> [CFilter i] -> CFilter i
mkElem String
"title"
hbody :: forall i. [CFilter i] -> CFilter i
hbody   = forall i. String -> [CFilter i] -> CFilter i
mkElem String
"body"
h1 :: forall i. [CFilter i] -> CFilter i
h1      = forall i. String -> [CFilter i] -> CFilter i
mkElem String
"h1"
h2 :: forall i. [CFilter i] -> CFilter i
h2      = forall i. String -> [CFilter i] -> CFilter i
mkElem String
"h2"
h3 :: forall i. [CFilter i] -> CFilter i
h3      = forall i. String -> [CFilter i] -> CFilter i
mkElem String
"h3"
h4 :: forall i. [CFilter i] -> CFilter i
h4      = forall i. String -> [CFilter i] -> CFilter i
mkElem String
"h4"
hpara :: forall i. [CFilter i] -> CFilter i
hpara   = forall i. String -> [CFilter i] -> CFilter i
mkElem String
"p"
hpre :: forall i. [CFilter i] -> CFilter i
hpre    = forall i. String -> [CFilter i] -> CFilter i
mkElem String
"pre"
hcentre :: forall i. [CFilter i] -> CFilter i
hcentre = forall i. String -> [CFilter i] -> CFilter i
mkElem String
"center"
hem :: forall i. [CFilter i] -> CFilter i
hem     = forall i. String -> [CFilter i] -> CFilter i
mkElem String
"em"
htt :: forall i. [CFilter i] -> CFilter i
htt     = forall i. String -> [CFilter i] -> CFilter i
mkElem String
"tt"
hbold :: forall i. [CFilter i] -> CFilter i
hbold   = forall i. String -> [CFilter i] -> CFilter i
mkElem String
"b"

htable :: forall i. [CFilter i] -> CFilter i
htable = forall i. String -> [CFilter i] -> CFilter i
mkElem String
"table"
hrow :: forall i. [CFilter i] -> CFilter i
hrow   = forall i. String -> [CFilter i] -> CFilter i
mkElem String
"tr"
hcol :: forall i. [CFilter i] -> CFilter i
hcol   = forall i. String -> [CFilter i] -> CFilter i
mkElem String
"td"

hdiv :: forall i. [CFilter i] -> CFilter i
hdiv   = forall i. String -> [CFilter i] -> CFilter i
mkElem String
"div"
hspan :: forall i. [CFilter i] -> CFilter i
hspan  = forall i. String -> [CFilter i] -> CFilter i
mkElem String
"span"
margin :: forall i. [CFilter i] -> CFilter i
margin = forall i.
String -> [(String, CFilter i)] -> [CFilter i] -> CFilter i
mkElemAttr String
"div" [(String
"margin-left",(String
"2em"forall i. String -> CFilter i
!)),
                           (String
"margin-top", (String
"1em"forall i. String -> CFilter i
!))]

anchor      :: [(String, CFilter i)] -> [CFilter i] -> CFilter  i
anchor :: forall i. [(String, CFilter i)] -> [CFilter i] -> CFilter i
anchor       = forall i.
String -> [(String, CFilter i)] -> [CFilter i] -> CFilter i
mkElemAttr String
"a"

makehref, anchorname :: CFilter i -> [CFilter i] -> CFilter i
makehref :: forall i. CFilter i -> [CFilter i] -> CFilter i
makehref CFilter i
r   = forall i. [(String, CFilter i)] -> [CFilter i] -> CFilter i
anchor [ (String
"href",CFilter i
r) ]
anchorname :: forall i. CFilter i -> [CFilter i] -> CFilter i
anchorname CFilter i
n = forall i. [(String, CFilter i)] -> [CFilter i] -> CFilter i
anchor [ (String
"name",CFilter i
n) ]


hbr, hhr :: CFilter i
hbr :: forall i. CFilter i
hbr       = forall i. String -> [CFilter i] -> CFilter i
mkElem String
"br" []
hhr :: forall i. CFilter i
hhr       = forall i. String -> [CFilter i] -> CFilter i
mkElem String
"hr" []


showattr, (!), (?) :: String -> CFilter i
showattr :: forall i. String -> CFilter i
showattr String
n = forall i. String -> (String -> CFilter i) -> CFilter i
find String
n forall i. String -> CFilter i
literal
! :: forall i. String -> CFilter i
(!) = forall i. String -> CFilter i
literal
? :: forall i. String -> CFilter i
(?) = forall i. String -> CFilter i
showattr

parens :: CFilter i -> CFilter i
parens :: forall i. CFilter i -> CFilter i
parens CFilter i
f = forall a b. [a -> [b]] -> a -> [b]
cat [ forall i. String -> CFilter i
literal String
"(", CFilter i
f, forall i. String -> CFilter i
literal String
")" ]

bullet :: [CFilter i] -> CFilter i
bullet :: forall i. [CFilter i] -> CFilter i
bullet = forall a b. [a -> [b]] -> a -> [b]
cat forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall i. String -> CFilter i
literal String
"M-^U"forall a. a -> [a] -> [a]
:)


---- Printing function

-- htmlprint :: [Content] -> String
-- htmlprint = concatMap cprint
--   where
--   cprint (CElem e _) = elem e
--   cprint (CString _ s) = s
--   cprint (CMisc m) = ""
--
--   elem (Elem n as []) = "\n<"++n++attrs as++" />"
--   elem (Elem n as cs) = "\n<"++n++attrs as++">"++htmlprint cs++"\n</"++n++">"
--
--   attrs = concatMap attr
--   attr (n,v) = " "++n++"='"++v++"'"


htmlprint :: [Content i] -> Pretty.Doc
htmlprint :: forall i. [Content i] -> Doc
htmlprint = [Doc] -> Doc
Pretty.cat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall {i}. Content i -> Doc
cprint forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {i}. [Content i] -> [Content i]
foldrefs
  where
  foldrefs :: [Content i] -> [Content i]
foldrefs [] = []
  foldrefs (CString Bool
ws String
s1 i
i:CRef Reference
r i
_:CString Bool
_ String
s2 i
_:[Content i]
cs) =
              forall i. Bool -> String -> i -> Content i
CString Bool
ws (String
s1forall a. [a] -> [a] -> [a]
++String
"&"forall a. [a] -> [a] -> [a]
++Reference -> String
ref Reference
rforall a. [a] -> [a] -> [a]
++String
";"forall a. [a] -> [a] -> [a]
++String
s2) i
iforall a. a -> [a] -> [a]
: [Content i] -> [Content i]
foldrefs [Content i]
cs
  foldrefs (Content i
c:[Content i]
cs) = Content i
c forall a. a -> [a] -> [a]
: [Content i] -> [Content i]
foldrefs [Content i]
cs

--ref (RefEntity (EntityRef n)) = n     -- Actually, should look-up symtable.
--ref (RefChar (CharRef s)) = s
  ref :: Reference -> String
ref (RefEntity String
n) = String
n -- Actually, should look-up symtable.
  ref (RefChar CharRef
s) = forall a. Show a => a -> String
show CharRef
s

  cprint :: Content i -> Doc
cprint (CElem Element i
e i
_)      = forall {i}. Element i -> Doc
element Element i
e
  cprint (CString Bool
ws String
s i
_) = [Doc] -> Doc
Pretty.cat (forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
Pretty.text (CharRef -> String -> [String]
fmt CharRef
60
                                             ((if Bool
ws then forall a. a -> a
id else String -> String
deSpace) String
s)))
  cprint (CRef Reference
r i
_)       = String -> Doc
Pretty.text (String
"&"forall a. [a] -> [a] -> [a]
++Reference -> String
ref Reference
rforall a. [a] -> [a] -> [a]
++String
";")
  cprint (CMisc Misc
_ i
_)      = Doc
Pretty.empty

  element :: Element i -> Doc
element (Elem QName
n [Attribute]
as []) = String -> Doc
Pretty.text String
"<"               Doc -> Doc -> Doc
Pretty.<>
                           String -> Doc
Pretty.text (QName -> String
printableName QName
n) Doc -> Doc -> Doc
Pretty.<>
                           [Attribute] -> Doc
attrs [Attribute]
as                      Doc -> Doc -> Doc
Pretty.<>
                           String -> Doc
Pretty.text String
" />"
  element (Elem QName
n [Attribute]
as [Content i]
cs) =
                    --  ( Pretty.text "<"   Pretty.<>
                    --    Pretty.text n     Pretty.<>
                    --    attrs as          Pretty.<>
                    --    Pretty.text ">")  Pretty.$$
                    --  Pretty.nest 6 (htmlprint cs)  Pretty.$$
                    --  ( Pretty.text "</"  Pretty.<>
                    --    Pretty.text n     Pretty.<>
                    --    Pretty.text ">" )
                        [Doc] -> Doc
Pretty.fcat [ String -> Doc
Pretty.text String
"<"               Doc -> Doc -> Doc
Pretty.<>
                                      String -> Doc
Pretty.text (QName -> String
printableName QName
n) Doc -> Doc -> Doc
Pretty.<>
                                      [Attribute] -> Doc
attrs [Attribute]
as                      Doc -> Doc -> Doc
Pretty.<>
                                      String -> Doc
Pretty.text String
">"
                                    , CharRef -> Doc -> Doc
Pretty.nest CharRef
4 (forall i. [Content i] -> Doc
htmlprint [Content i]
cs)
                                    , String -> Doc
Pretty.text String
"</"              Doc -> Doc -> Doc
Pretty.<>
                                      String -> Doc
Pretty.text (QName -> String
printableName QName
n) Doc -> Doc -> Doc
Pretty.<>
                                      String -> Doc
Pretty.text String
">"
                                    ]

  attrs :: [Attribute] -> Doc
attrs = [Doc] -> Doc
Pretty.cat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Attribute -> Doc
attribute
  attribute :: Attribute -> Doc
attribute (QName
n,v :: AttValue
v@(AttValue [Either String Reference]
_)) =
               String -> Doc
Pretty.text String
" "               Doc -> Doc -> Doc
Pretty.<>
               String -> Doc
Pretty.text (QName -> String
printableName QName
n) Doc -> Doc -> Doc
Pretty.<>
               String -> Doc
Pretty.text String
"='"              Doc -> Doc -> Doc
Pretty.<>
               String -> Doc
Pretty.text (forall a. Show a => a -> String
show AttValue
v)          Doc -> Doc -> Doc
Pretty.<>
               String -> Doc
Pretty.text String
"'"

  fmt :: CharRef -> String -> [String]
fmt CharRef
_ [] = []
  fmt CharRef
n String
s  = let (String
top,String
bot) = forall a. CharRef -> [a] -> ([a], [a])
splitAt CharRef
n String
s
                 (String
word,String
left) = forall {a}. (a -> Bool) -> [a] -> ([a], [a])
keepUntil Char -> Bool
isSpace (forall a. [a] -> [a]
reverse String
top)
             in if forall (t :: * -> *) a. Foldable t => t a -> CharRef
length String
top forall a. Ord a => a -> a -> Bool
< CharRef
n then [String
s]
                else if Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
left) then
                     forall a. [a] -> [a]
reverse String
leftforall a. a -> [a] -> [a]
: CharRef -> String -> [String]
fmt CharRef
n (String
wordforall a. [a] -> [a] -> [a]
++String
bot)
                else let (String
big,String
rest) = forall {a}. (a -> Bool) -> [a] -> ([a], [a])
keepUntil Char -> Bool
isSpace String
s
                     in forall a. [a] -> [a]
reverse String
bigforall a. a -> [a] -> [a]
: CharRef -> String -> [String]
fmt CharRef
n String
rest

  deSpace :: String -> String
deSpace []     = []
  deSpace (Char
c:String
cs) | Char
cforall a. Eq a => a -> a -> Bool
==Char
'\n'   = String -> String
deSpace (Char
' 'forall a. a -> [a] -> [a]
:String
cs)
                 | Char -> Bool
isSpace Char
c = Char
c forall a. a -> [a] -> [a]
: String -> String
deSpace (forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
cs)
                 | Bool
otherwise = Char
c forall a. a -> [a] -> [a]
: String -> String
deSpace String
cs

  keepUntil :: (a -> Bool) -> [a] -> ([a], [a])
keepUntil a -> Bool
p [a]
xs = forall {a}. (a -> Bool) -> ([a], [a]) -> ([a], [a])
select a -> Bool
p ([],[a]
xs)
      where select :: (a -> Bool) -> ([a], [a]) -> ([a], [a])
select a -> Bool
_ ([a]
ls,[])     = ([a]
ls,[])
            select a -> Bool
q ([a]
ls,a
y:[a]
ys) | a -> Bool
q a
y       = ([a]
ls,a
yforall a. a -> [a] -> [a]
:[a]
ys)
                               | Bool
otherwise = (a -> Bool) -> ([a], [a]) -> ([a], [a])
select a -> Bool
q (a
yforall a. a -> [a] -> [a]
:[a]
ls,[a]
ys)