src/HSX/XHTML.hs

module HSX.XHTML where

import HSX.XMLGenerator

import Data.List (intersperse)

------------------------------------------
-- We need separate classes for each separate
-- type that we want to parametrize over.

class (XMLGenerator m, EmbedAsChild m t, EmbedAsAttr m (Attr String t)) => StringType    m t
class (XMLGenerator m,                   EmbedAsAttr m (Attr String t)) => IntType       m t
class (XMLGenerator m,                   EmbedAsAttr m (Attr String t)) => BoolType      m t
class (XMLGenerator m,                   EmbedAsAttr m (Attr String t)) => ShapeType     m t
class (XMLGenerator m,                   EmbedAsAttr m (Attr String t)) => DirType       m t
class (XMLGenerator m, EmbedAsChild m t                               ) => LegendType    m t
class (XMLGenerator m,                   EmbedAsAttr m t              ) => InputType     m t
class (XMLGenerator m,                   EmbedAsAttr m t              ) => CheckedType   m t
class (XMLGenerator m,                   EmbedAsAttr m t              ) => HTTPEquivType m t
class (XMLGenerator m,                   EmbedAsAttr m t              ) => MetaNameType  m t
class (XMLGenerator m, EmbedAsChild m t, EmbedAsAttr m t              ) => ScriptType    m t
class (XMLGenerator m, EmbedAsChild m t, EmbedAsAttr m t              ) => OptionType    m t
class (XMLGenerator m, EmbedAsChild m t                               ) => CaptionType   m t

-- We already get the appropriate EmbedAsChild and EmbedAsAttr instances
-- from XMLGenerator, which has them as super-classes for String, Int and Bool.
instance XMLGenerator m => StringType m String
instance XMLGenerator m => IntType    m Int
instance XMLGenerator m => BoolType   m Bool

-----------------------------------------

page ::(StringType m title, 
         EmbedAsAttr m a, 
         EmbedAsChild m body) 
        => title -> [a] -> body -> GenXML m
page title attrs html
 = <html>
     <head>
       <title><% title %></title>
     </head>
     <body attrs><% html %></body>
   </html> 


-- 'a'

link, anchor :: (StringType m s, EmbedAsChild m c) => s -> c -> GenXML m
link   url  conts = <a href=url><% conts %></a>
anchor name conts = <a id=name><% conts %></a>

-- 'abbr' and 'acronym'


abbr, acronym :: (StringType m s1, StringType m s2)
        => s1 -> s2 -> GenXML m
abbr    full a = <abbr title=full><% a %></abbr>
acronym full a = <acronym title=full><% a %></acronym>

-- 'address'

address :: (XMLGenerator m, EmbedAsChild m l) => [l] -> GenXML m
address ls = <address><% intersperse <% br %> $ map asChild ls  %></address>

-- 'area'
area :: (StringType m alt, StringType m url, ShapeType m sh) 
      => alt -> sh -> url -> GenXML m
area altTxt sh url = 
        <area 
          alt=altTxt 
          shape=sh 
          coords=sh
          href=url
         />

{-
-- The <tt> <i> <b> <big> <small> tags + <bdo>
-- TODO: check if these may contain other tags
-- TODO: these should be simulated with style!

--tt, i, b, big, small, rtl :: IsXMLs a => a -> HSP XML
tt, i, b, big, small :: EmbedAsChild m a => a -> GenXML m
tt a      = <tt><% a %></tt>
i a       = <i><% a %></i>
b a       = <b><% a %></b>
big a     = <big><% a %></big>
small a   = <small><% a %></small>
-}

bdo :: (EmbedAsChild m a, DirType m d) => d -> a -> GenXML m
bdo dir a = <bdo dir=dir><% a %></bdo>

-- 'base'
base :: (StringType m s) => s -> GenXML m
base url = <base href=url />

-- 'blockquote' and 'q'

blockquote, q :: EmbedAsChild m a => a -> GenXML m
blockquote a = <blockquote><% a %></blockquote>
q a = <q><% a %></q>

-- 'br'
br :: XMLGenerator m => GenXML m
br = <br/>

-- 'button'
-- perhaps there should be more to this? 

