[copy in required modules from happstack-extra, and drop happstack-extra dependency Jeremy Shaw **20091204031304 Ignore-this: 522f735bec55cbc670e85775d8fc54ea ] adddir ./HSP adddir ./HSP/Google addfile ./HSP/Google/Analytics.hs addfile ./HSP/ServerPartT.hs hunk ./HSP/Google/Analytics.hs 1 +{-# OPTIONS_GHC -fglasgow-exts -F -pgmFtrhsx #-} +module HSP.Google.Analytics + ( UACCT(..) + , analytics + ) where + +import Data.Generics +import HSP +-- import Happstack.Template.HSP + +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 %> immedialy for the tag +-- See also: addAnalytics +analytics :: (XMLGenerator m) => UACCT -> GenXMLList m +-- analytics :: (Monad m) => UACCT -> HSPT m [XML] +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 :: (Monad m) => UACCT -> HSPT m XML -> HSPT m XML +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) +-} +-- import Happstack.Template.HSP + +{- Example Analytics Code from Google: + + +-} + +-- * Test +{- +testXML' :: Web XML -> IO XML +testXML' xml = evalHSP (runWebXML undefined xml) + +testXML :: Web XML -> IO () +testXML xml = evalHSP (runWebXML undefined xml) >>= putStrLn . renderAsHTML + + +-- dummy :: (Monad m) => HSPT m HSP.XML +-- dummy :: Web HSP.XML +dummy :: (EmbedAsChild m [Char]) => GenXML m +dummy = + + + the title + + +

the body

+ + +-} + +{- +-- * OLD + +pageTemplate :: UACCT -> Web XML -> Web XML -> Web XML +pageTemplate uacct header body = + do a <- analytics uacct + hdr <- header + (Element (Nothing, "body") attrs children) <- body + h <- + <% hdr %> + <% (Element (Nothing, "body") attrs (children ++ a)) %> + + return h + +pageTest = + pageTemplate (UACCT "hi") + + I like Cheese! + + +

bork brok brok

+ +-} +{- +addAnalytics :: UACCT -> Web XML -> Web XML +addAnalytics uacct page = + case page of + (Element (Nothing, "html") attrs children) -> + return $ (Element (Nothing, "html") attrs + case find (\(Element (Nothing, name) _ _) -> name == "body") children of + (Just (\ (Element (Nothing, name) attrs bodyChildren))) -> + do a <- analytics uacct + return $ (Element (Nothing, name) attrs bodyChildren) +-} hunk ./HSP/ServerPartT.hs 1 +{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances, TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module HSP.ServerPartT where + +import HSP +import Control.Applicative +import Control.Monad.Identity +import qualified HSX.XMLGenerator as HSX +import Happstack.Server + +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.com.cabal 2 -Version: 0.0.1 +Version: 0.0.2 hunk ./happstack.com.cabal 17 - happstack-extra >= 0.71, hunk ./happstack.com.cabal 23 - directory + directory, + syb +