module Happstack.Facebook.FacebookT where
import HSP
import Control.Applicative (Applicative((<*>), pure), Alternative((<|>), empty), WrappedMonad(WrapMonad, unwrapMonad), (<$>))
import Control.Monad.Identity
import Control.Monad.Reader
import Data.List (intersperse)
import qualified HSX.XMLGenerator as HSX
import Happstack.Server (ServerMonad(askRq, localRq), FilterMonad(setFilter,composeFilter,getFilter), WebMonad(finishWith))
import URLT (ShowURL(showURL), URL)
newtype FacebookT s m a =
FacebookT { unFacebookT :: ReaderT s m a }
deriving (Functor, Monad, MonadFix, MonadPlus, MonadIO, MonadTrans)
instance (Monad m) => Applicative (FacebookT s m) where
pure = FacebookT . return
(FacebookT m) <*> (FacebookT n) = FacebookT (m `ap` n)
instance (MonadPlus m) => Alternative (FacebookT s m) where
empty = unwrapMonad empty
f <|> g = unwrapMonad $ (WrapMonad f) <|> (WrapMonad g)
instance (ServerMonad m) => ServerMonad (FacebookT s m) where
askRq = lift askRq
localRq f (FacebookT m) = FacebookT (mapReaderT (localRq f) m)
instance (FilterMonad a m) => FilterMonad a (FacebookT s m) where
setFilter f = lift (setFilter f)
composeFilter f = lift (composeFilter f)
getFilter (FacebookT m) = FacebookT (mapReaderT getFilter m)
instance (WebMonad a m) => WebMonad a (FacebookT s m) where
finishWith = lift . finishWith
instance (Monad m) => MonadReader s (FacebookT s m) where
ask = FacebookT ask
local f (FacebookT m) = FacebookT (local f m)
instance (ShowURL m) => ShowURL (FacebookT s m) where
type URL (FacebookT s m) = URL m
showURL u = FacebookT $ ReaderT $ const (showURL u)
instance (Monad m) => HSX.XMLGen (FacebookT s m) where
type HSX.XML (FacebookT s m) = XML
newtype HSX.Child (FacebookT s m) = FChild { unFChild :: XML }
newtype HSX.Attribute (FacebookT s m) = FAttr { unFAttr :: Attribute }
genElement n attrs children =
do attribs <- map unFAttr <$> asAttr attrs
childer <- flattenCDATA . map unFChild <$> asChild children
HSX.XMLGenT $ return (Element
(toName n)
attribs
childer
)
xmlToChild = FChild
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 (FacebookT s m) Attribute where
asAttr = return . (:[]) . FAttr
instance (Monad m) => HSX.EmbedAsAttr (FacebookT s m) (Attr String Char) where
asAttr (n := c) = asAttr (n := [c])
instance (Monad m) => HSX.EmbedAsAttr (FacebookT s m) (Attr String String) where
asAttr (n := str) = asAttr $ MkAttr (toName n, pAttrVal str)
instance (Monad m) => HSX.EmbedAsAttr (FacebookT s m) (Attr (String, String) String) where
asAttr (n := str) = asAttr $ MkAttr (toName n, pAttrVal str)
instance (Monad m) => HSX.EmbedAsAttr (FacebookT s 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 (FacebookT s m) (Attr String Int) where
asAttr (n := i) = asAttr $ MkAttr (toName n, pAttrVal (show i))
instance (Monad m) => EmbedAsChild (FacebookT s m) Char where
asChild = XMLGenT . return . (:[]) . FChild . pcdata . (:[])
instance (Monad m) => EmbedAsChild (FacebookT s m) String where
asChild = XMLGenT . return . (:[]) . FChild . pcdata
instance (Monad m) => EmbedAsChild (FacebookT s m) XML where
asChild = XMLGenT . return . (:[]) . FChild
instance (Monad m) => EmbedAsChild (FacebookT s m) () where
asChild () = return []
instance (Monad m) => AppendChild (FacebookT s 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 unFChild chs))
instance (Monad m) => SetAttr (FacebookT s 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 unFAttr attrs)) cs
instance (Monad m) => XMLGenerator (FacebookT s m)
renderAsFBML :: XML -> String
renderAsFBML xml = renderAsFBML' 0 xml ""
data TagType = Open | Close | Single
renderAsFBML' :: Int -> XML -> ShowS
renderAsFBML' _ (CDATA needsEscape cd) = showString (if needsEscape then escape cd else cd)
renderAsFBML' n elm@(Element name@(Nothing, nm) attrs children)
| nm == "area" = renderTagEmpty children
| nm == "base" = renderTagEmpty children
| nm == "br" = renderTagEmpty children
| nm == "col" = renderTagEmpty children
| nm == "hr" = renderTagEmpty children
| nm == "img" = renderTagEmpty children
| nm == "input" = renderTagEmpty children
| nm == "link" = renderTagEmpty children
| nm == "meta" = renderTagEmpty children
| nm == "param" = renderTagEmpty children
| nm == "script" = renderElement n (Element name attrs (map asCDATA children))
| nm == "style" = renderElement n (Element name attrs (map asCDATA children))
where
renderTagEmpty [] = renderTag Open n name attrs
renderTagEmpty _ = renderElement n elm
asCDATA :: XML -> XML
asCDATA (CDATA _ cd) = (CDATA False cd)
asCDATA o = o
renderAsFBML' n elm = renderElement n elm
renderElement :: Int -> XML -> String -> String
renderElement n (Element name attrs children) =
let open = renderTag Open n name attrs
cs = renderChildren n children
close = renderTag Close n name []
in open . cs . close
where
renderChildren :: Int -> Children -> ShowS
renderChildren n' cs = foldl (.) id $ map (renderAsFBML' (n'+2)) cs
renderTag :: TagType -> Int -> Name -> Attributes -> ShowS
renderTag typ n name attrs =
let (start,end) = case typ of
Open -> (showChar '<', showChar '>')
Close -> (showString "</", showChar '>')
nam = showName name
as = renderAttrs attrs
in start . nam . as . end
where renderAttrs :: Attributes -> ShowS
renderAttrs [] = nl
renderAttrs attrs' = showChar ' ' . ats . nl
where ats = foldl (.) id $ intersperse (showChar ' ') $ fmap renderAttr attrs'
renderAttr :: Attribute -> ShowS
renderAttr (MkAttr (nam, (Value needsEscape val))) = showName nam . showChar '=' . renderAttrVal (if needsEscape then escape val else val)
renderAttrVal :: String -> ShowS
renderAttrVal s = showChar '\"' . showString s . showChar '\"'
showName (Nothing, s) = showString s
showName (Just d, s) = showString d . showChar ':' . showString s
nl = showChar '\n' . showString (replicate n ' ')