button :: EmbedAsChild m a => a -> GenXML m
button a = <button><% a %></button>

{-

-- The <em> <strong> <dfn> <code> <samp> <kbd> <var> <cite> tags
-- These should be simulated with style!

em, strong, dfn, code, samp, kbd, var, cite :: 
-}

-- 'del' and 'ins'

del, ins :: (StringType m s) => s -> GenXML m
del str = <del><% str %></del>
ins str = <ins><% str %></ins>

-- 'div', 'span' and 'p'

div, span, p :: EmbedAsChild m a => a -> GenXML m
div a  = <div><% a %></div>
span a = <span><% a %></span>
p a    = <p><% a %></p>

-- Definition lists: 'dl', 'dt' and 'dd'

dl :: (EmbedAsChild m a, EmbedAsChild m b) => [(a,[b])] -> GenXML m
dl entries = <dl><% concatMap mkDef entries %></dl>
  where mkDef (a, bs) = <dt><% a %></dt> : map (\b -> <dd><% b %></dd>) bs

-- 'fieldset' and 'legend'

--fieldset :: IsXMLs c => Legend -> c -> HSP XML
fieldset :: (LegendType m l, EmbedAsChild m a) => l -> a -> GenXML m
fieldset lgd conts =
        <fieldset>
          <% lgd %>
          <% conts %>
        </fieldset>

-- 'form'

form :: (StringType m s, EmbedAsChild m a) => s -> a -> GenXML m
form url conts = <form action=url><% conts %></form>

-- 'head' and 'title'

head :: (StringType m s, EmbedAsChild m a) => s -> a -> GenXML m
head ttl conts =
        <head><title><% ttl %></title><% conts %></head>



-- 'h1' - 'h6'

-- This one would do well with some way of defining 
-- tag names from expressions!
h :: EmbedAsChild m a => Int -> a -> GenXML m
h n a = genElement (Nothing, ("h" ++ show n)) [] [asChild a]

h1,h2,h3,h4,h5,h6 :: EmbedAsChild m a => a -> GenXML m
h1 = h 1
h2 = h 2
h3 = h 3
h4 = h 4
h5 = h 5
h6 = h 6

-- 'hr'

hr :: XMLGenerator m => GenXML m
hr = <hr />

-- 'img' and 'map'

img :: (StringType m alt, StringType m url) => alt -> url -> GenXML m
img altTxt url = <img alt=altTxt src=url />

imgmap :: (StringType m alt, StringType m url, StringType m map, 
           StringType m aalt, StringType m aurl, ShapeType m sh) 
        => alt -> url -> (map, [(aalt, sh, aurl)]) -> GenXMLList m
imgmap altTxt url (im,areas) =
        do ix <- <img alt=altTxt src=url ismap=True usemap=im />
           mp <- <map id=im name=im><% map (\(a,s,u) -> area a s u) areas %></map>
           return $ [ix,mp]


-- 'input' and 'label'

label :: (StringType m s, EmbedAsChild m a) => s -> a -> GenXML m
label inp a = <label for=inp><% a %></label>


--input :: InputType -> String -> HSP XML
input :: (InputType m i, StringType m s) => i -> s -> GenXML m
input itype n = <input name=n [itype] />

data Input c s
        = Checkbox c
        | File 
        | Image s s
        | Hidden 
        | Button s
        | Password 
        | Text 
        | Radio c
        | Submit s
        | Reset s

type CInput c = Input c String
type SInput s = Input Checked s

data Checked = Checked | Unchecked

instance XMLGenerator m => EmbedAsAttr m Checked where
 asAttr Checked   = asAttr ("checked" := "checked")
 asAttr Unchecked = return []

instance XMLGenerator m => CheckedType m Checked

