tdoc (empty) → 0.2.0
raw patch · 11 files changed
+1115/−0 lines, 11 filesdep +basedep +bytestringdep +template-haskellsetup-changed
Dependencies added: base, bytestring, template-haskell, transformers, xhtml
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- Text/TDoc.hs +22/−0
- Text/TDoc/Attributes.hs +89/−0
- Text/TDoc/Core.hs +164/−0
- Text/TDoc/QQ.hs +42/−0
- Text/TDoc/TH.hs +98/−0
- Text/TDoc/Tags.hs +233/−0
- Text/TDoc/Tags/Form.hs +142/−0
- Text/TDoc/XHtml.hs +267/−0
- tdoc.cabal +26/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2009, 2010, 2011, Nicolas Pouillard+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * 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.++ * Neither the name of the copyright holders nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"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 COPYRIGHT+OWNER 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
+ Text/TDoc.hs view
@@ -0,0 +1,22 @@+--------------------------------------------------------------------+-- !+-- Module : Text.TDoc+-- Copyright : (c) Nicolas Pouillard 2009-2011+-- License : BSD3+--+-- Maintainer : Nicolas Pouillard <nicolas.pouillard@gmail.com>+--+--------------------------------------------------------------------++module Text.TDoc+ ( module Text.TDoc.Core+ , module Text.TDoc.Attributes+ , module Text.TDoc.Tags+ , module Text.TDoc.Tags.Form+ )+ where++import Text.TDoc.Core+import Text.TDoc.Attributes+import Text.TDoc.Tags+import Text.TDoc.Tags.Form
+ Text/TDoc/Attributes.hs view
@@ -0,0 +1,89 @@+--------------------------------------------------------------------+-- !+-- Module : Text.TDoc.Attributes+-- Copyright : (c) Nicolas Pouillard 2009-2011+-- License : BSD3+--+-- Maintainer : Nicolas Pouillard <nicolas.pouillard@gmail.com>+--+--------------------------------------------------------------------++{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses,+ TemplateHaskell #-}+module Text.TDoc.Attributes where++import Text.TDoc.Core+import Text.TDoc.TH (attributes)++data Length = Px Int+ | Cm Int+ | Em Int++instance Show Length where+ show (Px x) = show x ++ "px"+ show (Cm x) = show x ++ "cm"+ show (Em x) = show x ++ "em"++toPixels :: Length -> Int+toPixels (Px x) = x+toPixels _ = error "toPixels: wrong unit"++newtype Width = Width { fromWidth :: Length }+newtype Height = Height { fromHeight :: Length }+newtype Src = Src { fromSrc :: String }+newtype Size = Size { fromSize :: Int }+newtype Alt = Alt { fromAlt :: String }+newtype ClassAttr = ClassAttr { fromClassAttr :: String }+newtype Name = Name { fromName :: String }+newtype Rows = Rows { fromRows :: Int }+newtype Cols = Cols { fromCols :: Int }+newtype Style = Style { fromStyle :: String } -- put something more typeful+newtype Identifier = Identifier { fromIdentifier :: String }++$(attributes [''Width, ''Height, ''Src, ''Size, ''Alt, ''ClassAttr, ''Name+ ,''Rows, ''Cols, ''Style])++instance IsNode a => IsAttributeOf ClassAttr a+instance IsNode n => IsAttributeOf Style n++width :: (WidthTag t, Width `IsAttributeOf` node) => Length -> AttributeOf t node+width = TAttr widthTag . Width++height :: (HeightTag t, Height `IsAttributeOf` node) => Length -> AttributeOf t node+height = TAttr heightTag . Height++src :: (SrcTag t, Src `IsAttributeOf` node) => String -> AttributeOf t node+src = TAttr srcTag . Src++size :: (SizeTag t, Size `IsAttributeOf` a) => Int -> AttributeOf t a+size = TAttr sizeTag . Size++alt :: (AltTag t, Alt `IsAttributeOf` node) => String -> AttributeOf t node+alt = TAttr altTag . Alt++classAttr :: (ClassAttrTag t, IsNode a) => String -> AttributeOf t a+classAttr = TAttr classAttrTag . ClassAttr++name :: (NameTag t, Name `IsAttributeOf` a) => String -> AttributeOf t a+name = TAttr nameTag . Name++rows :: (RowsTag t, Rows `IsAttributeOf` a) => Int -> AttributeOf t a+rows = TAttr rowsTag . Rows++cols :: (ColsTag t, Cols `IsAttributeOf` a) => Int -> AttributeOf t a+cols = TAttr colsTag . Cols++style :: (StyleTag t, Style `IsAttributeOf` a) => String -> AttributeOf t a+style = TAttr styleTag . Style++class (WidthTag t+ ,HeightTag t+ ,SrcTag t+ ,ClassAttrTag t+ ,StyleTag t+ ,SizeTag t+ ,AltTag t+ ,NameTag t+ ,RowsTag t+ ,ColsTag t+ ) => AttributeTags t
+ Text/TDoc/Core.hs view
@@ -0,0 +1,164 @@+--------------------------------------------------------------------+-- !+-- Module : Text.TDoc.Core+-- Copyright : (c) Nicolas Pouillard 2009-2011+-- License : BSD3+--+-- Maintainer : Nicolas Pouillard <nicolas.pouillard@gmail.com>+--+--------------------------------------------------------------------++{-# LANGUAGE Rank2Types, ExistentialQuantification, MultiParamTypeClasses,+ TypeFamilies, FlexibleInstances, FlexibleContexts #-}+module Text.TDoc.Core where++import Data.Monoid+import Data.Functor.Identity+import Control.Monad.Trans.Writer++class IsNode node++class IsAttribute attr++class (IsNode father, IsNode child) => child `IsChildOf` father++class (IsAttribute attr, IsNode node) => IsAttributeOf attr node++class IsNode a => IsBlockOrInline a+class IsBlockOrInline a => IsInline a+class IsBlockOrInline a => IsBlock a++data AttributeOf t node =+ forall attr. (attr `IsAttributeOf` node) =>+ TAttr (t attr) attr++type AttributesOf t node = [AttributeOf t node]++data TDoc t tag =+ TNode { tTag :: t tag+ , tAttrs :: AttributesOf t tag+ , tChildren :: [ChildOf t tag]+ }++data ChildOf t father =+ forall child. (child `IsChildOf` father) => Child (TDoc t child)++-- ToChildren instances should only dispatch on the first argument.+-- So the to others must be variables, however you can equate+-- them in the premises.+class ToChildren a t father where+ toChildren :: a -> [ChildOf t father]++instance ToChildren a t b => ToChildren [a] t b where+ toChildren = concatMap toChildren++instance ToChildren () t b where+ toChildren () = []++instance (ToChildren a t n, ToChildren b t n) => ToChildren (a,b) t n where+ toChildren (x, y) = toChildren x ++ toChildren y++instance (ToChildren a t n+ ,ToChildren b t n+ ,ToChildren c t n+ ) => ToChildren (a,b,c) t n where+ toChildren (x, y, z) = toChildren x ++ toChildren y ++ toChildren z++instance (t1 ~ t2, a ~ b) => ToChildren (ChildOf t1 a) t2 b where+ toChildren = (:[])++instance (t1 ~ t2, a `IsChildOf` b) => ToChildren (TDoc t1 a) t2 b where+ toChildren = toChildren . Child++instance ToChildren a t b => ToChildren (Identity a) t b where+ toChildren = toChildren . runIdentity++instance (Monad m, ToChildren (m w) t b, a ~ ()) => ToChildren (WriterT w m a) t b where+ toChildren = toChildren . execWriterT++-- Like ToChildren, only dispatch on first.+class ToTDoc a t b where+ toTDoc :: a -> TDoc t b++instance (t1 ~ t2, a ~ b) => ToTDoc (TDoc t1 a) t2 b where+ toTDoc = id++instance ToTDoc a t b => ToTDoc (Identity a) t b where+ toTDoc = toTDoc . runIdentity++instance (Monad m, ToTDoc (m w) t b, a ~ ()) => ToTDoc (WriterT w m a) t b where+ toTDoc = toTDoc . execWriterT++infixl 8 !++-- Like ToChildren, only dispatch on first.+class AddAttrs a t b where+ (!) :: a -> AttributesOf t b -> a++instance (t1 ~ t2, a ~ b) => AddAttrs (TDoc t1 a) t2 b where+ (TNode tag attrs children) ! attrs' = TNode tag (attrs++attrs') children++instance AddAttrs b t c => AddAttrs (a -> b) t c where+ (f ! attrs) x = f x ! attrs++-- Like ToChildren, only dispatch on first.+class FromTDoc a t tag where+ fromTDoc :: TDoc t tag -> a++instance (t1 ~ t2, a ~ b) => FromTDoc (TDoc t1 a) t2 b where+ fromTDoc = id++instance (t1 ~ t2, b `IsChildOf` a) => FromTDoc (ChildOf t1 a) t2 b where+ fromTDoc = Child++instance FromTDoc a t tag => FromTDoc [a] t tag where+ fromTDoc = (:[]) . fromTDoc++instance FromTDoc a t tag => FromTDoc (Identity a) t tag where+ fromTDoc = Identity . fromTDoc++instance (Monad m, FromTDoc w t tag, Monoid w, a ~ ()) => FromTDoc (WriterT w m a) t tag where+ fromTDoc = tell . fromTDoc++type PutM a = Writer [a] ()++type Star t node+ = forall children. ToChildren children t node =>+ children -> TDoc t node++type Nullary t node+ = TDoc t node++type Unary t node+ = forall child. (child `IsChildOf` node) =>+ TDoc t child -> TDoc t node++type Plus t node+ = forall children child. (child `IsChildOf` node, ToChildren children t node) =>+ TDoc t child -> children -> TDoc t node++infixr 7 <<+infixr 2 +++++(+++) :: (ToChildren a t tag, ToChildren b t tag) => a -> b -> [ChildOf t tag]+a +++ b = toChildren a ++ toChildren b++-- | This operator is an infix sugar for 'put'+-- @paragraph << do ...@ is equal to @put $ paragraph $ do ...@.+(<<) :: (a `IsChildOf` b) => (c -> TDoc t a) -> c -> PutM (ChildOf t b)+(<<) f = put . f++put :: ToChildren children t father => children -> PutM (ChildOf t father)+put = tell . toChildren++tStar :: t a -> Star t a+tStar tag = TNode tag [] . toChildren++tNullary :: t a -> Nullary t a+tNullary tag = TNode tag [] []++tUnary :: t a -> Unary t a+tUnary tag = tStar tag . toChildren++tPlus :: t a -> Plus t a+tPlus tag first rest = tStar tag (Child first : toChildren rest)
+ Text/TDoc/QQ.hs view
@@ -0,0 +1,42 @@+--------------------------------------------------------------------+-- !+-- Module : Text.TDoc.QQ+-- Copyright : (c) Nicolas Pouillard 2009-2011+-- License : BSD3+--+-- Maintainer : Nicolas Pouillard <nicolas.pouillard@gmail.com>+--+--------------------------------------------------------------------++{-# LANGUAGE TemplateHaskell, FlexibleContexts #-}+module Text.TDoc.QQ (+ -- * frquotes support+ frQQ, frTop, frAntiq) where++import qualified Language.Haskell.TH as TH+import Language.Haskell.TH.Quote+import Text.TDoc (spanDoc, Star, Span, SpanTag(..), ToChildren(..), ChildOf(..))+import Data.Char (isSpace)+import Data.Monoid++frTop :: SpanTag t => Star t Span+frTop = spanDoc++frAntiq :: ToChildren a t father => a -> [ChildOf t father] +frAntiq = toChildren++expandingQQExpr :: String -> TH.ExpQ+expandingQQExpr = chunk . stripIndents+ where+ chunk x | null x = TH.varE 'mempty+ | otherwise = TH.varE 'toChildren `TH.appE` TH.stringE x++stripIndents :: String -> String+stripIndents = go+ where go (x:xs) | isSpace x = ' ' : go (dropWhile isSpace xs)+ | otherwise = x:go xs+ go "" = ""++frQQ :: QuasiQuoter+frQQ = QuasiQuoter expandingQQExpr+ (error "Text.TDoc.QQ.frQQ: not available in patterns")
+ Text/TDoc/TH.hs view
@@ -0,0 +1,98 @@+--------------------------------------------------------------------+-- !+-- Module : Text.TDoc.TH+-- Copyright : (c) Nicolas Pouillard 2009-2011+-- License : BSD3+--+-- Maintainer : Nicolas Pouillard <nicolas.pouillard@gmail.com>+--+--------------------------------------------------------------------++{-# LANGUAGE TemplateHaskell #-}+module Text.TDoc.TH+ (node+ ,nodeChildren+ ,nodeAttributes+ ,attribute+ ,attributes+ ,tagInstances+ ,tagInstance+ ,NodeOpt(..))+where++import Data.Char (toLower)+import Text.TDoc.Core (IsNode, IsChildOf, IsAttributeOf, IsAttribute+ ,IsInline, IsBlock, IsBlockOrInline)+import Language.Haskell.TH++data NodeOpt = NoTag | Inline | Block | BlockOrInline+ deriving (Eq)+type NodeOpts = [NodeOpt]++mkIs :: Name -> Name -> Dec+mkIs cl ty = InstanceD [] (ConT cl `AppT` ConT ty) []++node :: String -> NodeOpts -> [Name] -> [Name] -> Q [Dec]+node nod opts attrs children+ = return . concat+ $ [ [ DataD [] nodeNm [] [] []+ , mkIs ''IsNode nodeNm+ ]+ , [ mkIs ''IsInline nodeNm | Inline `elem` opts ]+ , [ mkIs ''IsBlock nodeNm | Block `elem` opts ]+ , [ mkIs ''IsBlockOrInline nodeNm | BlockOrInline `elem` opts+ || Block `elem` opts+ || Inline `elem` opts ]+ , [ mkTagClass nodeNm | NoTag `notElem` opts ]+ , map (`mkIsAttributeOf` nodeNm) attrs+ , map (`mkIsChildOf` nodeNm) children+ ]+ where nodeNm = mkName nod++lowerFirst :: String -> String+lowerFirst [] = error "Text.TDoc.TH.lowerFirst: []"+lowerFirst (x:xs) = toLower x : xs++mkTagName :: String -> Name+mkTagName x = mkName $ x ++ "Tag"++mkTagClass :: Name -> Dec+mkTagClass nm = ClassD [] nmTagTy [PlainTV t] []+ [SigD nmTagFun (VarT t `AppT` ConT nm)]+ where nmBase = nameBase nm+ nmTagTy = mkTagName nmBase+ nmTagFun = mkTagName $ lowerFirst nmBase+ t = mkName "t"++attribute :: Name -> Q [Dec]+attribute attr = return+ [ InstanceD [] (ConT ''IsAttribute `AppT` ConT attr) []+ , mkTagClass attr+ ]++attributes :: [Name] -> Q [Dec]+attributes = fmap concat . mapM attribute++tagInstances :: Name -> [Name] -> Q [Dec]+tagInstances tagTy = return . map (tagInstance tagTy)++tagInstance :: Name -> Name -> Dec+tagInstance tagTy nm =+ InstanceD [] (ConT nmTagCon `AppT` ConT tagTy)+ [ValD (VarP nmTagFun) (NormalB (ConE nmTagCon)) []]+ where+ nmBase = nameBase nm+ nmTagFun = mkTagName . lowerFirst $ nmBase+ nmTagCon = mkTagName nmBase++mkIsChildOf :: Name -> Name -> Dec+mkIsChildOf child nod = InstanceD [] (ConT ''IsChildOf `AppT` ConT child `AppT` ConT nod) []++mkIsAttributeOf :: Name -> Name -> Dec+mkIsAttributeOf attr nod = InstanceD [] (ConT ''IsAttributeOf `AppT` ConT attr `AppT` ConT nod) []++nodeChildren :: Name -> [Name] -> Q [Dec]+nodeChildren nod = return . map (`mkIsChildOf` nod)++nodeAttributes :: Name -> [Name] -> Q [Dec]+nodeAttributes nod = return . map (`mkIsAttributeOf` nod)
+ Text/TDoc/Tags.hs view
@@ -0,0 +1,233 @@+--------------------------------------------------------------------+-- !+-- Module : Text.TDoc.Tags+-- Copyright : (c) Nicolas Pouillard 2009-2011+-- License : BSD3+--+-- Maintainer : Nicolas Pouillard <nicolas.pouillard@gmail.com>+--+--------------------------------------------------------------------++{-# LANGUAGE TypeFamilies, ScopedTypeVariables, EmptyDataDecls,+ MultiParamTypeClasses, FlexibleContexts,+ FlexibleInstances, TemplateHaskell #-}+module Text.TDoc.Tags where++import Text.TDoc.Core+import Text.TDoc.TH (node,NodeOpt(..))+import Text.TDoc.Attributes+import qualified Data.ByteString as Strict+import qualified Data.ByteString.Lazy as Lazy++$(node "Leaf" [Inline, BlockOrInline] [] [])+newtype Url = Url { fromUrl :: String }++class LeafTags t where+ charTag :: Char -> t Leaf+ stringTag :: String -> t Leaf+ strictByteStringTag :: Strict.ByteString -> t Leaf+ lazyByteStringTag :: Lazy.ByteString -> t Leaf++instance (LeafTags t, Leaf `IsChildOf` a) => ToChildren Char t a where toChildren = toChildren . char+instance (LeafTags t, Leaf `IsChildOf` a) => ToChildren Lazy.ByteString t a where toChildren = toChildren . lazyByteString+instance (LeafTags t, Leaf `IsChildOf` a) => ToChildren Strict.ByteString t a where toChildren = toChildren . strictByteString++char :: LeafTags t => Char -> TDoc t Leaf+char = tNullary . charTag++string :: LeafTags t => String -> TDoc t Leaf+string = tNullary . stringTag++strictByteString :: LeafTags t => Strict.ByteString -> TDoc t Leaf+strictByteString = tNullary . strictByteStringTag++lazyByteString :: LeafTags t => Lazy.ByteString -> TDoc t Leaf+lazyByteString = tNullary . lazyByteStringTag++instance (LeafTags t, a ~ Leaf) => ToTDoc Char t a where+ toTDoc = char++instance (LeafTags t, b ~ Char, a ~ Leaf) => ToTDoc [b] t a where+ toTDoc = string++instance (LeafTags t, a ~ Leaf) => ToTDoc Strict.ByteString t a where+ toTDoc = strictByteString++instance (LeafTags t, a ~ Leaf) => ToTDoc Lazy.ByteString t a where+ toTDoc = lazyByteString++--++$(node "Paragraph" [Block] [] [])+instance IsInline a => IsChildOf a Paragraph+paragraph, para :: ParagraphTag t => Star t Paragraph+paragraph = tStar paragraphTag+para = paragraph++$(node "Title" [] [] [''Leaf])+title :: TitleTag t => Star t Title+title = tStar titleTag++$(node "Br" [Block, Inline] [] [])+br :: BrTag t => Nullary t Br+br = tNullary brTag++$(node "Hr" [Block, Inline] [] [])+hr :: HrTag t => Nullary t Hr+hr = tNullary hrTag++$(node "Col" [] [] [])+instance IsBlockOrInline a => IsChildOf a Col+col :: ColTag t => Star t Col+col = tStar colTag++$(node "HCol" [] [] [])+instance IsBlockOrInline a => IsChildOf a HCol+hcol :: HColTag t => Star t HCol+hcol = tStar hColTag++$(node "Row" [] [] [''Col, ''HCol])+row :: RowTag t => Star t Row+row = tStar rowTag++$(node "Table" [Block] [] [''Row])+table :: TableTag t => Star t Table+table = tStar tableTag++$(node "Item" [] [] [])+instance IsBlockOrInline a => IsChildOf a Item+item :: ItemTag t => Star t Item+item = tStar itemTag++--++$(node "UList" [Block] [] [''Item])+ulist :: UListTag t => Star t UList+ulist = tStar uListTag++-- | 'ulistQ' is a quick version of 'ulist' when all children+-- of a UList are homogeneous one can factor the building of+-- the Item nodes.+ulistQ :: (UListTag t, ItemTag t, a `IsChildOf` Item) => [TDoc t a] -> TDoc t UList+ulistQ = ulist . map item++--++$(node "Span" [NoTag, Inline] [] [])+instance IsInline a => IsChildOf a Span+class ClassAttrTag t => SpanTag t where spanTag :: t Span++spanDoc :: SpanTag t => Star t Span+spanDoc = tStar spanTag++spanDocCA :: SpanTag t => String -> Star t Span+spanDocCA ca = tStar spanTag ! [classAttr ca]++strong :: SpanTag t => Star t Span+strong = spanDocCA "strong"++small :: SpanTag t => Star t Span+small = spanDocCA "small"++big :: SpanTag t => Star t Span+big = spanDocCA "big"++italics :: SpanTag t => Star t Span+italics = spanDocCA "italics"++sub :: SpanTag t => Star t Span+sub = spanDocCA "sub"++sup :: SpanTag t => Star t Span+sup = spanDocCA "sup"++tt :: SpanTag t => Star t Span+tt = spanDocCA "tt"++bold :: SpanTag t => Star t Span+bold = spanDocCA "bold"++--++data Div a+class DivTag t where divTag :: t (Div a)+div :: DivTag t => Star t (Div a)+div = tStar divTag+instance IsNode a => IsNode (Div a)+instance IsBlock a => IsBlock (Div a)+instance IsBlockOrInline a => IsBlockOrInline (Div a)+instance IsChildOf b a => IsChildOf b (Div a)++$(node "Subsection" [NoTag] [] [])+instance IsBlock a => IsChildOf a Subsection+class SubsectionTag t where+ subsectionTag :: (a `IsChildOf` Span) => TDoc t a -> t Subsection+subsection :: forall a b t. (SubsectionTag t, a `IsChildOf` Span, ToTDoc b t a) => b -> Star t Subsection+subsection t = tStar (subsectionTag (toTDoc t :: TDoc t a))++$(node "Section" [NoTag] [] [''Paragraph, ''UList, ''Table, ''Hr, ''Subsection])+-- instance IsBlock a => IsChildOf a Section+instance a ~ Section => IsChildOf (Div a) Section+class SectionTag t where+ sectionTag :: (a `IsChildOf` Span) => TDoc t a -> t Section+section :: forall a b t. (SectionTag t, a `IsChildOf` Span, ToTDoc b t a) => b -> Star t Section+section t = tStar (sectionTag (toTDoc t :: TDoc t a))++$(node "HLink" [NoTag, Inline] [] [])+instance IsInline a => IsChildOf a HLink+class HLinkTag t where hLinkTag :: Url -> t HLink+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)++$(node "Image" [Inline] [''Alt, ''Src, ''Height, ''Width] [])+image :: ImageTag t => Nullary t Image+image = tNullary imageTag++$(node "Preambule" [] [] [''Title])+preambule :: PreambuleTag t => Star t Preambule+preambule = tStar preambuleTag++-- instance IsBlock a => IsChildOf a Document+$(node "Document" [] [] [''Section, ''Paragraph, ''UList, ''Table, ''Hr])+instance a ~ Document => IsChildOf (Div a) Document+document :: DocumentTag t => Star t Document+document = tStar documentTag++$(node "Root" [] [] [''Preambule, ''Document])+root :: forall t doc preambule. (RootTag t, ToTDoc preambule t Preambule, ToTDoc doc t Document) => preambule -> doc -> TDoc t Root+root x y = tStar rootTag [ Child (toTDoc x :: TDoc t Preambule)+ , Child (toTDoc y :: TDoc t Document) ]++class (AttributeTags t+ ,LeafTags t+ ,ParagraphTag t+ ,TitleTag t+ ,BrTag t+ ,HrTag t+ ,ColTag t+ ,HColTag t+ ,RowTag t+ ,TableTag t+ ,ItemTag t+ ,UListTag t+ ,SpanTag t+ ,DivTag t+ ,SubsectionTag t+ ,SectionTag t+ ,HLinkTag t+ ,AnchorTag t+ ,ImageTag t+ ,PreambuleTag t+ ,DocumentTag t+ ,RootTag t+ ) => Tags t where++-- since their is no 'instance IsChildOf X Leaf'+-- one cannot build a 'TNode attrs [x] :: Tags t => TDoc t Leaf'+-- but one can build a 'TNode attrs [] :: Tags t => TDoc t Leaf'+
+ Text/TDoc/Tags/Form.hs view
@@ -0,0 +1,142 @@+--------------------------------------------------------------------+-- !+-- Module : Text.TDoc.Tags.Form+-- Copyright : (c) Nicolas Pouillard 2009-2011+-- License : BSD3+--+-- Maintainer : Nicolas Pouillard <nicolas.pouillard@gmail.com>+--+--------------------------------------------------------------------++{-# LANGUAGE TypeFamilies, EmptyDataDecls, TemplateHaskell,+ MultiParamTypeClasses, FlexibleContexts, FlexibleInstances #-}+module Text.TDoc.Tags.Form where++import Text.TDoc.Core+import Text.TDoc.TH+import Text.TDoc.Attributes+import Text.TDoc.Tags++newtype Action = Action { fromAction :: String }+data Selected = Selected+newtype Value = Value { fromValue :: String }+data Multiple = Multiple+data FormMethod = GET+ | POST+ | RawFormMethod String++instance Show FormMethod where+ show POST = "post"+ show GET = "get"+ show (RawFormMethod s) = s++data InputType+ = TEXT+ | PASSWORD+ | CHECKBOX+ | RADIO+ | SUBMIT+ | RESET+ | FILE+ | IMAGE+ | BUTTON+ | HIDDEN+ deriving (Eq, Ord, Enum)++instance Show InputType where+ show TEXT = "text"+ show PASSWORD = "password"+ show CHECKBOX = "checkbox"+ show RADIO = "radio"+ show SUBMIT = "submit"+ show RESET = "reset"+ show FILE = "file"+ show IMAGE = "image"+ show BUTTON = "button"+ show HIDDEN = "hidden"++--++$(attributes [''FormMethod, ''Action, ''Selected+ ,''Value, ''Multiple, ''InputType])++--++formMethod :: (FormMethodTag t, IsAttributeOf FormMethod a) => FormMethod -> AttributeOf t a+formMethod = TAttr formMethodTag++action :: (ActionTag t, IsAttributeOf Action a) => String -> AttributeOf t a+action = TAttr actionTag . Action++selected :: (SelectedTag t, IsAttributeOf Selected a) => AttributeOf t a+selected = TAttr selectedTag Selected++selectedB :: (SelectedTag t, IsAttributeOf Selected a) => Bool -> AttributesOf t a -> AttributesOf t a+selectedB True = (TAttr selectedTag Selected:)+selectedB False = id++selectedMS :: (SelectedTag t, IsAttributeOf Selected a) => Maybe Selected -> AttributesOf t a -> AttributesOf t a+selectedMS (Just Selected) = (TAttr selectedTag Selected:)+selectedMS Nothing = id++value :: (ValueTag t, IsAttributeOf Value a) => String -> AttributeOf t a+value = TAttr valueTag . Value++inputType :: (InputTypeTag t, IsAttributeOf InputType a) => InputType -> AttributeOf t a+inputType = TAttr inputTypeTag++--++$(node "Label" [] [] [])+--instance IsBlock Label+instance IsInline a => IsChildOf a Label+label :: LabelTag t => Star t Label+label = tStar labelTag++$(node "Input" [] [''Name, ''Value, ''InputType] [])+input :: InputTag t => Nullary t Input+input = tNullary inputTag++$(node "Option" [] [''Selected, ''Value] [''Leaf])+option :: OptionTag t => Star t Option+option = tStar optionTag++$(node "Select" [] [''Multiple, ''Name, ''Size] [''Option])+-- actually Plus Select would be a more precise type+select :: SelectTag t => Star t Select+select = tStar selectTag++$(node "Textarea" [] [''Rows, ''Cols, ''Name] [''Leaf])+textarea :: (TextareaTag t, AttributeTags t) => Rows -> Cols -> Star t Textarea+textarea r c = tStar textareaTag ! [rows (fromRows r), cols (fromCols c)]++$(node "Form" [Block] [''Action, ''FormMethod] [''Select, ''Textarea, ''Input, ''Label])+$(nodeChildren ''Document [''Form])+instance Form ~ a => IsChildOf (Div a) Form+form :: FormTags t => Star t Form+form = tStar formTag++--++class (ActionTag t+ ,ValueTag t+ ,FormMethodTag t+ ,SelectedTag t+ ,InputTypeTag t+ ,MultipleTag t+ ) => FormAttributeTags t++class (FormAttributeTags t+ ,LabelTag t+ ,InputTag t+ ,OptionTag t+ ,FormTag t+ ,SelectTag t+ ,TextareaTag t+ ) => FormTags t++selectQ :: (LeafTags t, FormTags t) => AttributesOf t Select -> (String, String) -> [(String, String)] -> TDoc t Select+selectQ attrs (val0, children0) opts+ = select ! attrs $ (option ! [value val0, selected] $ children0) : map f opts+ where+ f (val, children) = option ! [value val] $ children
+ Text/TDoc/XHtml.hs view
@@ -0,0 +1,267 @@+--------------------------------------------------------------------+-- !+-- Module : Text.TDoc.XHtml+-- Copyright : (c) Nicolas Pouillard 2009-2011+-- License : BSD3+--+-- Maintainer : Nicolas Pouillard <nicolas.pouillard@gmail.com>+--+--------------------------------------------------------------------++{-# 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
+ tdoc.cabal view
@@ -0,0 +1,26 @@+name: tdoc+cabal-Version: >=1.2+version: 0.2.0+license: BSD3+license-file: LICENSE+copyright: (c) Nicolas Pouillard+author: Nicolas Pouillard+maintainer: Nicolas Pouillard <nicolas.pouillard@gmail.com>+--category:+synopsis: TDoc is a typed document builder with support for (X)HTML+description: TDoc +stability: Experimental+build-type: Simple++library+ build-depends: base>=3.0&&<5, transformers,+ template-haskell, xhtml, bytestring+ exposed-modules: Text.TDoc+ Text.TDoc.Core+ Text.TDoc.Attributes+ Text.TDoc.Tags+ Text.TDoc.Tags.Form+ Text.TDoc.XHtml+ Text.TDoc.QQ+ Text.TDoc.TH+ ghc-options: -Wall