[Version 0.83 - Removed modules that moved to happstack David Fox **20100218055302 Ignore-this: d3d6aabcbbeed177792a284619f62de6 ] { hunk ./debian/changelog 1 +haskell-happstack-extra (0.83) unstable; urgency=low + + * Remove modules that moved to happstack. + + -- David Fox Wed, 17 Feb 2010 21:52:37 -0800 + hunk ./happstack-extra.cabal 2 -Version: 0.82 +Version: 0.83 hunk ./happstack-extra.cabal 12 -Exposed-Modules: HSP.Google.Analytics, HSP.HTML.Extra, HSP.Identity, HSP.IdentityT, HSP.WebT, HSP.ServerPartT - Happstack.Extra, Happstack.Data.IxSet.Extra, +Exposed-Modules: HSP.HTML.Extra, Happstack.Extra, Happstack.Data.IxSet.Extra, hunk ./happstack-extra.cabal 24 - happstack-server, happstack-data, happstack-ixset, happstack-util, happstack-state, happstack, + happstack-server, happstack-data, happstack-ixset, happstack-util, happstack-state, happstack >= 0.4.3, hunk ./src/HSP/Google/Analytics.hs 1 -{-# OPTIONS_GHC -fglasgow-exts -F -pgmFtrhsx #-} -module HSP.Google.Analytics - ( UACCT(..) - , analytics - , addAnalytics - ) 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) --} rmfile ./src/HSP/Google/Analytics.hs rmdir ./src/HSP/Google hunk ./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.Applicative -import Control.Monad.Identity -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 - --- send upstream to applicative-extra -instance Applicative Identity where - pure = return - (<*>) = ap rmfile ./src/HSP/Identity.hs hunk ./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 Data.Maybe (fromMaybe) -- for demos at bottom -import Data.List (lookup) -- for demos at bottom -import Control.Applicative -import Control.Monad.Identity -import Control.Monad.Reader -- for demos at bottom -import Control.Monad.Trans -import HSP -import qualified HSX.XMLGenerator as HSX - --- * IdentityT Monad Transformer - -newtype (Monad m) => IdentityT m a = IdentityT { runIdentityT :: m a } - deriving (Monad) - -instance (Functor m, Monad m) => Functor (IdentityT m) where - fmap f = IdentityT . fmap f . runIdentityT - -instance MonadTrans IdentityT where - lift = IdentityT - -instance (MonadIO m) => MonadIO (IdentityT m) where - liftIO = IdentityT . liftIO - -instance (Functor m, Monad m) => Applicative (IdentityT m) where - pure = return - (<*>) = ap - --- * 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 - -page :: (Monad m, Functor m) => IdentT m -page = - - - whee! - - -

whee

- - - -testIO :: IO () -testIO = evalIdentityT page >>= putStrLn . renderAsHTML - -testIdentity :: IO () -testIdentity = putStrLn (renderAsHTML (runIdentity (evalIdentityT page))) - -testReader :: IO () -testReader = putStrLn (renderAsHTML (runReader (evalIdentityT page') [("title","sweet!"), ("paragraph","rock!") ])) - where - lookup' :: String -> IdentityT (Reader [(String, String)]) String - lookup' n = lift $ - do env <- ask - return $ fromMaybe (n ++" not found in environment.") $ lookup n env - page' :: IdentT (Reader [(String, String)]) - page' = - - - <% lookup' "title" %> - - -

<% lookup' "paragraph" %>

-

<% lookup' "doesNotExist" %>

- - rmfile ./src/HSP/IdentityT.hs hunk ./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 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) rmfile ./src/HSP/ServerPartT.hs hunk ./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 Control.Monad.Identity -import qualified HSX.XMLGenerator as HSX -import Happstack.Server - -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) rmfile ./src/HSP/WebT.hs }