instance (XMLGenerator m, CheckedType m c, StringType m s) => EmbedAsAttr m (Input c s) where
  asAttr inp = do
        t  <- asAttr $ typeOf inp
        es <- extras inp
        return $ t ++ es
    where typeOf i = let t = case i of
                              Checkbox _ -> "checkbox"
                              File       -> "file"
                              Image _ _  -> "image"
                              Hidden     -> "hidden"
                              Button _   -> "button"
                              Password   -> "password"
                              Text       -> "text"
                              Radio _    -> "radio"
                              Submit _   -> "submit"
                              Reset _    -> "reset"
                      in "type" := t
          extras i = case i of
                Checkbox b        -> asAttr b
                Radio b           -> asAttr b
                Image altText url -> asAttr ["alt" := altText, "src" := url]
                Button val        -> asAttr ["value" := val]
                Submit val        -> asAttr ["value" := val]
                Reset  val        -> asAttr ["value" := val]
                _                 -> return []

instance (XMLGenerator m, CheckedType m c, StringType m s) => InputType m (Input c s)

submitButton, resetButton :: forall m n v . (StringType m n, StringType m v) => n -> v -> GenXML m
submitButton n val = input (Submit val :: SInput v) n
resetButton  n val = input (Reset  val :: SInput v) n


--checkbox :: Bool -> String -> String -> HSP [XML]

checkbox :: forall m c s1 s2 . (CheckedType m c, StringType m s1, StringType m s2) => c -> s1 -> s2 -> GenXMLList m
checkbox check n lbl = 
        sequence $ [input (Checkbox check :: CInput c) n, label lbl n]

-- TODO: Should be more fancy stuff in here

-- 'meta'

data HTTPEquiv
        = ContentType
        | Expires
        | Refresh
        | SetCookie

instance XMLGenerator m => EmbedAsAttr m HTTPEquiv where
  asAttr he = asAttr ("http-equiv" := toStr he)
    where toStr ContentType = "content-type"
          toStr Expires     = "expires"
          toStr Refresh     = "refresh"
          toStr SetCookie   = "set-cookie"

instance XMLGenerator m => HTTPEquivType m HTTPEquiv

data MetaName
        = Author
        | Description
        | Keywords
        | Generator
        | Revised
        | Others String

instance XMLGenerator m => EmbedAsAttr m MetaName where
  asAttr mn = asAttr ("name" := toStr mn) 
    where toStr Author      = "author"
          toStr Description = "description"
          toStr Keywords    = "keywords"
          toStr Generator   = "generator"
          toStr Revised     = "revised"
          toStr (Others s)  = s

instance XMLGenerator m => MetaNameType m MetaName

httpEquiv :: (HTTPEquivType m h, StringType m s) => h -> s -> GenXML m
httpEquiv equiv conts = <meta content=conts [equiv] />

meta :: (MetaNameType m mn, StringType m s) => mn -> s -> GenXML m
meta mn conts = <meta content=conts [mn] />

-- 'object' and 'param'

-- This one is rather difficult to standardise, I'll leave that to
-- libs to fix.

--object :: IsXMLs a => [(String,String)] -> a -> HSP XML
object :: (EmbedAsChild m a, StringType m s1, StringType m s2)
        => [(s1, s2)] -> a -> GenXML m
object pars alt = <object><% alt %><% mapM (uncurry param) pars %></object>

param :: (StringType m s1, StringType m s2) => s1 -> s2 -> GenXML m
param n v = <param name=n value=v />


-- 'ol', 'ul' and 'li'

ol, orderedList, ul, unorderedList :: (EmbedAsChild m a) => [a] -> GenXML m
ol items = <ol><% mapM listItem items %></ol>
orderedList = ol
ul items = <ul><% mapM listItem items %></ul>
unorderedList = ul

listItem :: EmbedAsChild m a => a -> GenXML m
listItem a = <li><% a %></li>

-- 'pre'

pre :: EmbedAsChild m a => a -> GenXML m
pre a = <pre><% a %></pre>

-- 'script' and 'noscript'

--script :: IsXMLs a => Script -> a -> [HSP XML]
script :: (ScriptType m s, EmbedAsChild m a) => s -> a -> GenXMLList m
script sc alt = sequence [<script [sc]><% sc %></script>, <noscript><% alt %></noscript>]

-- TODO: import HSP.JavaScript

data JavaScript s = JavaScript s

instance XMLGenerator m => EmbedAsAttr m (JavaScript s) where
 asAttr _ = asAttr ("type" := "text/javascript")

instance EmbedAsChild m s => EmbedAsChild m (JavaScript s) where
 asChild (JavaScript s) = asChild s

