-------------------------------------------------------------------- -- ! -- Module : Text.TDoc.XHtml -- Copyright : (c) Nicolas Pouillard 2009-2011 -- License : BSD3 -- -- Maintainer : Nicolas Pouillard -- -------------------------------------------------------------------- {-# LANGUAGE TypeFamilies, ScopedTypeVariables, GADTs, FlexibleContexts, TemplateHaskell #-} module Text.TDoc.XHtml where import qualified Text.XHtml.Strict as X import Text.XHtml.Strict (HTML, Html, HtmlAttr, toHtml) import Control.Arrow (second) import Control.Exception (assert) import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy.Char8 as L8 import Text.TDoc.Core import Text.TDoc.Tags import Text.TDoc.TH import Text.TDoc.Attributes import Text.TDoc.Tags.Form type HtmlAttributeOf = AttributeOf HtmlTag type HtmlAttributesOf x = AttributesOf HtmlTag x type HtmlDoc = TDoc HtmlTag data HtmlTag t where RootTag :: HtmlTag Root PreambuleTag :: HtmlTag Preambule DocumentTag :: HtmlTag Document SectionTag :: (a `IsChildOf` Span) => HtmlDoc a -> HtmlTag Section SubsectionTag :: (a `IsChildOf` Span) => HtmlDoc a -> HtmlTag Subsection UListTag :: HtmlTag UList ItemTag :: HtmlTag Item ParagraphTag :: HtmlTag Paragraph SpanTag :: HtmlTag Span AnchorTag :: Identifier -> HtmlTag Anchor HLinkTag :: Url -> HtmlTag HLink TitleTag :: HtmlTag Title ImageTag :: HtmlTag Image BrTag :: HtmlTag Br HrTag :: HtmlTag Hr RawHtmlTag :: Html -> HtmlTag a TableTag :: HtmlTag Table RowTag :: HtmlTag Row ColTag :: HtmlTag Col HColTag :: HtmlTag HCol DivTag :: HtmlTag (Div a) FormTag :: HtmlTag Form InputTag :: HtmlTag Input OptionTag :: HtmlTag Option SelectTag :: HtmlTag Select TextareaTag :: HtmlTag Textarea LabelTag :: HtmlTag Label StyleTag :: HtmlTag Style AltTag :: HtmlTag Alt SrcTag :: HtmlTag Src WidthTag :: HtmlTag Width HeightTag :: HtmlTag Height ClassAttrTag :: HtmlTag ClassAttr InputTypeTag :: HtmlTag InputType NameTag :: HtmlTag Name ValueTag :: HtmlTag Value FormMethodTag :: HtmlTag FormMethod ActionTag :: HtmlTag Action SelectedTag :: HtmlTag Selected MultipleTag :: HtmlTag Multiple SizeTag :: HtmlTag Size RowsTag :: HtmlTag Rows ColsTag :: HtmlTag Cols instance LeafTags HtmlTag where charTag = RawHtmlTag . toHtml stringTag = RawHtmlTag . toHtml strictByteStringTag = RawHtmlTag . toHtml . S8.unpack lazyByteStringTag = RawHtmlTag . toHtml . L8.unpack -- instance ValueAttributeTag HtmlTag where valueTag = ValueTag -- ... -- instance ActionAttributeTag HtmlTag where actionTag = ActionTag $(tagInstances ''HtmlTag [''Value, ''Action, ''FormMethod ,''Selected, ''InputType, ''Multiple ,''Form, ''Input, ''Option, ''Select ,''Textarea, ''Label, ''Style, ''Src ,''Height, ''Width, ''ClassAttr, ''Alt ,''Name, ''Size, ''Rows, ''Cols, ''Span ,''Anchor, ''Root, ''Preambule, ''Document ,''UList, ''Item, ''Paragraph ,''Title, ''Image, ''Br, ''Hr, ''Table ,''Row, ''Col, ''HCol, ''Section, ''Subsection ,''Div, ''HLink ]) instance FormAttributeTags HtmlTag instance FormTags HtmlTag instance AttributeTags HtmlTag instance Tags HtmlTag rawHtml :: Html -> HtmlDoc a rawHtml = tNullary . RawHtmlTag rawHtml_ :: a -> Html -> HtmlDoc a rawHtml_ _ = rawHtml lookupClassAttr :: IsAttributeOf ClassAttr nodeTag => HtmlAttributesOf nodeTag -> Maybe (String, HtmlAttributesOf nodeTag) lookupClassAttr (TAttr ClassAttrTag (ClassAttr t) : attrs) = Just (t, attrs) lookupClassAttr (attr : attrs) = fmap (second (attr:)) $ lookupClassAttr attrs lookupClassAttr [] = Nothing renderTDocHtml :: forall nodeTag . IsNode nodeTag => HtmlDoc nodeTag -> Html renderTDocHtml (TNode tag attrs children) = f tag where f :: IsNode nodeTag => HtmlTag nodeTag -> Html f RootTag = toHtml children f PreambuleTag = X.header X.! map commonAttr attrs X.<< children f TitleTag = X.thetitle X.! map commonAttr attrs X.<< children f DocumentTag = X.body X.! map commonAttr attrs X.<< children f (SectionTag x)= heading X.h1 x f (SubsectionTag x) = heading X.h2 x f UListTag = X.ulist X.! map commonAttr attrs X.<< children f ItemTag = X.li X.! map commonAttr attrs X.<< children f ParagraphTag = X.p X.! map commonAttr attrs X.<< children f DivTag = X.thediv X.! map commonAttr attrs X.<< children f TableTag = X.table X.! map commonAttr attrs X.<< children f ColTag = X.td X.! map commonAttr attrs X.<< children f HColTag = X.th X.! map commonAttr attrs X.<< children f RowTag = X.tr X.! map commonAttr attrs X.<< children f SpanTag = genSpan (lookupClassAttr attrs) f (HLinkTag url)= toHtml $ X.hotlink (fromUrl url) X.! map hlinkAttr attrs X.<< children f ImageTag = assert (null children) $ X.image X.! map imageAttr attrs f BrTag = assert (null children) $ X.br X.! map commonAttr attrs f HrTag = assert (null children) $ X.hr X.! map commonAttr attrs f (RawHtmlTag h)= assert (null children) $ assert (null attrs) h f FormTag = X.form X.! map formAttr attrs X.<< children f LabelTag = X.label X.! map commonAttr attrs X.<< children f InputTag = X.input X.! map inputAttr attrs f SelectTag = X.select X.! map selectAttr attrs X.<< children f TextareaTag = X.textarea X.! map textareaAttr attrs X.<< children f OptionTag = X.option X.! map optionAttr attrs X.<< children f (AnchorTag i) = X.anchor X.! (X.identifier (fromIdentifier i) : map commonAttr attrs) X.<< children f ClassAttrTag = error "impossible" f AltTag = error "impossible" f StyleTag = error "impossible" f SrcTag = error "impossible" f WidthTag = error "impossible" f HeightTag = error "impossible" f ActionTag = error "impossible" f NameTag = error "impossible" f ValueTag = error "impossible" f FormMethodTag = error "impossible" f InputTypeTag = error "impossible" f SelectedTag = error "impossible" f MultipleTag = error "impossible" f SizeTag = error "impossible" f RowsTag = error "impossible" f ColsTag = error "impossible" heading :: (a `IsChildOf` Span) => (Html -> Html) -> HtmlDoc a -> Html heading hN child = hN {-X.! map commonAttr attrs-} X.<< child X.+++ children genSpan :: nodeTag ~ Span => Maybe (String, HtmlAttributesOf nodeTag) -> Html genSpan (Just ("strong", attrs')) = X.strong X.! map commonAttr attrs' X.<< children genSpan (Just ("italics", attrs')) = X.italics X.! map commonAttr attrs' X.<< children genSpan (Just ("tt", attrs')) = X.tt X.! map commonAttr attrs' X.<< children genSpan (Just ("small", attrs')) = X.small X.! map commonAttr attrs' X.<< children genSpan (Just ("big", attrs')) = X.big X.! map commonAttr attrs' X.<< children genSpan (Just ("sub", attrs')) = X.sub X.! map commonAttr attrs' X.<< children genSpan (Just ("sup", attrs')) = X.sup X.! map commonAttr attrs' X.<< children genSpan (Just ("bold", attrs')) = X.bold X.! map commonAttr attrs' X.<< children genSpan _ | null attrs = toHtml children | otherwise = X.thespan X.! map commonAttr attrs X.<< children commonAttr :: IsNode a => HtmlAttributeOf a -> HtmlAttr commonAttr (TAttr ClassAttrTag (ClassAttr x)) = X.theclass x commonAttr (TAttr StyleTag (Style s)) = X.thestyle s commonAttr _ = error "commonAttr: bug" hlinkAttr :: HtmlAttributeOf HLink -> HtmlAttr hlinkAttr = undefined inputAttr :: HtmlAttributeOf Input -> HtmlAttr inputAttr (TAttr ClassAttrTag (ClassAttr x)) = X.theclass x inputAttr (TAttr StyleTag (Style x)) = X.thestyle x inputAttr (TAttr InputTypeTag it) = X.thetype . show $ it inputAttr (TAttr NameTag (Name n)) = X.name n inputAttr (TAttr ValueTag (Value n)) = X.value n inputAttr _ = error "inputAttr: bug" formAttr :: HtmlAttributeOf Form -> HtmlAttr formAttr (TAttr ClassAttrTag (ClassAttr x)) = X.theclass x formAttr (TAttr StyleTag (Style x)) = X.thestyle x formAttr (TAttr FormMethodTag fm) = X.method . show $ fm formAttr (TAttr ActionTag (Action a)) = X.action a formAttr _ = error "formAttr: bug" imageAttr :: HtmlAttributeOf Image -> HtmlAttr imageAttr (TAttr ClassAttrTag (ClassAttr x)) = X.theclass x imageAttr (TAttr StyleTag (Style x)) = X.thestyle x imageAttr (TAttr AltTag (Alt a)) = X.alt a imageAttr (TAttr SrcTag (Src a)) = X.src a imageAttr (TAttr WidthTag (Width w)) = X.width . show . toPixels $ w imageAttr (TAttr HeightTag (Height h)) = X.height . show . toPixels $ h imageAttr _ = error "imageAttr: bug" selectAttr :: HtmlAttributeOf Select -> HtmlAttr selectAttr (TAttr ClassAttrTag (ClassAttr x)) = X.theclass x selectAttr (TAttr StyleTag (Style x)) = X.thestyle x selectAttr (TAttr MultipleTag Multiple) = X.multiple selectAttr (TAttr NameTag (Name x)) = X.name x selectAttr (TAttr SizeTag (Size x)) = X.size (show x) selectAttr _ = error "selectAttr: bug" textareaAttr :: HtmlAttributeOf Textarea -> HtmlAttr textareaAttr (TAttr ClassAttrTag (ClassAttr x)) = X.theclass x textareaAttr (TAttr StyleTag (Style x)) = X.thestyle x textareaAttr (TAttr NameTag (Name x)) = X.name x textareaAttr (TAttr RowsTag (Rows x)) = X.rows (show x) textareaAttr (TAttr ColsTag (Cols x)) = X.cols (show x) textareaAttr _ = error "textareaAttr: bug" optionAttr :: HtmlAttributeOf Option -> HtmlAttr optionAttr (TAttr ClassAttrTag (ClassAttr x)) = X.theclass x optionAttr (TAttr StyleTag (Style x)) = X.thestyle x optionAttr (TAttr ValueTag (Value n)) = X.value n optionAttr (TAttr SelectedTag Selected) = X.selected optionAttr _ = error "optionAttr: bug" instance (t ~ HtmlTag, IsNode a) => HTML (TDoc t a) where toHtml = renderTDocHtml instance t ~ HtmlTag => HTML (ChildOf t fatherTag) where toHtml (Child x) = renderTDocHtml x ex :: IO () ex = putStr $ X.prettyHtml $ toHtml $ root (preambule $ title "t") $ document $ do section "s1" << subsection "ss1" << do para << "p1" ulist << do item << para "a" item << para << do put "b" put "c" para << "p1" section "s2" << subsection "ss2" << do para << do put "p2a" put br put "p2b" para << ["p3a", "p3b"] put hr para << string "p4" put $ para ["p5a", "p5b"] section "s3" << () put hr section "s4" << subsection "ss4" << para << "p5" section "s5" << [hr,hr] --end