[commit: xhtml] master: Add CHANGEATTRS and htmlAttrPair (5c08c76)

Repository : ssh://darcs.haskell.org//srv/darcs/packages/xhtml

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/5c08c761e1137610d5feb56aa8ff28c90754b097

>---------------------------------------------------------------

commit 5c08c761e1137610d5feb56aa8ff28c90754b097
Author: Chris Dornan <[email protected]>
Date:   Wed May 9 18:38:37 2012 +0100

    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] https://github.com/haskell/xhtml/issues/2
    
    [2] http://www.w3.org/WAI/GL/WCAG20-TECHS/H94.html

>---------------------------------------------------------------

 .gitignore                 |    2 ++
 Text/XHtml/Frameset.hs     |    4 ++--
 Text/XHtml/Internals.hs    |   22 ++++++++++++++++++++--
 Text/XHtml/Strict.hs       |    4 ++--
 Text/XHtml/Transitional.hs |    4 ++--
 5 files changed, 28 insertions(+), 8 deletions(-)

diff --git a/.gitignore b/.gitignore
index 8fa219b..468db0f 100644
--- a/.gitignore
+++ b/.gitignore
@@ -3,3 +3,5 @@ dist
 GNUmakefile
 dist-install/
 ghc.mk
+test.hs
+.hub
diff --git a/Text/XHtml/Frameset.hs b/Text/XHtml/Frameset.hs
index befc499..453bff1 100644
--- a/Text/XHtml/Frameset.hs
+++ b/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, 
diff --git a/Text/XHtml/Internals.hs b/Text/XHtml/Internals.hs
index ed13e7d..083f19a 100644
--- a/Text/XHtml/Internals.hs
+++ b/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
 
 
diff --git a/Text/XHtml/Strict.hs b/Text/XHtml/Strict.hs
index fdb2a39..73dd343 100644
--- a/Text/XHtml/Strict.hs
+++ b/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
diff --git a/Text/XHtml/Transitional.hs b/Text/XHtml/Transitional.hs
index 71a8bce..99af40c 100644
--- a/Text/XHtml/Transitional.hs
+++ b/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,