hsx-xhtml (empty) → 0.4.4
raw patch · 5 files changed
+587/−0 lines, 5 filesdep +basedep +hsxdep +mtlsetup-changed
Dependencies added: base, hsx, mtl
Files
- LICENSE +28/−0
- Setup.hs +2/−0
- hsx-xhtml.cabal +33/−0
- src/HSX/Layout.hs +54/−0
- src/HSX/XHTML.hs +470/−0
+ LICENSE view
@@ -0,0 +1,28 @@+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hsx-xhtml.cabal view
@@ -0,0 +1,33 @@+Name: hsx-xhtml+Version: 0.4.4+License: BSD3+License-File: LICENSE+Author: Niklas Broberg+Maintainer: Niklas Broberg <nibro@cs.chalmers.se>++Stability: Experimental+Category: Web+Synopsis: XHTML utilities to use together with HSX.+Description: XHTML utilities to use together with HSX.+ +Homepage: http://code.google.com/hsp++Build-Depends: base>3, mtl, hsx>=0.4.4+Build-Type: Simple+Tested-With: GHC==6.8.2++Hs-Source-Dirs: src+Exposed-Modules: HSX.Layout, HSX.XHTML++GHC-Options: -Wall -F -pgmFtrhsx+Extensions: MultiParamTypeClasses,+ FunctionalDependencies,+ OverlappingInstances,+ UndecidableInstances,+ FlexibleInstances,+ TypeFamilies,+ TypeSynonymInstances,+ FlexibleContexts,+ RankNTypes,+ PatternSignatures,+ ScopedTypeVariables
+ src/HSX/Layout.hs view
@@ -0,0 +1,54 @@+{-# OPTIONS_GHC -fglasgow-exts #-} +{-# OPTIONS_GHC -fallow-undecidable-instances #-} +{-# OPTIONS_GHC -fallow-overlapping-instances #-} +module HSX.Layout ( + Layout(..), IsLayout(..), + above, beside, (^^), (<>) + )where + +import Prelude hiding ((^^)) + +import HSX.XMLGenerator + +data Layoutm + = Above (Layout m) (Layout m) + | Beside (Layout m) (Layoutm) + | Item (GenChildList m) + +class IsLayout m a where + toLayout :: a -> Layout m + + +instance IsLayout m (Layout m) where + toLayout = id + +instance (EmbedAsChild m c) => IsLayout m c where + toLayout = Item . asChild + +(^^),(<>),above,beside :: (IsLayout m a, IsLayout m b) =>a -> b -> Layout m +a ^^ b = Above (toLayout a) (toLayout b) +a <> b = Beside (toLayout a) (toLayout b) +above = (^^) +beside = (<>) + + +instance XMLGenerator m => EmbedAsChild m (Layout m) where + asChild a@(Above _ _) = asChild $ + <table border="0"><% mapM mkRow $ foldAbove a %></table> + asChild b@(Beside _ _) = asChild $ + <table border="0"><tr><% mapM mkCell $ foldBeside b %></tr></table> + asChild (Item xml) = xml + +foldAbove :: Layout m -> [Layout m] +foldAbove (Above a b) = foldAbove a ++ foldAbove b +foldAbove l = [l] + +foldBeside :: Layout m -> [Layout m] +foldBeside (Beside a b) = foldBeside a ++ foldBeside b +foldBeside l = [l] + +mkRow :: (XMLGenerator m, EmbedAsChild m c) => c -> GenXML m +mkRow xml = <tr><% mkCell xml %></tr> + +mkCell :: (XMLGenerator m, EmbedAsChild m c) => c -> GenXML m +mkCell xml = <td><% xml %></td>
+ src/HSX/XHTML.hs view
@@ -0,0 +1,470 @@+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>