Literal XML in a pure function

[added HSP.Identity jeremy@n-heptane.com**20080829000516] { adddir ./examples addfile ./examples/HSPIdentity.hs addfile ./src/HSP/Identity.hs hunk ./HAppS-Extra.cabal 2 -Version: 0.9 +Version: 0.10 hunk ./HAppS-Extra.cabal 12 -Exposed-Modules: HSP.Google.Analytics, HSP.HTML.Extra, HAppS.Extra, HAppS.Data.IxSet.Extra, HAppS.Data.User.Password, - HAppS.Server.Session, HAppS.State.Extra, HAppS.Server.Account, HAppS.Server.Extra +Exposed-Modules: HSP.Google.Analytics, HSP.HTML.Extra, HSP.Identity, HAppS.Extra, HAppS.Data.IxSet.Extra, + HAppS.Data.User.Password, HAppS.Server.Session, HAppS.State.Extra, HAppS.Server.Account, + HAppS.Server.Extra hunk ./HAppS-Extra.cabal 16 -Build-Depends: base, hsp >= 0.4.4, harp >= 0.4, HAppS-IxSet, HAppS-Data, HAppS-Util, mtl, random, HAppS-State, html, HAppS-Server >= 0.9.2.2 +Build-Depends: base, hsp >= 0.4.4, harp >= 0.4, HAppS-IxSet, HAppS-Data, HAppS-Util, mtl, random, HAppS-State, html, HAppS-Server >= 0.9.2.2, hsx >= 0.4.4 hunk ./debian/changelog 1 +haskell-happs-extra (0.10) unstable; urgency=low + + * Added HSP.Identity + + -- Jeremy Shaw Thu, 28 Aug 2008 16:59:07 -0700 + hunk ./debian/control 12 + libghc6-hsx-prof (>= 0.4.4), + haskell-hsx-doc (>= 0.4.4), hunk ./examples/HSPIdentity.hs 1 - +{-# OPTIONS_GHC -fno-warn-orphans -F -pgmF trhsx #-} +-- |simple example of using Identity XML monad +module Main where + +import HSP +import HSP.Identity + +page :: XML +page = evalIdentity $ + + + Literal XML in a pure function + + +

Purely for demo purposes.

+ + + +main :: IO () +main = putStrLn (renderAsHTML page) 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.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 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 }