diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,3 @@ +#!/usr/bin/env runhaskell import Distribution.Simple main = defaultMain diff --git a/Text/TDoc/Attributes.hs b/Text/TDoc/Attributes.hs --- a/Text/TDoc/Attributes.hs +++ b/Text/TDoc/Attributes.hs @@ -39,12 +39,15 @@ newtype Cols = Cols { fromCols :: Int } newtype Style = Style { fromStyle :: String } -- put something more typeful newtype Identifier = Identifier { fromIdentifier :: String } +newtype Href = Href { fromHref :: String } $(attributes [''Width, ''Height, ''Src, ''Size, ''Alt, ''ClassAttr, ''Name - ,''Rows, ''Cols, ''Style]) + ,''Rows, ''Cols, ''Style, ''Identifier, ''Href]) +-- Common attributes instance IsNode a => IsAttributeOf ClassAttr a instance IsNode n => IsAttributeOf Style n +instance IsNode n => IsAttributeOf Identifier n width :: (WidthTag t, Width `IsAttributeOf` node) => Length -> AttributeOf t node width = TAttr widthTag . Width @@ -76,6 +79,12 @@ style :: (StyleTag t, Style `IsAttributeOf` a) => String -> AttributeOf t a style = TAttr styleTag . Style +identifier :: (IdentifierTag t, Identifier `IsAttributeOf` a) => String -> AttributeOf t a +identifier = TAttr identifierTag . Identifier + +href :: (HrefTag t, Href `IsAttributeOf` a) => String -> AttributeOf t a +href = TAttr hrefTag . Href + class (WidthTag t ,HeightTag t ,SrcTag t @@ -86,4 +95,6 @@ ,NameTag t ,RowsTag t ,ColsTag t + ,IdentifierTag t + ,HrefTag t ) => AttributeTags t diff --git a/Text/TDoc/TH.hs b/Text/TDoc/TH.hs --- a/Text/TDoc/TH.hs +++ b/Text/TDoc/TH.hs @@ -17,8 +17,7 @@ ,attributes ,tagInstances ,tagInstance - ,NodeOpt(..) - ,NodeOpts) + ,NodeOpt(..)) where import Data.Char (toLower) diff --git a/Text/TDoc/Tags.hs b/Text/TDoc/Tags.hs --- a/Text/TDoc/Tags.hs +++ b/Text/TDoc/Tags.hs @@ -179,10 +179,11 @@ hlink :: HLinkTag t => String -> Star t HLink hlink url = tStar (hLinkTag (Url url)) -$(node "Anchor" [NoTag, Inline] [] [''Span]) -class AnchorTag t where anchorTag :: Identifier -> t Anchor -anchor :: AnchorTag t => Identifier -> Unary t Anchor -anchor i = tUnary (anchorTag i) +-- TODO in HTML5 is supposed to work on blocks too. +$(node "Anchor" [NoTag, Inline] [''Href] [''Span]) +class AnchorTag t where anchorTag :: t Anchor +anchor :: AnchorTag t => Unary t Anchor +anchor = tUnary anchorTag $(node "Image" [Inline] [''Alt, ''Src, ''Height, ''Width] []) image :: ImageTag t => Nullary t Image diff --git a/Text/TDoc/XHtml.hs b/Text/TDoc/XHtml.hs --- a/Text/TDoc/XHtml.hs +++ b/Text/TDoc/XHtml.hs @@ -38,7 +38,7 @@ ItemTag :: HtmlTag Item ParagraphTag :: HtmlTag Paragraph SpanTag :: HtmlTag Span - AnchorTag :: Identifier -> HtmlTag Anchor + AnchorTag :: HtmlTag Anchor HLinkTag :: Url -> HtmlTag HLink TitleTag :: HtmlTag Title ImageTag :: HtmlTag Image @@ -57,6 +57,8 @@ TextareaTag :: HtmlTag Textarea LabelTag :: HtmlTag Label StyleTag :: HtmlTag Style + IdentifierTag :: HtmlTag Identifier + HrefTag :: HtmlTag Href AltTag :: HtmlTag Alt SrcTag :: HtmlTag Src WidthTag :: HtmlTag Width @@ -92,7 +94,7 @@ ,''UList, ''Item, ''Paragraph ,''Title, ''Image, ''Br, ''Hr, ''Table ,''Row, ''Col, ''HCol, ''Section, ''Subsection - ,''Div, ''HLink + ,''Div, ''HLink, ''Identifier, ''Href ]) instance FormAttributeTags HtmlTag @@ -115,35 +117,37 @@ 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 PreambuleTag = X.header X.! commonAttrs "head" attrs X.<< children + f TitleTag = X.thetitle X.! commonAttrs "title" attrs X.<< children + f DocumentTag = X.body X.! commonAttrs "body" attrs X.<< children + f (SectionTag x) = heading X.h1 x + f (SubsectionTag x) = heading X.h2 x + f UListTag = X.ulist X.! commonAttrs "ul" attrs X.<< children + f ItemTag = X.li X.! commonAttrs "li" attrs X.<< children + f ParagraphTag = X.p X.! commonAttrs "p" attrs X.<< children + f DivTag = X.thediv X.! commonAttrs "div" attrs X.<< children + f TableTag = X.table X.! commonAttrs "table" attrs X.<< children + f ColTag = X.td X.! commonAttrs "td" attrs X.<< children + f HColTag = X.th X.! commonAttrs "th" attrs X.<< children + f RowTag = X.tr X.! commonAttrs "tr" 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 ImageTag = assert (null children) $ X.image X.! map imageAttr attrs + f BrTag = assert (null children) $ X.br X.! commonAttrs "br" attrs + f HrTag = assert (null children) $ X.hr X.! commonAttrs "hr" attrs + f InputTag = assert (null children) $ X.input X.! map inputAttr 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 FormTag = X.form X.! map formAttr attrs X.<< children + f LabelTag = X.label X.! commonAttrs "label" attrs X.<< children + 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 = X.anchor X.! map anchorAttr attrs X.<< children f ClassAttrTag = error "impossible" f AltTag = error "impossible" f StyleTag = error "impossible" + f IdentifierTag = error "impossible" + f HrefTag = error "impossible" f SrcTag = error "impossible" f WidthTag = error "impossible" f HeightTag = error "impossible" @@ -159,74 +163,96 @@ 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 + 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 (Just ("strong", attrs')) = X.strong X.! commonAttrs "strong" attrs' X.<< children + genSpan (Just ("italics", attrs')) = X.italics X.! commonAttrs "i" attrs' X.<< children + genSpan (Just ("tt", attrs')) = X.tt X.! commonAttrs "tt" attrs' X.<< children + genSpan (Just ("small", attrs')) = X.small X.! commonAttrs "small" attrs' X.<< children + genSpan (Just ("big", attrs')) = X.big X.! commonAttrs "big" attrs' X.<< children + genSpan (Just ("sub", attrs')) = X.sub X.! commonAttrs "sub" attrs' X.<< children + genSpan (Just ("sup", attrs')) = X.sup X.! commonAttrs "sup" attrs' X.<< children + genSpan (Just ("bold", attrs')) = X.bold X.! commonAttrs "bold" attrs' X.<< children genSpan _ | null attrs = toHtml children - | otherwise = X.thespan X.! map commonAttr attrs X.<< children + | otherwise = X.thespan X.! commonAttrs "span" 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" + commonAttr :: IsNode a => String -> HtmlAttributeOf a -> HtmlAttr + commonAttr _ (TAttr ClassAttrTag (ClassAttr x)) = X.theclass x + commonAttr _ (TAttr StyleTag (Style s)) = X.thestyle s + commonAttr _ (TAttr IdentifierTag (Identifier i)) = X.identifier i + commonAttr nam _ = error $ "commonAttr: " ++ nam ++ ": bug" + commonAttrs :: IsNode a => String -> [HtmlAttributeOf a] -> [HtmlAttr] + commonAttrs = map . commonAttr + 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" + inputAttr attr = commonAttr "input" attr 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" + formAttr attr = commonAttr "form" attr 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" + 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 attr = commonAttr "img" attr 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" + selectAttr (TAttr MultipleTag Multiple) = X.multiple + selectAttr (TAttr NameTag (Name x)) = X.name x + selectAttr (TAttr SizeTag (Size x)) = X.size (show x) + selectAttr attr = commonAttr "select" attr 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" + 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 attr = commonAttr "textarea" attr 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" + optionAttr attr = commonAttr "option" attr + + anchorAttr :: HtmlAttributeOf Anchor -> HtmlAttr + anchorAttr (TAttr HrefTag (Href url)) = X.href url + anchorAttr attr = commonAttr "a" attr + +{- +TODO +commonAttr from http://www.html-5.com/attributes/ + +accesskey +class +contenteditable +contextmenu +draggable +dropzone +hidden +id +dir +lang +spellcheck +style +tabindex +title +Author-Defined data-* Attributes +on... Event Attributes +Microdata item... Attributes +XML Atttributes in HTML xmlns and xml:space + +DONE +-} instance (t ~ HtmlTag, IsNode a) => HTML (TDoc t a) where toHtml = renderTDocHtml diff --git a/tdoc.cabal b/tdoc.cabal --- a/tdoc.cabal +++ b/tdoc.cabal @@ -1,14 +1,14 @@ name: tdoc cabal-Version: >=1.2 -version: 0.2.1 +version: 0.3.0 license: BSD3 -license-file: LICENSE +license-File: LICENSE copyright: (c) Nicolas Pouillard author: Nicolas Pouillard maintainer: Nicolas Pouillard category: Text, Web synopsis: TDoc is a typed document builder with support for (X)HTML -description: TDoc is a typed document builder with support for (X)HTML +--description: stability: Experimental build-type: Simple