{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}
module UI.Templates(page, inspector, inspector', sessionForm,
    xmlNode, xmlNode', elSelector, elPage, hlCSS, hlCSSs, identTok, symbolTok) 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 Internal.Load (isClickableEl)
import Internal.Forms (isTypableEl, readInput')
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 Data.Maybe (fromMaybe)

import Data.CSS.Syntax.Tokens

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 elValue langs = blockquote $ do
    nav $ do
        forM (Prelude.reverse $ XC.ancestor cursor) $ \el -> do
            link el $ xmlNode' $ XC.node el -- Should all be elements...
            symbolTok False " > "
        H.form ! class_ "disclosure" ! target "_top" ! alt (l' langs SearchChildren') !
                action (stringValue ('/':ID.toString uuid ++ "/search")) ! A.method "GET" $ do
            input ! type_ "hidden" ! name "el" !
                value (stringValue $ fromMaybe "" $ ID.toString <$> Prelude.lookup (XC.node cursor) links)
            input ! type_ "search" ! name "q" ! placeholder (l' langs SearchChildren')
        when (isClickableEl cursor) $ H.form ! class_ "disclosure" ! target "_top" ! alt (l' langs Click') !
                action (stringValue ('/':ID.toString uuid ++ "/click")) ! A.method "POST" $ do
            input ! type_ "hidden" ! name "el" !
                value (stringValue $ fromMaybe "" $ ID.toString <$> Prelude.lookup (XC.node cursor) links)
            button $ l langs Click
    link cursor $ p $ xmlNode $ XC.node cursor
    ol $ void $ forM (XC.child cursor) $ \el -> li $ link el $ xmlNode $ XC.node el
    when (isTypableEl cursor) $ H.form ! target "_top" ! alt (l' langs EnterValue') !
            action (stringValue ('/':ID.toString uuid ++ "/type")) ! A.method "POST" $ do
        input ! type_ "hidden" ! name "el" !
            value (stringValue $ fromMaybe "" $ ID.toString <$> Prelude.lookup (XC.node cursor) links)
        input ! type_ "text" ! name "text" ! placeholder (l' langs EnterValue') ! value (textValue elValue)
        button $ l langs SetValue
        button ! name "reset" $ l langs ResetValue
  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
stringTok' = token "string"
commentTok = token "comment"
errorTok = token "error"
numTok = token "num"

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

--- CSS formatting
hlCSSs toks = do
    forM toks $ \tok -> do
        hlCSS tok
        text " " -- Because Haskell Stylist stripes Whitespace out from properties.
    return ()
hlCSS Whitespace = " " -- Filtered out by caller.
hlCSS CDO = commentTok "<!--"
hlCSS CDC = commentTok "-->"
hlCSS Comma = symbolTok True ","
hlCSS Colon = symbolTok True ":"
hlCSS Semicolon = symbolTok True ";"
hlCSS LeftParen = "("
hlCSS RightParen = ")"
hlCSS LeftSquareBracket = "["
hlCSS RightSquareBracket = "]"
hlCSS LeftCurlyBracket = "{"
hlCSS RightCurlyBracket = "}"
hlCSS SuffixMatch = symbolTok True "$="
hlCSS SubstringMatch = symbolTok True "*="
hlCSS PrefixMatch = symbolTok True "^="
hlCSS DashMatch = symbolTok True "|="
hlCSS IncludeMatch = symbolTok True "~="
hlCSS Column = symbolTok True "||"
hlCSS tok@(String _) = stringTok' $ serialize [tok]
hlCSS BadString = errorTok "\"\n"
hlCSS (Number x _) = numTok x
hlCSS (Percentage x _) = numTok (x `Txt.append` "%")
hlCSS (Dimension x _ u) = numTok (x `Txt.append` u)
hlCSS (Url x) = do
    identTok "url("
    stringTok' x
    text ")"
hlCSS BadUrl = errorTok "url(()"
hlCSS (Ident x) = keywordTok x
hlCSS (AtKeyword x) = keywordTok ('@' `Txt.cons` x)
hlCSS (Function x) = identTok (x `Txt.append` "(")
hlCSS (Hash HId x) = keywordTok ('#' `Txt.cons` x)
hlCSS (Hash HUnrestricted x) = stringTok' ('#' `Txt.cons` x)
hlCSS (Delim x) = symbolTok True $ Txt.pack [x]