{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances, TypeFamilies, GeneralizedNewtypeDeriving, UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
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

-- normally we would just derive this, but trhsx can't handle it
-- (haddock used to break as well, I wonder if that is fixed now?)
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)


------------------------------------------------------------------
-- Rendering

-- TODO: indents are incorrectly calculated

-- | Pretty-prints XML values.
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 (Element name attrs []) = renderTag Single n name attrs
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 -- this case should not happen in valid HTML
    asCDATA :: XML -> XML
    asCDATA (CDATA _ cd) = (CDATA False cd)
    asCDATA o = o -- this case should not happen in valid HTML
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 '>')
                           -- Single -> (showChar '<', showString "/>")
            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 ' ')