[happstack: added HSP.Google.Analytics, HSP.Identity, HSP.IdentityT, HSP.ServerPartT, HSP.WebT jeremy@n-heptane.com**20100208000853 Ignore-this: 4f6df720d9912f4f86c81e55dc167c6 ] adddir ./happstack/src/HSP adddir ./happstack/src/HSP/Google addfile ./happstack/src/HSP/Google/Analytics.hs addfile ./happstack/src/HSP/Identity.hs addfile ./happstack/src/HSP/IdentityT.hs addfile ./happstack/src/HSP/ServerPartT.hs addfile ./happstack/src/HSP/WebT.hs hunk ./happstack/happstack.cabal 66 + HSP.Identity + HSP.IdentityT + HSP.ServerPartT + HSP.WebT + HSP.Google.Analytics hunk ./happstack/happstack.cabal 82 + harp >= 0.4 && < 0.5, hunk ./happstack/src/HSP/Google/Analytics.hs 1 +{-# OPTIONS_GHC -fglasgow-exts -F -pgmFtrhsx #-} +module HSP.Google.Analytics + ( UACCT(..) + , analytics + , addAnalytics + ) where + +import Data.Generics (Data, Typeable) +import HSP +import Prelude hiding (head) + +newtype UACCT = UACCT String -- ^ The UACCT provided to you by Google + deriving (Read, Show, Eq, Ord, Typeable, Data) + +-- |create the google analytics script tags +-- NOTE: you must put the <% analytics yourUACCT %> immediately before the tag +-- See also: addAnalytics +analytics :: (XMLGenerator m) => UACCT -> GenXMLList m +analytics (UACCT uacct) = + do a <- + b <- + return [a,b] + +-- |automatically add the google analytics scipt tags immediately before the element +-- NOTE: this function is not idepotent +addAnalytics :: ( AppendChild m XML + , EmbedAsChild m XML + , EmbedAsAttr m Attribute + , XMLGenerator m) + => UACCT + -> XMLGenT m XML + -> GenXML m +addAnalytics uacct pg = + do page <- pg + a <- analytics uacct + case page of + <[ head, body ]> -> + + <% head %> + <% body <: a %> + + o -> error ("Failed to add analytics." ++ show o) + +{- Example Analytics Code from Google: + + + +-} hunk ./happstack/src/HSP/Identity.hs 1 +{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances, TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module HSP.Identity + ( Ident + , evalIdentity + ) where + +import HSP +import Control.Monad.Identity (Identity(Identity, runIdentity)) +import qualified HSX.XMLGenerator as HSX + +instance HSX.XMLGenerator Identity + +instance HSX.XMLGen Identity where + type HSX.XML Identity = XML + newtype HSX.Child Identity = IChild { unIChild :: XML } + newtype HSX.Attribute Identity = IAttr { unIAttr :: Attribute } + 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) + ) + xmlToChild = IChild + +instance HSX.EmbedAsAttr Identity Attribute where + asAttr = return . (:[]) . IAttr + +instance HSX.EmbedAsAttr Identity (Attr String Char) where + asAttr (n := c) = asAttr (n := [c]) + +instance HSX.EmbedAsAttr Identity (Attr String String) where + asAttr (n := str) = asAttr $ MkAttr (toName n, pAttrVal str) + +instance HSX.EmbedAsAttr Identity (Attr String Bool) where + asAttr (n := True) = asAttr $ MkAttr (toName n, pAttrVal "true") + asAttr (n := False) = asAttr $ MkAttr (toName n, pAttrVal "false") + +instance HSX.EmbedAsAttr Identity (Attr String Int) where + asAttr (n := i) = asAttr $ MkAttr (toName n, pAttrVal (show i)) + + +instance EmbedAsChild Identity Char where + asChild = XMLGenT . Identity . (:[]) . IChild . pcdata . (:[]) + +instance EmbedAsChild Identity String where + asChild = XMLGenT . Identity . (:[]) . IChild . pcdata + + +instance EmbedAsChild Identity XML where + asChild = XMLGenT . Identity . (:[]) . IChild + +instance EmbedAsChild Identity () where + asChild () = return [] + +instance AppendChild Identity XML where + appAll xml children = do + chs <- children + case xml of + CDATA _ _ -> return xml + Element n as cs -> return $ Element n as (cs ++ (map stripChild chs)) + +stripAttr :: HSX.Attribute Identity -> Attribute +stripAttr (IAttr a) = a + +stripChild :: HSX.Child Identity -> XML +stripChild (IChild c) = c + +instance SetAttr Identity XML where + setAll xml hats = do + attrs <- hats + case xml of + CDATA _ _ -> return xml + Element n as cs -> return $ Element n (foldr insert as (map stripAttr attrs)) cs + +insert :: Attribute -> Attributes -> Attributes +insert = (:) + +evalIdentity :: XMLGenT Identity XML -> XML +evalIdentity = runIdentity . HSX.unXMLGenT + +type Ident = XMLGenT Identity hunk ./happstack/src/HSP/IdentityT.hs 1 +{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances, TypeFamilies, GeneralizedNewtypeDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans -F -pgmF trhsx #-} +module HSP.IdentityT + ( evalIdentityT + , IdentT + , IdentityT(..) + ) where + +import Control.Applicative (Applicative((<*>), pure)) +import Control.Monad.Trans (MonadTrans(lift), MonadIO(liftIO)) +import HSP +import qualified HSX.XMLGenerator as HSX + +-- * IdentityT Monad Transformer + +newtype IdentityT m a = IdentityT { runIdentityT :: m a } + deriving (Monad) + +instance (Functor m) => Functor (IdentityT m) where + fmap f = IdentityT . fmap f . runIdentityT + +instance (Applicative f) => Applicative (IdentityT f) where + pure = IdentityT . pure + (IdentityT f) <*> (IdentityT a) = IdentityT (f <*> a) + +instance MonadTrans IdentityT where + lift = IdentityT + +instance (MonadIO m) => MonadIO (IdentityT m) where + liftIO = IdentityT . liftIO + +-- * HSX.XMLGenerator for IdentityT + +instance (Monad m, Functor m) => HSX.XMLGenerator (IdentityT m) + +instance (Functor m, Monad m) => HSX.XMLGen (IdentityT m) where + type HSX.XML (IdentityT m) = XML + newtype HSX.Child (IdentityT m) = IChild { unIChild :: XML } + newtype HSX.Attribute (IdentityT m) = IAttr { unIAttr :: Attribute } + 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)) + return (Element (toName n) attrs' children') + xmlToChild = IChild + + +instance (Monad m, Functor m) => HSX.EmbedAsAttr (IdentityT m) Attribute where + asAttr = return . (:[]) . IAttr + +instance (Monad m, Functor m) => HSX.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 + asAttr (n := str) = asAttr $ MkAttr (toName n, pAttrVal str) + +instance (Monad m, Functor m) => HSX.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 + asAttr (n := i) = asAttr $ MkAttr (toName n, pAttrVal (show i)) + +instance (Monad m, Functor m) => EmbedAsChild (IdentityT m) Char where + asChild = XMLGenT . return . (:[]) . IChild . pcdata . (:[]) + +instance (Monad m, Functor m) => EmbedAsChild (IdentityT m) String where + asChild = XMLGenT . return . (:[]) . IChild . pcdata + +instance (Monad m, Functor m) => EmbedAsChild (IdentityT m) (IdentityT m String) where + asChild c = + do c' <- lift c + lift . return . (:[]) . IChild . pcdata $ c' + +instance (Monad m, Functor m) => EmbedAsChild (IdentityT m) XML where + asChild = XMLGenT . return . (:[]) . IChild + +instance (Monad m, Functor m) => EmbedAsChild (IdentityT m) () where + asChild () = return [] + +instance (Monad m, Functor m) => AppendChild (IdentityT 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 stripChild chs)) + +stripAttr :: (Monad m, Functor m) => HSX.Attribute (IdentityT m) -> Attribute +stripAttr (IAttr a) = a + +stripChild :: (Monad m, Functor m) => HSX.Child (IdentityT m) -> XML +stripChild (IChild c) = c + +instance (Monad m, Functor m) => SetAttr (IdentityT m) XML where + setAll xml hats = do + attrs <- hats + case xml of + CDATA _ _ -> return xml + Element n as cs -> return $ Element n (foldr insert as (map stripAttr attrs)) cs + +insert :: Attribute -> Attributes -> Attributes +insert = (:) + +evalIdentityT :: (Functor m, Monad m) => XMLGenT (IdentityT m) XML -> m XML +evalIdentityT = runIdentityT . HSX.unXMLGenT + +type IdentT m = XMLGenT (IdentityT m) XML hunk ./happstack/src/HSP/ServerPartT.hs 1 +{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances, TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module HSP.ServerPartT where + +import HSP +import Control.Applicative ((<$>)) +import qualified HSX.XMLGenerator as HSX +import Happstack.Server (ServerPartT) + +instance (Monad m) => HSX.XMLGen (ServerPartT m) where + type HSX.XML (ServerPartT m) = XML + newtype HSX.Child (ServerPartT m) = SChild { unSChild :: XML } + newtype HSX.Attribute (ServerPartT m) = SAttr { unSAttr :: Attribute } + genElement n attrs children = + do attribs <- map unSAttr <$> asAttr attrs + childer <- flattenCDATA . map unSChild <$> asChild children + HSX.XMLGenT $ return (Element + (toName n) + attribs + childer + ) + xmlToChild = SChild + +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) => HSX.EmbedAsAttr (ServerPartT m) Attribute where + asAttr = return . (:[]) . SAttr + +instance (Monad m) => HSX.EmbedAsAttr (ServerPartT m) (Attr String Char) where + asAttr (n := c) = asAttr (n := [c]) + +instance (Monad m) => HSX.EmbedAsAttr (ServerPartT m) (Attr String String) where + asAttr (n := str) = asAttr $ MkAttr (toName n, pAttrVal str) + +instance (Monad m) => HSX.EmbedAsAttr (ServerPartT 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 (ServerPartT m) (Attr String Int) where + asAttr (n := i) = asAttr $ MkAttr (toName n, pAttrVal (show i)) + +instance (Monad m) => EmbedAsChild (ServerPartT m) Char where + asChild = XMLGenT . return . (:[]) . SChild . pcdata . (:[]) + +instance (Monad m) => EmbedAsChild (ServerPartT m) String where + asChild = XMLGenT . return . (:[]) . SChild . pcdata + +instance (Monad m) => EmbedAsChild (ServerPartT m) XML where + asChild = XMLGenT . return . (:[]) . SChild + +instance Monad m => EmbedAsChild (ServerPartT m) () where + asChild () = return [] + +instance (Monad m) => AppendChild (ServerPartT 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 unSChild chs)) + +instance (Monad m) => SetAttr (ServerPartT 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 unSAttr attrs)) cs + +instance (Monad m) => XMLGenerator (ServerPartT m) hunk ./happstack/src/HSP/WebT.hs 1 +{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances, TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module HSP.WebT where + +import HSP +import Control.Applicative ((<$>)) +import qualified HSX.XMLGenerator as HSX +import Happstack.Server (WebT) + +instance (Monad m) => HSX.XMLGen (WebT m) where + type HSX.XML (WebT m) = XML + newtype HSX.Child (WebT m) = WChild { unWChild :: XML } + newtype HSX.Attribute (WebT m) = WAttr { unWAttr :: Attribute } + genElement n attrs children = + do attribs <- map unWAttr <$> asAttr attrs + childer <- flattenCDATA . map unWChild <$> asChild children + HSX.XMLGenT $ return (Element + (toName n) + attribs + childer + ) + xmlToChild = WChild + +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) => 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) => 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) => 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) hunk ./happstack/src/Happstack/Server/HSX.hs 2 +{-# OPTIONS_GHC -fno-warn-orphans #-}