diff --git a/happstack-hsp.cabal b/happstack-hsp.cabal --- a/happstack-hsp.cabal +++ b/happstack-hsp.cabal @@ -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.*, diff --git a/src/HSP/Google/Analytics.hs b/src/HSP/Google/Analytics.hs --- a/src/HSP/Google/Analytics.hs +++ b/src/HSP/Google/Analytics.hs @@ -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 diff --git a/src/HSP/Identity.hs b/src/HSP/Identity.hs --- a/src/HSP/Identity.hs +++ b/src/HSP/Identity.hs @@ -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 diff --git a/src/HSP/IdentityT.hs b/src/HSP/IdentityT.hs --- a/src/HSP/IdentityT.hs +++ b/src/HSP/IdentityT.hs @@ -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 diff --git a/src/HSP/ServerPartT.hs b/src/HSP/ServerPartT.hs --- a/src/HSP/ServerPartT.hs +++ b/src/HSP/ServerPartT.hs @@ -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 diff --git a/src/HSP/WebT.hs b/src/HSP/WebT.hs deleted file mode 100644 --- a/src/HSP/WebT.hs +++ /dev/null @@ -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) diff --git a/src/Happstack/Server/HSP/HTML.hs b/src/Happstack/Server/HSP/HTML.hs --- a/src/Happstack/Server/HSP/HTML.hs +++ b/src/Happstack/Server/HSP/HTML.hs @@ -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 \ tag -> headers -- ^ extra headers to insert in \ tag. Use @()@ if none. -> body -- ^ content to put between the \ tags. - -> m (HSX.XML m) + -> m (XMLType m) defaultTemplate title headers body = unXMLGenT $