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
=
<% title %>
<% html %>
-- 'a'
link, anchor :: (StringType m s, EmbedAsChild m c) => s -> c -> GenXML m
link url conts = <% conts %>
anchor name conts = <% conts %>
-- 'abbr' and 'acronym'
abbr, acronym :: (StringType m s1, StringType m s2)
=> s1 -> s2 -> GenXML m
abbr full a = <% a %>
acronym full a = <% a %>
-- 'address'
address :: (XMLGenerator m, EmbedAsChild m l) => [l] -> GenXML m
address ls = <% intersperse <% br %> $ map asChild ls %>
-- 'area'
area :: (StringType m alt, StringType m url, ShapeType m sh)
=> alt -> sh -> url -> GenXML m
area altTxt sh url =
{-
-- The tags +
-- 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 = <% a %>
i a = <% a %>
b a = <% a %>
big a = <% a %>
small a = <% a %>
-}
bdo :: (EmbedAsChild m a, DirType m d) => d -> a -> GenXML m
bdo dir a = <% a %>
-- 'base'
base :: (StringType m s) => s -> GenXML m
base url =
-- 'blockquote' and 'q'
blockquote, q :: EmbedAsChild m a => a -> GenXML m
blockquote a =
<% a %>
q a = <% a %>
-- 'br'
br :: XMLGenerator m => GenXML m
br =
-- 'button'
-- perhaps there should be more to this?
button :: EmbedAsChild m a => a -> GenXML m
button a =
{-
-- The 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 = <% str %>
ins str = <% str %>
-- 'div', 'span' and 'p'
div, span, p :: EmbedAsChild m a => a -> GenXML m
div a =
<% a %>
span a = <% a %>
p a =
<% a %>
-- Definition lists: 'dl', 'dt' and 'dd'
dl :: (EmbedAsChild m a, EmbedAsChild m b) => [(a,[b])] -> GenXML m
dl entries =
<% concatMap mkDef entries %>
where mkDef (a, bs) =
<% a %>
: map (\b ->
<% b %>
) 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 =
-- 'form'
form :: (StringType m s, EmbedAsChild m a) => s -> a -> GenXML m
form url conts =
-- 'head' and 'title'
head :: (StringType m s, EmbedAsChild m a) => s -> a -> GenXML m
head ttl conts =
<% ttl %><% conts %>
-- '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 =
-- 'img' and 'map'
img :: (StringType m alt, StringType m url) => alt -> url -> GenXML m
img altTxt 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 <-
mp <-
return $ [ix,mp]
-- 'input' and 'label'
label :: (StringType m s, EmbedAsChild m a) => s -> a -> GenXML m
label inp a =
--input :: InputType -> String -> HSP XML
input :: (InputType m i, StringType m s) => i -> s -> GenXML m
input itype n =
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 :: (MetaNameType m mn, StringType m s) => mn -> s -> GenXML m
meta mn conts =
-- '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 =
param :: (StringType m s1, StringType m s2) => s1 -> s2 -> GenXML m
param n v =
-- 'ol', 'ul' and 'li'
ol, orderedList, ul, unorderedList :: (EmbedAsChild m a) => [a] -> GenXML m
ol items = <% mapM listItem items %>
orderedList = ol
ul items =
<% mapM listItem items %>
unorderedList = ul
listItem :: EmbedAsChild m a => a -> GenXML m
listItem a =
<% a %>
-- 'pre'
pre :: EmbedAsChild m a => a -> GenXML m
pre a =
<% a %>
-- '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 [, ]
-- 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 :: 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 =
type OptGroup s o = (s, [o])
groupSelect :: (StringType m s, OptionType m o) => [OptGroup s o] -> GenXML m
groupSelect gs =
optgroup :: (StringType m s, OptionType m o) => s -> [o] -> GenXML m
optgroup s opts =
-- '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 = <% a %>
sup a = <% a %>
-- '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 =
<% a %>
colgroup :: (EmbedAsAttr m a, IntType m i) => i -> [[a]] -> GenXML m
colgroup spancols colattrs =
<% mapM col colattrs %>
col :: EmbedAsAttr m a => [a] -> GenXML m
col ats =
table :: (CaptionType m cap, EmbedAsChild m c) => cap -> [[c]] -> GenXML m
table cap rows =
<% cap %><% mapM tableRow rows %>
tableRow :: EmbedAsChild m a => [a] -> GenXML m
tableRow cells =
<% mapM tableCell cells %>
tableCell :: EmbedAsChild m a => a -> GenXML m
tableCell a =
<% a %>
headFootTable :: (EmbedAsChild m h, EmbedAsChild m b, EmbedAsChild m f) => h -> [[b]] -> f -> GenXML m
headFootTable hs body fs =