happstack-hsp 7.0.2 → 7.1.0
raw patch · 7 files changed
+62/−192 lines, 7 filesdep ~hspdep ~hsx
Dependency ranges changed: hsp, hsx
Files
- happstack-hsp.cabal +3/−4
- src/HSP/Google/Analytics.hs +1/−2
- src/HSP/Identity.hs +16/−23
- src/HSP/IdentityT.hs +22/−28
- src/HSP/ServerPartT.hs +16/−22
- src/HSP/WebT.hs +0/−108
- src/Happstack/Server/HSP/HTML.hs +4/−5
happstack-hsp.cabal view
@@ -1,5 +1,5 @@ Name: happstack-hsp-Version: 7.0.2+Version: 7.1.0 Synopsis: Support for using HSP templates in Happstack Description: Happstack is a web application framework. HSP is an XML templating solution. This package makes it easy to use HSP templates with Happstack. Homepage: http://www.happstack.com/@@ -25,15 +25,14 @@ HSP.Identity HSP.IdentityT HSP.ServerPartT- HSP.WebT HSP.Google.Analytics Build-depends: base >= 3.0 && < 5.0, bytestring == 0.9.*, happstack-server >= 6.0 && < 7.1, harp >= 0.4 && < 0.5,- hsx >= 0.9.1 && < 0.10,- hsp >= 0.6.1 && < 0.7,+ hsx >= 0.10.2 && < 0.11,+ hsp >= 0.7.1 && < 0.8, mtl >= 1.1 && < 2.2, utf8-string == 0.3.*, syb == 0.3.*,
src/HSP/Google/Analytics.hs view
@@ -9,7 +9,6 @@ import Data.Generics (Data, Typeable) import HSP-import qualified HSX.XMLGenerator as HSX import Prelude hiding (head) newtype UACCT = UACCT String -- ^ The UACCT provided to you by Google (looks like: @UA-XXXXX-X@)@@ -62,7 +61,7 @@ , EmbedAsChild m XML , EmbedAsAttr m Attribute , XMLGenerator m- , HSX.XML m ~ XML)+ , XMLType m ~ XML) => UACCT -> XMLGenT m XML -> GenXML m
src/HSP/Identity.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE CPP, MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances, TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-}-module HSP.Identity +module HSP.Identity ( Ident , evalIdentity ) where@@ -9,27 +9,20 @@ import qualified Data.Text.Lazy as TL import HSP import Control.Monad.Identity (Identity(Identity, runIdentity))-import qualified HSX.XMLGenerator as HSX+import HSX.XMLGenerator -instance HSX.XMLGenerator Identity+instance XMLGenerator Identity -instance HSX.XMLGen Identity where-#if __GLASGOW_HASKELL__ < 702- type HSX.XML Identity = XML- newtype HSX.Child Identity = IChild { unIChild :: XML }- newtype HSX.Attribute Identity = IAttr { unIAttr :: Attribute }-#else- type XML Identity = XML- newtype Child Identity = IChild { unIChild :: XML }- newtype Attribute Identity = IAttr { unIAttr :: Attribute }-#endif- genElement n attrs children = HSX.XMLGenT $ Identity (Element- (toName n)- (map unIAttr $ concatMap runIdentity $ map HSX.unXMLGenT attrs)- (map unIChild $ concatMap runIdentity $ map HSX.unXMLGenT children)- )+instance XMLGen Identity where+ type XMLType Identity = XML+ newtype ChildType Identity = IChild { unIChild :: XML }+ newtype AttributeType Identity = IAttr { unIAttr :: Attribute }+ genElement n attrs children = do+ attrs' <- asAttr attrs+ children' <- asChild children+ return $ Element (toName n) (map unIAttr attrs') (map unIChild children') xmlToChild = IChild- pcdataToChild = HSX.xmlToChild . pcdata+ pcdataToChild = xmlToChild . pcdata instance IsAttrValue Identity T.Text where toAttrValue = toAttrValue . T.unpack@@ -38,7 +31,7 @@ toAttrValue = toAttrValue . TL.unpack instance EmbedAsAttr Identity Attribute where- asAttr = return . (:[]) . IAttr + asAttr = return . (:[]) . IAttr instance EmbedAsAttr Identity (Attr String Char) where asAttr (n := c) = asAttr (n := [c])@@ -84,10 +77,10 @@ CDATA _ _ -> return xml Element n as cs -> return $ Element n as (cs ++ (map stripChild chs)) -stripAttr :: HSX.Attribute Identity -> Attribute+stripAttr :: AttributeType Identity -> Attribute stripAttr (IAttr a) = a -stripChild :: HSX.Child Identity -> XML+stripChild :: ChildType Identity -> XML stripChild (IChild c) = c instance SetAttr Identity XML where@@ -101,6 +94,6 @@ insert = (:) evalIdentity :: XMLGenT Identity XML -> XML-evalIdentity = runIdentity . HSX.unXMLGenT+evalIdentity = runIdentity . unXMLGenT type Ident = XMLGenT Identity
src/HSP/IdentityT.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE CPP, MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances, TypeFamilies, GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans -F -pgmF trhsx #-}-module HSP.IdentityT +module HSP.IdentityT ( evalIdentityT , IdentT , IdentityT(..)@@ -16,7 +16,7 @@ import qualified Data.Text as T import qualified Data.Text.Lazy as TL import HSP-import qualified HSX.XMLGenerator as HSX+import HSX.XMLGenerator -- * IdentityT Monad Transformer @@ -24,7 +24,7 @@ deriving (Functor, Monad, MonadWriter w, MonadReader r, MonadState s, MonadRWS r w s, MonadIO, MonadPlus) instance (Applicative f) => Applicative (IdentityT f) where- pure = IdentityT . pure + pure = IdentityT . pure (IdentityT f) <*> (IdentityT a) = IdentityT (f <*> a) instance MonadTrans IdentityT where@@ -32,24 +32,18 @@ -- * HSX.XMLGenerator for IdentityT -instance (Monad m, Functor m) => HSX.XMLGenerator (IdentityT m)+instance (Monad m, Functor m) => XMLGenerator (IdentityT m) -instance (Functor m, Monad m) => HSX.XMLGen (IdentityT m) where-#if __GLASGOW_HASKELL__ < 702- type HSX.XML (IdentityT m) = XML- newtype HSX.Child (IdentityT m) = IChild { unIChild :: XML }- newtype HSX.Attribute (IdentityT m) = IAttr { unIAttr :: Attribute }-#else- type XML (IdentityT m) = XML- newtype Child (IdentityT m) = IChild { unIChild :: XML }- newtype Attribute (IdentityT m) = IAttr { unIAttr :: Attribute }-#endif- genElement n attrs children = HSX.XMLGenT $ - do attrs' <- HSX.unXMLGenT (fmap (map unIAttr . concat) (sequence attrs))- children' <- HSX.unXMLGenT (fmap (map unIChild . concat) (sequence children))+instance (Functor m, Monad m) => XMLGen (IdentityT m) where+ type XMLType (IdentityT m) = XML+ newtype ChildType (IdentityT m) = IChild { unIChild :: XML }+ newtype AttributeType (IdentityT m) = IAttr { unIAttr :: Attribute }+ genElement n attrs children =+ do attrs' <- fmap (map unIAttr . concat) (sequence attrs)+ children' <- fmap (map unIChild . concat) (sequence children) return (Element (toName n) attrs' children') xmlToChild = IChild- pcdataToChild = HSX.xmlToChild . pcdata+ pcdataToChild = xmlToChild . pcdata instance (Monad m, Functor m) => IsAttrValue (IdentityT m) T.Text where toAttrValue = toAttrValue . T.unpack@@ -57,20 +51,20 @@ instance (Monad m, Functor m) => IsAttrValue (IdentityT m) TL.Text where toAttrValue = toAttrValue . TL.unpack -instance (Monad m, Functor m) => HSX.EmbedAsAttr (IdentityT m) Attribute where- asAttr = return . (:[]) . IAttr +instance (Monad m, Functor m) => EmbedAsAttr (IdentityT m) Attribute where+ asAttr = return . (:[]) . IAttr -instance (Monad m, Functor m) => HSX.EmbedAsAttr (IdentityT m) (Attr String Char) where+instance (Monad m, Functor m) => EmbedAsAttr (IdentityT m) (Attr String Char) where asAttr (n := c) = asAttr (n := [c]) -instance (Monad m, Functor m) => HSX.EmbedAsAttr (IdentityT m) (Attr String String) where+instance (Monad m, Functor m) => EmbedAsAttr (IdentityT m) (Attr String String) where asAttr (n := str) = asAttr $ MkAttr (toName n, pAttrVal str) -instance (Monad m, Functor m) => HSX.EmbedAsAttr (IdentityT m) (Attr String Bool) where+instance (Monad m, Functor m) => EmbedAsAttr (IdentityT m) (Attr String Bool) where asAttr (n := True) = asAttr $ MkAttr (toName n, pAttrVal "true") asAttr (n := False) = asAttr $ MkAttr (toName n, pAttrVal "false") -instance (Monad m, Functor m) => HSX.EmbedAsAttr (IdentityT m) (Attr String Int) where+instance (Monad m, Functor m) => EmbedAsAttr (IdentityT m) (Attr String Int) where asAttr (n := i) = asAttr $ MkAttr (toName n, pAttrVal (show i)) instance (Monad m, Functor m, IsName n) => (EmbedAsAttr (IdentityT m) (Attr n TL.Text)) where@@ -86,7 +80,7 @@ asChild = XMLGenT . return . (:[]) . IChild . pcdata instance (Monad m, Functor m) => EmbedAsChild (IdentityT m) (IdentityT m String) where- asChild c = + asChild c = do c' <- lift c lift . return . (:[]) . IChild . pcdata $ c' @@ -109,10 +103,10 @@ CDATA _ _ -> return xml Element n as cs -> return $ Element n as (cs ++ (map stripChild chs)) -stripAttr :: (Monad m, Functor m) => HSX.Attribute (IdentityT m) -> Attribute+stripAttr :: (Monad m, Functor m) => AttributeType (IdentityT m) -> Attribute stripAttr (IAttr a) = a -stripChild :: (Monad m, Functor m) => HSX.Child (IdentityT m) -> XML+stripChild :: (Monad m, Functor m) => ChildType (IdentityT m) -> XML stripChild (IChild c) = c instance (Monad m, Functor m) => SetAttr (IdentityT m) XML where@@ -126,6 +120,6 @@ insert = (:) evalIdentityT :: (Functor m, Monad m) => XMLGenT (IdentityT m) XML -> m XML-evalIdentityT = runIdentityT . HSX.unXMLGenT+evalIdentityT = runIdentityT . unXMLGenT type IdentT m = XMLGenT (IdentityT m) XML
src/HSP/ServerPartT.hs view
@@ -7,36 +7,30 @@ import Control.Monad (liftM) import qualified Data.Text as T import qualified Data.Text.Lazy as TL-import qualified HSX.XMLGenerator as HSX+import HSX.XMLGenerator import Happstack.Server (ServerPartT) -instance (Monad m) => HSX.XMLGen (ServerPartT m) where-#if __GLASGOW_HASKELL__ < 702- type HSX.XML (ServerPartT m) = XML- newtype HSX.Child (ServerPartT m) = SChild { unSChild :: XML }- newtype HSX.Attribute (ServerPartT m) = SAttr { unSAttr :: Attribute }-#else- type XML (ServerPartT m) = XML- newtype Child (ServerPartT m) = SChild { unSChild :: XML }- newtype Attribute (ServerPartT m) = SAttr { unSAttr :: Attribute }-#endif- genElement n attrs children = +instance (Monad m) => XMLGen (ServerPartT m) where+ type XMLType (ServerPartT m) = XML+ newtype ChildType (ServerPartT m) = SChild { unSChild :: XML }+ newtype AttributeType (ServerPartT m) = SAttr { unSAttr :: Attribute }+ genElement n attrs children = do attribs <- map unSAttr `liftM` asAttr attrs childer <- (flattenCDATA . map unSChild) `liftM`asChild children- HSX.XMLGenT $ return (Element+ return (Element (toName n) attribs childer ) xmlToChild = SChild- pcdataToChild = HSX.xmlToChild . pcdata+ pcdataToChild = xmlToChild . pcdata flattenCDATA :: [XML] -> [XML]-flattenCDATA cxml = +flattenCDATA cxml = case flP cxml [] of [] -> [] [CDATA _ ""] -> []- xs -> xs + xs -> xs where flP :: [XML] -> [XML] -> [XML] flP [] bs = reverse bs@@ -52,20 +46,20 @@ instance (Monad m, Functor m) => IsAttrValue (ServerPartT m) TL.Text where toAttrValue = toAttrValue . TL.unpack -instance (Monad m) => HSX.EmbedAsAttr (ServerPartT m) Attribute where- asAttr = return . (:[]) . SAttr +instance (Monad m) => EmbedAsAttr (ServerPartT m) Attribute where+ asAttr = return . (:[]) . SAttr -instance (Monad m, IsName n) => HSX.EmbedAsAttr (ServerPartT m) (Attr n Char) where+instance (Monad m, IsName n) => EmbedAsAttr (ServerPartT m) (Attr n Char) where asAttr (n := c) = asAttr (n := [c]) -instance (Monad m, IsName n) => HSX.EmbedAsAttr (ServerPartT m) (Attr n String) where+instance (Monad m, IsName n) => EmbedAsAttr (ServerPartT m) (Attr n String) where asAttr (n := str) = asAttr $ MkAttr (toName n, pAttrVal str) -instance (Monad m, IsName n) => HSX.EmbedAsAttr (ServerPartT m) (Attr n Bool) where+instance (Monad m, IsName n) => EmbedAsAttr (ServerPartT m) (Attr n Bool) where asAttr (n := True) = asAttr $ MkAttr (toName n, pAttrVal "true") asAttr (n := False) = asAttr $ MkAttr (toName n, pAttrVal "false") -instance (Monad m, IsName n) => HSX.EmbedAsAttr (ServerPartT m) (Attr n Int) where+instance (Monad m, IsName n) => EmbedAsAttr (ServerPartT m) (Attr n Int) where asAttr (n := i) = asAttr $ MkAttr (toName n, pAttrVal (show i)) instance (Monad m, Functor m, IsName n) => (EmbedAsAttr (ServerPartT m) (Attr n TL.Text)) where
− src/HSP/WebT.hs
@@ -1,108 +0,0 @@-{-# LANGUAGE CPP, MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances, TypeFamilies #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-module HSP.WebT where--import HSP-import Control.Monad (liftM)-import qualified Data.Text as T-import qualified Data.Text.Lazy as TL-import qualified HSX.XMLGenerator as HSX-import Happstack.Server.Internal.Monads (WebT)--instance (Monad m) => HSX.XMLGen (WebT m) where-#if __GLASGOW_HASKELL__ < 702- type HSX.XML (WebT m) = XML- newtype HSX.Child (WebT m) = WChild { unWChild :: XML }- newtype HSX.Attribute (WebT m) = WAttr { unWAttr :: Attribute }-#else- type XML (WebT m) = XML- newtype Child (WebT m) = WChild { unWChild :: XML }- newtype Attribute (WebT m) = WAttr { unWAttr :: Attribute }-#endif- genElement n attrs children = - do attribs <- map unWAttr `liftM` asAttr attrs- childer <- (flattenCDATA . map unWChild) `liftM` asChild children- HSX.XMLGenT $ return (Element- (toName n)- attribs- childer- )- xmlToChild = WChild- pcdataToChild = HSX.xmlToChild . pcdata--flattenCDATA :: [XML] -> [XML]-flattenCDATA cxml = - case flP cxml [] of- [] -> []- [CDATA _ ""] -> []- xs -> xs - where- flP :: [XML] -> [XML] -> [XML]- flP [] bs = reverse bs- flP [x] bs = reverse (x:bs)- flP (x:y:xs) bs = case (x,y) of- (CDATA e1 s1, CDATA e2 s2) | e1 == e2 -> flP (CDATA e1 (s1++s2) : xs) bs- _ -> flP (y:xs) (x:bs)---instance (Monad m, Functor m) => IsAttrValue (WebT m) T.Text where- toAttrValue = toAttrValue . T.unpack--instance (Monad m, Functor m) => IsAttrValue (WebT m) TL.Text where- toAttrValue = toAttrValue . TL.unpack--instance (Monad m) => HSX.EmbedAsAttr (WebT m) Attribute where- asAttr = return . (:[]) . WAttr --instance (Monad m) => HSX.EmbedAsAttr (WebT m) (Attr String Char) where- asAttr (n := c) = asAttr (n := [c])--instance (Monad m) => HSX.EmbedAsAttr (WebT m) (Attr String String) where- asAttr (n := str) = asAttr $ MkAttr (toName n, pAttrVal str)--instance (Monad m) => HSX.EmbedAsAttr (WebT m) (Attr String Bool) where- asAttr (n := True) = asAttr $ MkAttr (toName n, pAttrVal "true")- asAttr (n := False) = asAttr $ MkAttr (toName n, pAttrVal "false")--instance (Monad m) => HSX.EmbedAsAttr (WebT m) (Attr String Int) where- asAttr (n := i) = asAttr $ MkAttr (toName n, pAttrVal (show i))--instance (Monad m, Functor m, IsName n) => (EmbedAsAttr (WebT m) (Attr n TL.Text)) where- asAttr (n := a) = asAttr $ MkAttr (toName n, pAttrVal $ TL.unpack a)--instance (Monad m, Functor m, IsName n) => (EmbedAsAttr (WebT m) (Attr n T.Text)) where- asAttr (n := a) = asAttr $ MkAttr (toName n, pAttrVal $ T.unpack a)--instance (Monad m) => EmbedAsChild (WebT m) Char where- asChild = XMLGenT . return . (:[]) . WChild . pcdata . (:[])--instance (Monad m) => EmbedAsChild (WebT m) String where- asChild = XMLGenT . return . (:[]) . WChild . pcdata--instance (Monad m, Functor m) => (EmbedAsChild (WebT m) TL.Text) where- asChild = asChild . TL.unpack--instance (Monad m, Functor m) => (EmbedAsChild (WebT m) T.Text) where- asChild = asChild . T.unpack--instance (Monad m) => EmbedAsChild (WebT m) XML where- asChild = XMLGenT . return . (:[]) . WChild--instance Monad m => EmbedAsChild (WebT m) () where- asChild () = return []--instance (Monad m) => AppendChild (WebT m) XML where- appAll xml children = do- chs <- children- case xml of- CDATA _ _ -> return xml- Element n as cs -> return $ Element n as (cs ++ (map unWChild chs))--instance (Monad m) => SetAttr (WebT m) XML where- setAll xml hats = do- attrs <- hats- case xml of- CDATA _ _ -> return xml- Element n as cs -> return $ Element n (foldr (:) as (map unWAttr attrs)) cs--instance (Monad m) => XMLGenerator (WebT m)
src/Happstack/Server/HSP/HTML.hs view
@@ -1,4 +1,4 @@--- | support for using HSP+Happstack for rendering HTML +-- | support for using HSP+Happstack for rendering HTML {-# LANGUAGE FlexibleInstances, FlexibleContexts #-} {-# OPTIONS_GHC -fno-warn-orphans -F -pgmFtrhsx #-} module Happstack.Server.HSP.HTML@@ -19,7 +19,6 @@ import HSP import HSP.ServerPartT () -- import 'instance XMLGen ServerPartT' import Happstack.Server.HSX () -- import 'instance Happstack XMLGenT'-import qualified HSX.XMLGenerator as HSX instance ToMessage XML where toContentType _ = P.pack "text/html;charset=utf-8"@@ -28,17 +27,17 @@ instance ToMessage (Maybe XMLMetaData, XML) where toContentType (Just md,_) = P.pack (contentType md) toContentType _ = P.pack "text/html;charset=utf-8"- toMessage (Just (XMLMetaData (showDt, dt) _ pr), xml) = + toMessage (Just (XMLMetaData (showDt, dt) _ pr), xml) = L.fromString ((if showDt then (dt ++) else id) (pr xml)) toMessage (Nothing, xml) = L.fromString (renderAsHTML xml) -- | A generic webpage template-defaultTemplate :: (XMLGenerator m, EmbedAsChild m headers, EmbedAsChild m body) => +defaultTemplate :: (XMLGenerator m, EmbedAsChild m headers, EmbedAsChild m body) => String -- ^ text to use in \<title\> tag -> headers -- ^ extra headers to insert in \<head\> tag. Use @()@ if none. -> body -- ^ content to put between the \<body\> tags.- -> m (HSX.XML m)+ -> m (XMLType m) defaultTemplate title headers body = unXMLGenT $ <html>