Add CHANGEATTRS and htmlAttrPair

Mistuke has pointed out that (!) does not allow attributes to be added
to a general (X)HTML tag while taking account of the attributes that
are already defined by the tag [1]. This can make it hard to generally
extend tags with attributes while even being sure that correct (X)HTML
is being generated (the standard prohibits the duplication of
attributes[2]).

In order to minimize disruption the existing interface has been
extended with an alternative class to `ADDATTRS` called `CHANGEATTRS`
and a deconstructor function, `htmlAttrPair`, for analysing the
(abstract) `HtmlAttr` type. With `CHANGEATTRS` a function is used to
transform the existing attributes (which can now be analysed with
`htmlAttrPair`) rather than being passed a list of attributes to add
to an HTML tag as is the case with `ADDATTRS`.

[1] #2

[2] http://www.w3.org/WAI/GL/WCAG20-TECHS/H94.html

.gitignore

@@ -3,3 +3,5 @@ dist
 GNUmakefile
 dist-install/
 ghc.mk
+test.hs
+.hub

Text/XHtml/Frameset.hs

@@ -7,11 +7,11 @@ module Text.XHtml.Frameset (
      -- * Data types
      Html, HtmlAttr,
      -- * Classes
-     HTML(..), ADDATTRS(..),
+     HTML(..), ADDATTRS(..), CHANGEATTRS(..),
      -- * Primitives and basic combinators
      (<<), concatHtml, (+++), 
      noHtml, isNoHtml, tag, itag,
-     emptyAttr, intAttr, strAttr, htmlAttr,
+     htmlAttrPair, emptyAttr, intAttr, strAttr, htmlAttr,
      primHtml, 
      -- * Rendering
      showHtml, renderHtml, prettyHtml, 

Text/XHtml/Internals.hs

@@ -46,6 +46,10 @@ data HtmlElement
 data HtmlAttr = HtmlAttr String String
 
 
+htmlAttrPair :: HtmlAttr -> (String,String)
+htmlAttrPair (HtmlAttr n v) = (n,v)
+
+
 newtype Html = Html { getHtmlElements :: [HtmlElement] }
 
 
@@ -93,14 +97,28 @@ instance HTML a => HTML (Maybe a) where
 class ADDATTRS a where
       (!) :: a -> [HtmlAttr] -> a
 
+-- | CHANGEATTRS is a more expressive alternative to ADDATTRS
+class CHANGEATTRS a where
+      changeAttrs :: a -> ([HtmlAttr]->[HtmlAttr]) -> a
+
 instance (ADDATTRS b) => ADDATTRS (a -> b) where
-      fn ! attr = \ arg -> fn arg ! attr
+      fn ! attr        = \ arg -> fn arg ! attr
+
+instance (CHANGEATTRS b) => CHANGEATTRS (a -> b) where
+      changeAttrs fn f = \ arg -> changeAttrs (fn arg) f
 
 instance ADDATTRS Html where
       (Html htmls) ! attr = Html (map addAttrs htmls)
         where
               addAttrs (html@(HtmlTag { markupAttrs = attrs }) )
-                              = html { markupAttrs = attrs ++ attr }
+                            = html { markupAttrs = attrs ++ attr }
+              addAttrs html = html
+
+instance CHANGEATTRS Html where
+      changeAttrs (Html htmls) f = Html (map addAttrs htmls)
+        where
+              addAttrs (html@(HtmlTag { markupAttrs = attrs }) )
+                            = html { markupAttrs = f attrs }
               addAttrs html = html
 
 

Text/XHtml/Strict.hs

@@ -7,11 +7,11 @@ module Text.XHtml.Strict (
      -- * Data types
      Html, HtmlAttr,
      -- * Classes
-     HTML(..), ADDATTRS(..),
+     HTML(..), ADDATTRS(..), CHANGEATTRS(..),
      -- * Primitives and basic combinators
      (<<), concatHtml, (+++), 
      noHtml, isNoHtml, tag, itag,
-     emptyAttr, intAttr, strAttr, htmlAttr,
+     htmlAttrPair, emptyAttr, intAttr, strAttr, htmlAttr,
      primHtml, stringToHtmlString,
      docType,
      -- * Rendering

Text/XHtml/Transitional.hs

@@ -7,11 +7,11 @@ module Text.XHtml.Transitional (
      -- * Data types
      Html, HtmlAttr,
      -- * Classes
-     HTML(..), ADDATTRS(..),
+     HTML(..), ADDATTRS(..), CHANGEATTRS(..),
      -- * Primitives and basic combinators
      (<<), concatHtml, (+++), 
      noHtml, isNoHtml, tag, itag,
-     emptyAttr, intAttr, strAttr, htmlAttr,
+     htmlAttrPair, emptyAttr, intAttr, strAttr, htmlAttr,
      primHtml, 
      -- * Rendering
      showHtml, renderHtml, prettyHtml,