{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}
module UI.Templates(page, inspector, inspector', sessionForm,
    xmlNode, xmlNode', elSelector, elPage) where

import Happstack.Lite
import Text.Blaze.Html5 as H
import Text.Blaze.Html5.Attributes as A
import Text.Blaze.Html
import Data.Text as Txt

import Internal
import Control.Monad.IO.Class (liftIO)
import Control.Monad (unless, when, forM)
import Control.Concurrent.MVar
import Data.UUID as ID

import Text.XML (Element(..), Node(..), Instruction(..), Name(..))
import Text.XML.Cursor as XC
import qualified Data.Map as M

import Messages
import Happstack.Server.I18N

page :: (Response -> ServerPart Response) -> [Text] -> AttributeValue -> ([Text] -> Html) -> ServerPart Response
page return' title class_ body' = do
    langs <- bestLanguage <$> acceptLanguage
    return' $ toResponse $ html $ do
        H.head $ do
            link ! rel "stylesheet" ! href "/assets/pantheon.css"
            H.title $ text $ intercalate " — " title
        body ! A.class_ class_ $ body' langs

inspector :: (Response -> ServerPart Response) -> Text -> Session' -> ([Text] -> Html) -> ServerPart Response
inspector = inspector' ""
inspector' :: String -> (Response -> ServerPart Response) -> Text -> Session' -> ([Text] -> Html) -> ServerPart Response
inspector' q return' title session' body' = do
    let timeout = H.stringValue $ show $ pageLoad $ timeouts session'
    page return' [title, pack $ show $ currentURL $ session', "Amphiarao"] "fill" $ \langs -> do
        header $ do
            unless (Prelude.null $ backStack session') $ postButton "/nav/back" (l' langs Back') "🡸"
            unless (Prelude.null $ nextStack session') $ postButton "/nav/next" (l' langs Next') "🡺"
            postButton "/nav/reload" (l' langs Reload') "↻"
            hr
            H.form ! action' ["/", uuid', "/search"] ! alt (l' langs Search') $ do
                input ! type_ "search" ! name "q" ! value (stringValue q) ! placeholder (l' langs Search')
        body' langs
        footer $ do
            H.form ! action' ["/close/", uuid'] ! A.method "POST" ! alt (l' langs CloseSession') $ do
                button ! type_ "submit" $ l langs CloseSession
            hr
            H.form ! action' ["/", uuid', "/timeout"] ! A.method "POST" ! alt (l' langs LoadTimeout') $ p $ do
                H.label $ do
                    l langs LoadTimeout
                    input ! type_ "number" ! name "pageLoad" ! value timeout
                text "ms"

  where
    uuid' = ID.toString $ uuid_ session'
    action' = A.action . H.stringValue . Prelude.concat
    postButton target title' label = H.form ! action' ["/", uuid', target] ! alt title' ! A.method "POST" $ do
        button ! type_ "submit" ! A.title title' $ label

sessionForm langs = H.form ! A.method "POST" ! action "/" ! alt (l' langs CreateSession') $ do
    input ! type_ "url" ! name "target" ! placeholder "URL to debug"
    button ! type_ "submit" $ l langs CreateSession

--- XML formatting

xmlNode (NodeElement (Element name attrs childs)) = do
    symbolTok False "<"
    ident'Tok name
    forM (M.toList attrs) $ \(name, value) -> do
        text " "
        ident'Tok name
        symbolTok True "="
        stringTok $ show value -- quote it!
    when (Prelude.null childs) $ symbolTok True "/"
    symbolTok False ">"
  where
    ident'Tok (Name tag _ ns) = do
        case ns of
            Just ns' -> do
                qualifyTok ns'
                symbolTok False ":"
            Nothing -> return ()
        identTok tag
xmlNode (NodeInstruction (Instruction name value)) = do
    symbolTok False "<"
    symbolTok True "?"
    identTok name
    text " "
    stringTok $ unpack value
    symbolTok True "?"
    symbolTok False ">"
xmlNode (NodeContent text) = stringTok $ show text
xmlNode (NodeComment text) = do
    symbolTok False "<!--"
    commentTok text
    symbolTok False "-->"

xmlNode' (NodeElement el) = elSelector el
xmlNode' node = xmlNode node

elSelector (Element (Name name _ ns) attrs _) = do
    -- Yes, token classification isn't a great fit!
    case ns of
        Just ns' -> do
            keywordTok ns'
            symbolTok False "|"
        Nothing -> return ()
    keywordTok name
    qualifiers "id" "#" identTok
    qualifiers "class" "." qualifyTok
    return ()
  where
    qualifiers attr symb tok
        | Just val <- attr `M.lookup` attrs = forM (Txt.words val) $ \val' -> do
            symbolTok True symb
            tok val'
        | otherwise = return []

elPage uuid cursor links = blockquote $ do
    nav $ void $ forM (Prelude.reverse $ XC.ancestor cursor) $ \el -> do
        link el $ xmlNode' $ XC.node el -- Should all be elements...
        symbolTok False " > "
    link cursor $ p $ xmlNode $ XC.node cursor
    ol $ void $ forM (XC.child cursor) $ \el -> li $ link el $ xmlNode $ XC.node el
  where
    link el | Just uuid' <- Prelude.lookup (XC.node el) links =
            a ! target "_top" ! href (stringValue $ href' uuid')
        | otherwise = H.span -- Shouldn't happen...
    href' el = '/':ID.toString uuid ++ "/el/" ++ (ID.toString el)

void act = act >> return ()

symbolTok False = token "symbol silent"
symbolTok True = token "symbol"
qualifyTok = token "qualify"
keywordTok = token "keyword"
identTok = token "ident"
stringTok = token "string" . pack
commentTok = token "comment"

token type_ txt = H.span ! class_ (stringValue ("tok-" ++ type_)) $ text txt