instance (XMLGenerator m, EmbedAsChild m s) => ScriptType m (JavaScript s)


-- 'select', 'option' and 'optgroup'

data Option s
        = Selected s s
        | Unselected s s

mkOption :: StringType m s => s -> s -> Bool -> Option s
mkOption conts val sel = case sel of
        True -> Selected conts val
        _    -> Unselected conts val

instance StringType m s => EmbedAsAttr m (Option s) where
 asAttr (Selected v _)   = asAttr ("selected":="selected") >>= 
                                \ss -> asAttr ("value":=v) >>= 
                                \vs -> return $ ss ++ vs
 asAttr (Unselected v _) = asAttr ("value":=v)
 



instance StringType m s => EmbedAsChild m (Option s) where
 asChild (Selected   _ c) = asChild c
 asChild (Unselected _ c) = asChild c

instance StringType m s => OptionType m (Option s)

select' :: OptionType m o => [GenAttributeList m] -> [o] -> GenXML m
select' attrs opts = <select attrs><% mapM option opts %></select>

select :: forall m o . OptionType m o => [o] -> GenXML m
select = select' [return []]

multiSelect :: forall m o . OptionType m o => [o] -> GenXML m
multiSelect = select' [asAttr $ "multiple" := "multiple"]

sizedSelect :: (IntType m i, OptionType m o) => i -> [o] -> GenXML m
sizedSelect n = select' [asAttr $ "size" := n]

sizedMultiSelect :: (IntType m i, OptionType m o) => i -> [o] -> GenXML m
sizedMultiSelect n = select' [asAttr $ "multiple" := "multiple", asAttr $ "size" := n]

option :: OptionType m o => o -> GenXML m
option opt = <option [opt]><% opt %></option>

type OptGroup s o = (s, [o])

groupSelect :: (StringType m s, OptionType m o) => [OptGroup s o] -> GenXML m
groupSelect gs = <select><% mapM (uncurry optgroup) gs %></select>

optgroup :: (StringType m s, OptionType m o) => s -> [o] -> GenXML m
optgroup s opts = <optgroup label=s><% mapM option opts %></optgroup>

-- 'style'

-- I'll leave this for later, need to implement styles first.

-- 'sub' and 'sup'

sub, sup :: EmbedAsChild m a => a -> GenXML m
sub a = <sub><% a %></sub>
sup a = <sup><% a %></sup>

-- 'table', 'tr', 'td', 'th' and 'caption', 
-- 'colgroup' and 'col',
-- 'thead', 'tfoot' and 'tbody'


data Caption a
        = Caption a
        | NoCaption

capt :: a -> Caption a
capt = Caption
noCapt :: Caption a
noCapt = NoCaption

instance EmbedAsChild m c => EmbedAsChild m (Caption c) where
 asChild NoCaption   = return []
 asChild (Caption a) = asChild $ caption a

instance (XMLGenerator m, EmbedAsChild m c) => CaptionType m (Caption c)

caption :: EmbedAsChild m c => c -> GenXML m
caption a = <caption><% a %></caption>


colgroup :: (EmbedAsAttr m a, IntType m i) => i -> [[a]] -> GenXML m
colgroup spancols colattrs = 
        <colgroup span=spancols><% mapM col colattrs %></colgroup>

col :: EmbedAsAttr m a => [a] -> GenXML m
col ats = <col ats />

table :: (CaptionType m cap, EmbedAsChild m c) => cap -> [[c]] -> GenXML m
table cap rows = <table><% cap %><% mapM tableRow rows %></table>

tableRow :: EmbedAsChild m a => [a] -> GenXML m
tableRow cells = <tr><% mapM tableCell cells %></tr>

tableCell :: EmbedAsChild m a => a -> GenXML m
tableCell a = <td><% a %></td>

headFootTable :: (EmbedAsChild m h, EmbedAsChild m b, EmbedAsChild m f) => h -> [[b]] -> f -> GenXML m
headFootTable hs body fs =
        <table>
          <thead><% hs %></thead>
          <tfoot><% fs %></tfoot>
          <tbody><% mapM tableRow body %></tbody>
        </table>