diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Text/TDoc.hs b/Text/TDoc.hs new file mode 100644 --- /dev/null +++ b/Text/TDoc.hs @@ -0,0 +1,22 @@ +-------------------------------------------------------------------- +-- ! +-- Module : Text.TDoc +-- Copyright : (c) Nicolas Pouillard 2009-2011 +-- License : BSD3 +-- +-- Maintainer : Nicolas Pouillard +-- +-------------------------------------------------------------------- + +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 diff --git a/Text/TDoc/Attributes.hs b/Text/TDoc/Attributes.hs new file mode 100644 --- /dev/null +++ b/Text/TDoc/Attributes.hs @@ -0,0 +1,89 @@ +-------------------------------------------------------------------- +-- ! +-- Module : Text.TDoc.Attributes +-- Copyright : (c) Nicolas Pouillard 2009-2011 +-- License : BSD3 +-- +-- Maintainer : Nicolas Pouillard +-- +-------------------------------------------------------------------- + +{-# 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 diff --git a/Text/TDoc/Core.hs b/Text/TDoc/Core.hs new file mode 100644 --- /dev/null +++ b/Text/TDoc/Core.hs @@ -0,0 +1,164 @@ +-------------------------------------------------------------------- +-- ! +-- Module : Text.TDoc.Core +-- Copyright : (c) Nicolas Pouillard 2009-2011 +-- License : BSD3 +-- +-- Maintainer : Nicolas Pouillard +-- +-------------------------------------------------------------------- + +{-# 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) diff --git a/Text/TDoc/QQ.hs b/Text/TDoc/QQ.hs new file mode 100644 --- /dev/null +++ b/Text/TDoc/QQ.hs @@ -0,0 +1,42 @@ +-------------------------------------------------------------------- +-- ! +-- Module : Text.TDoc.QQ +-- Copyright : (c) Nicolas Pouillard 2009-2011 +-- License : BSD3 +-- +-- Maintainer : Nicolas Pouillard +-- +-------------------------------------------------------------------- + +{-# 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") diff --git a/Text/TDoc/TH.hs b/Text/TDoc/TH.hs new file mode 100644 --- /dev/null +++ b/Text/TDoc/TH.hs @@ -0,0 +1,98 @@ +-------------------------------------------------------------------- +-- ! +-- Module : Text.TDoc.TH +-- Copyright : (c) Nicolas Pouillard 2009-2011 +-- License : BSD3 +-- +-- Maintainer : Nicolas Pouillard +-- +-------------------------------------------------------------------- + +{-# 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) diff --git a/Text/TDoc/Tags.hs b/Text/TDoc/Tags.hs new file mode 100644 --- /dev/null +++ b/Text/TDoc/Tags.hs @@ -0,0 +1,233 @@ +-------------------------------------------------------------------- +-- ! +-- Module : Text.TDoc.Tags +-- Copyright : (c) Nicolas Pouillard 2009-2011 +-- License : BSD3 +-- +-- Maintainer : Nicolas Pouillard +-- +-------------------------------------------------------------------- + +{-# 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' + diff --git a/Text/TDoc/Tags/Form.hs b/Text/TDoc/Tags/Form.hs new file mode 100644 --- /dev/null +++ b/Text/TDoc/Tags/Form.hs @@ -0,0 +1,142 @@ +-------------------------------------------------------------------- +-- ! +-- Module : Text.TDoc.Tags.Form +-- Copyright : (c) Nicolas Pouillard 2009-2011 +-- License : BSD3 +-- +-- Maintainer : Nicolas Pouillard +-- +-------------------------------------------------------------------- + +{-# 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 diff --git a/Text/TDoc/XHtml.hs b/Text/TDoc/XHtml.hs new file mode 100644 --- /dev/null +++ b/Text/TDoc/XHtml.hs @@ -0,0 +1,267 @@ +-------------------------------------------------------------------- +-- ! +-- 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 diff --git a/tdoc.cabal b/tdoc.cabal new file mode 100644 --- /dev/null +++ b/tdoc.cabal @@ -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 +--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