hsp 0.8.0 → 0.9.0
raw patch · 6 files changed
+89/−89 lines, 6 files
Files
- hsp.cabal +8/−7
- src/HSP.hs +7/−0
- src/HSP/HTML4.hs +2/−2
- src/HSP/Monad.hs +8/−7
- src/HSP/XML.hs +35/−28
- src/HSP/XMLGenerator.hs +29/−45
hsp.cabal view
@@ -1,5 +1,5 @@ Name: hsp-Version: 0.8.0+Version: 0.9.0 License: BSD3 License-File: LICENSE Author: Niklas Broberg, Joel Bjornson@@ -18,14 +18,14 @@ * A cgi-handler utility (as a separate package, hsp-cgi) . For details on usage, please see the website, and the author's thesis.-Homepage: http://patch-tag.com/r/nibro/hsp+Homepage: http://hub.darcs.net/nibro/hsp Build-Type: Simple Cabal-Version: >= 1.6-Tested-With: GHC==6.8.3, GHC==6.10, GHC==7.0.2+Tested-With: GHC==7.6.3 source-repository head type: darcs- location: http://patch-tag.com/r/nibro/hsp+ location: http://hub.darcs.net/nibro/hsp Flag base4 @@ -39,11 +39,12 @@ else Build-depends: base >= 3 && < 4 Hs-Source-Dirs: src- Exposed-Modules: HSP.XMLGenerator- HSP.XML- HSP.XML.PCDATA+ Exposed-Modules: HSP HSP.HTML4 HSP.Monad+ HSP.XML+ HSP.XML.PCDATA+ HSP.XMLGenerator GHC-Options: -Wall -fno-warn-orphans Extensions: MultiParamTypeClasses,
+ src/HSP.hs view
@@ -0,0 +1,7 @@+module HSP+ ( module HSP.XMLGenerator+ , module HSP.XML+ ) where++import HSP.XMLGenerator+import HSP.XML
src/HSP/HTML4.hs view
@@ -38,7 +38,7 @@ import Data.Text.Lazy.Builder (Builder, fromLazyText, singleton, toLazyText) import Data.Text.Lazy (Text) import HSP.XML ( Attribute(..), Attributes, AttrValue(..), Children- , Name, XML(..), XMLMetaData(..))+ , NSName, XML(..), XMLMetaData(..)) import HSP.XML.PCDATA (escaper) data TagType = Open | Close@@ -52,7 +52,7 @@ ('>', fromString "gt" ) ] -renderTag :: TagType -> Int -> Name -> Attributes -> Builder+renderTag :: TagType -> Int -> NSName -> Attributes -> Builder renderTag typ n name attrs = let (start,end) = case typ of Open -> (singleton '<', singleton '>')
src/HSP/Monad.hs view
@@ -12,7 +12,7 @@ import Data.String (fromString) import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as Text-import HSP.XMLGenerator (AppendChild(..), Attr(..), EmbedAsAttr(..), EmbedAsChild(..), IsName(toName), SetAttr(..), XMLGen(..), XMLGenerator)+import HSP.XMLGenerator (AppendChild(..), Attr(..), EmbedAsAttr(..), EmbedAsChild(..), IsName(..), SetAttr(..), XMLGen(..), XMLGenerator) import HSP.XML (Attribute(..), XML(..), pAttrVal, pcdata) newtype HSPT xml m a = HSPT { unHSPT :: m a }@@ -23,6 +23,7 @@ instance (Functor m, Monad m) => (XMLGen (HSPT XML m)) where type XMLType (HSPT XML m) = XML+ type StringType (HSPT XML m) = Text newtype ChildType (HSPT XML m) = HSPChild { unHSPChild :: XML } newtype AttributeType (HSPT XML m) = HSPAttr { unHSPAttr :: Attribute } genElement n attrs childr =@@ -64,20 +65,20 @@ instance (Functor m, Monad m) => EmbedAsChild (HSPT XML m) () where asChild = return . const [] -instance (Monad m, Functor m) => EmbedAsAttr (HSPT XML m) (Attr Text Char) where- asAttr (n := c) = asAttr (n := Text.singleton c)- instance (Monad m, Functor m) => EmbedAsAttr (HSPT XML m) Attribute where asAttr = return . (:[]) . HSPAttr +instance (Functor m, Monad m) => EmbedAsAttr (HSPT XML m) (Attr Text Text) where+ asAttr (n := v) = asAttr $ MkAttr (toName n, (pAttrVal v))++instance (Monad m, Functor m) => EmbedAsAttr (HSPT XML m) (Attr Text Char) where+ asAttr (n := c) = asAttr (n := Text.singleton c)+ instance (Functor m, Monad m) => EmbedAsAttr (HSPT XML m) (Attr Text Bool) where asAttr (n := True) = asAttr $ MkAttr (toName n, pAttrVal $ fromString "true") asAttr (n := False) = asAttr $ MkAttr (toName n, pAttrVal $ fromString "false") instance (Functor m, Monad m) => EmbedAsAttr (HSPT XML m) (Attr Text Int) where asAttr (n := i) = asAttr $ MkAttr (toName n, pAttrVal $ fromString (show i))--instance (Functor m, Monad m) => EmbedAsAttr (HSPT XML m) (Attr Text Text) where- asAttr (n := txt) = asAttr $ MkAttr (toName n, pAttrVal txt) instance (Functor m, Monad m) => XMLGenerator (HSPT XML m)
src/HSP/XML.hs view
@@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : HSP.XML--- Copyright : (c) Niklas Broberg 2008-2012+-- Copyright : (c) Niklas Broberg 2008-2013 -- License : BSD-style (see the file LICENSE.txt) -- -- Maintainer : Niklas Broberg, niklas.broberg@gmail.com@@ -15,8 +15,8 @@ -- * The 'XML' datatype XML(..), XMLMetaData(..),- Domain,- Name,+ Namespace,+ NSName, Attributes, Children, pcdata,@@ -27,7 +27,8 @@ attrVal, pAttrVal, -- * Functions renderXML,- isElement, isCDATA+ isElement, isCDATA,+ fromStringLit ) where import Data.List (intersperse)@@ -39,19 +40,28 @@ import HSP.XML.PCDATA (escape) ------------------------------------------------------------------ Domain/Name+-- fromStringLit -type Domain = Maybe Text-type Name = (Domain, Text)+fromStringLit :: String -> Text+fromStringLit = Text.pack ---------------------------------------------------------------+-- Namespace/NSName++type Namespace = Maybe Text+type NSName = (Namespace, Text)++--------------------------------------------------------------- -- Attributes-newtype Attribute = MkAttr (Name, AttrValue)+newtype Attribute = MkAttr (NSName, AttrValue) deriving Show -- | Represents an attribue value. data AttrValue = Value Bool Text +-- fromStringLit :: String -> Text+-- fromStringLit = Text.pack+ -- | Create an attribue value from a string. attrVal, pAttrVal :: Text -> AttrValue attrVal = Value False@@ -66,12 +76,23 @@ -- XML -- | The XML datatype representation. Is either an Element or CDATA. data XML- = Element Name Attributes Children+ = Element NSName Attributes Children | CDATA Bool Text deriving Show type Children = [XML] +-- | Embeds a string as a CDATA XML value.+cdata , pcdata :: Text -> XML+cdata = CDATA False+pcdata = CDATA True++-- | Test whether an XML value is an Element or CDATA+isElement, isCDATA :: XML -> Bool+isElement (Element {}) = True+isElement _ = False+isCDATA = not . isElement+ --------------------------------------------------------------- -- XMLMetaData @@ -86,32 +107,18 @@ , preferredRenderer :: XML -> Builder } -{- instance Show XML where- show = renderXML -}---- | Test whether an XML value is an Element or CDATA-isElement, isCDATA :: XML -> Bool-isElement (Element {}) = True-isElement _ = False-isCDATA = not . isElement---- | Embeds a string as a CDATA XML value.-cdata , pcdata :: Text -> XML-cdata = CDATA False-pcdata = CDATA True- ------------------------------------------------------------------ -- Rendering data TagType = Open | Close | Single -renderTag :: TagType -> Int -> Name -> Attributes -> Builder+renderTag :: TagType -> Int -> NSName -> Attributes -> Builder renderTag typ n name attrs = let (start,end) = case typ of Open -> (singleton '<', singleton '>') Close -> (fromString "</", singleton '>') Single -> (singleton '<', fromString "/>")- nam = showName name+ nam = showNSName name as = renderAttrs attrs in mconcat [start, nam, as, end] @@ -122,13 +129,13 @@ renderAttr :: Attribute -> Builder renderAttr (MkAttr (nam, (Value needsEscape val))) =- showName nam <> singleton '=' <> renderAttrVal (if needsEscape then escape val else fromLazyText val)+ showNSName nam <> singleton '=' <> renderAttrVal (if needsEscape then escape val else fromLazyText val) renderAttrVal :: Builder -> Builder renderAttrVal txt = singleton '\"' <> txt <> singleton '\"' - showName (Nothing, s) = fromLazyText s- showName (Just d, s) = fromLazyText d <> singleton ':' <> fromLazyText s+ showNSName (Nothing, s) = fromLazyText s+ showNSName (Just d, s) = fromLazyText d <> singleton ':' <> fromLazyText s nl = singleton '\n' <> fromString (replicate n ' ')
src/HSP/XMLGenerator.hs view
@@ -4,12 +4,12 @@ ----------------------------------------------------------------------------- -- | -- Module : HSX.XMLGenerator --- Copyright : (c) Niklas Broberg 2008 +-- Copyright : (c) Niklas Broberg 2008-2013 -- License : BSD-style (see the file LICENSE.txt) -- --- Maintainer : Niklas Broberg, niklas.broberg@chalmers.se +-- Maintainer : Niklas Broberg <niklas.broberg@gmail.com> -- Stability : experimental --- Portability : requires newtype deriving and MPTCs with fundeps +-- Portability : requires newtype deriving and MPTCs with fundeps and type families -- -- The class and monad transformer that forms the basis of the literal XML -- syntax translation. Literal tags will be translated into functions of @@ -49,18 +49,19 @@ instance MonadTrans XMLGenT where lift = XMLGenT -type Name = (Maybe Text, Text) +type Name a = (Maybe a, a) -- | Generate XML values in some XMLGenerator monad. class Monad m => XMLGen m where type XMLType m + type StringType m data ChildType m data AttributeType m - genElement :: Name -> [XMLGenT m [AttributeType m]] -> [XMLGenT m [ChildType m]] -> XMLGenT m (XMLType m) - genEElement :: Name -> [XMLGenT m [AttributeType m]] -> XMLGenT m (XMLType m) + genElement :: Name (StringType m) -> [XMLGenT m [AttributeType m]] -> [XMLGenT m [ChildType m]] -> XMLGenT m (XMLType m) + genEElement :: Name (StringType m) -> [XMLGenT m [AttributeType m]] -> XMLGenT m (XMLType m) genEElement n ats = genElement n ats [] - xmlToChild :: XMLType m -> ChildType m - pcdataToChild :: Text -> ChildType m + xmlToChild :: XMLType m -> ChildType m + pcdataToChild :: StringType m -> ChildType m -- | Type synonyms to avoid writing out the XMLnGenT all the time type GenXML m = XMLGenT m (XMLType m) @@ -98,12 +99,6 @@ #endif asChild = return . return . xmlToChild -instance XMLGen m => EmbedAsChild m String where - asChild = return . return . pcdataToChild . Text.pack - -instance XMLGen m => EmbedAsChild m Text where - asChild = return . return . pcdataToChild - instance XMLGen m => EmbedAsChild m () where asChild _ = return [] @@ -128,6 +123,8 @@ instance EmbedAsAttr m a => EmbedAsAttr m [a] where asAttr = liftM concat . mapM asAttr +-- This is certainly true, but we want the various generators to explicitly state it, +-- in order to get the error messages right. class ( XMLGen m , SetAttr m (XMLType m) , AppendChild m (XMLType m) @@ -141,23 +138,6 @@ , EmbedAsAttr m (Attr Text Bool) ) => XMLGenerator m -{- --- This is certainly true, but we want the various generators to explicitly state it, --- in order to get the error messages right. -instance ( XMLGen m - , SetAttr m (XMLType m) - , AppendChild m (XMLType m) - , EmbedAsChild m (XMLType m) - , EmbedAsChild m [XMLType m] - , EmbedAsChild m Text - , EmbedAsChild m Char - , EmbedAsChild m () - , EmbedAsAttr m (Attr Text Text) - , EmbedAsAttr m (Attr Text Int) - , EmbedAsAttr m (Attr Text Bool) - ) => XMLGenerator m --} - ------------------------------------- -- Setting attributes @@ -167,11 +147,13 @@ setAll :: elem -> GenAttributeList m -> GenXML m setAttr e a = setAll e $ liftM return a +-- | prepend @attr@ to the list of attributes for the @elem@ (<@), set :: (SetAttr m elem, EmbedAsAttr m attr) => elem -> attr -> GenXML m set xml attr = setAll xml (asAttr attr) (<@) = set -(<<@) :: (SetAttr m elem, EmbedAsAttr m a) => elem -> [a] -> GenXML m +-- | prepend the list of @attr@ to the attributes for the @elem@ +(<<@) :: (SetAttr m elem, EmbedAsAttr m attr) => elem -> [attr] -> GenXML m xml <<@ ats = setAll xml (liftM concat $ mapM asAttr ats) instance (TypeCastM m1 m, SetAttr m x) => @@ -186,10 +168,12 @@ appAll :: elem -> GenChildList m -> GenXML m appChild e c = appAll e $ liftM return c +-- | append child to the children of @elem@ (<:), app :: (AppendChild m elem, EmbedAsChild m c) => elem -> c -> GenXML m app xml c = appAll xml $ asChild c (<:) = app +-- | append children to the children of @elem@ (<<:) :: (AppendChild m elem, EmbedAsChild m c) => elem -> [c] -> GenXML m xml <<: chs = appAll xml (liftM concat $ mapM asChild chs) @@ -201,28 +185,28 @@ -- Names -- | Names can be simple or qualified with a domain. We want to conveniently --- use both simple strings or pairs wherever a Name is expected. -class Show n => IsName n where - toName :: n -> Name - --- | Names can represent names, of course. -instance IsName Name where - toName = id +-- use both simple strings or pairs wherever a 'Name' is expected. +class Show n => IsName n s where + toName :: n -> Name s -- | Strings can represent names, meaning a simple name with no domain. -instance IsName String where - toName s = (Nothing, Text.pack s) +instance IsName String String where + toName s = (Nothing, s) +-- | Names can represent names, of course. +instance (Show a) => IsName (Name a) a where + toName = id + -- | Pairs of strings can represent names, meaning a name qualified with a domain. -instance IsName (String, String) where - toName (ns, s) = (Just $ Text.pack ns, Text.pack s) +instance IsName (String, String) Text where + toName (ns, s) = (Just $ Text.pack ns, Text.pack s) -- | Strings can represent names, meaning a simple name with no domain. -instance IsName Text where +instance IsName Text Text where toName s = (Nothing, s) -- | Pairs of strings can represent names, meaning a name qualified with a domain. -instance IsName (Text, Text) where +instance IsName (Text, Text) Text where toName (ns, s) = (Just $ ns, s) ---------------------------------------