{-# LANGUAGE PatternSignatures #-}
module Types
    ( Node(..)
    , example
    ) where

import Control.Arrow (second)
import Control.Monad.Reader
import Data.Char
import Data.List
import Data.Maybe
import Text.XHtml.Transitional hiding (title)
import CGI.Tree
import Encoding.Octets
import Html.Style
import Html.URIQuery
import qualified HtmlParser as H
import TreePath
import URI

-- For debugging
import qualified Data.ByteString.Lazy as B

data Node
    = HomePage { pageTitle :: Html, pageColumns :: [Node] }
    | Column [Node]
    | Section { sectionTitle :: Html, links :: [Node] }
    | Link (Maybe URI) Html
--  | Undecided
    deriving (Read, Show, Eq)

isIncomplete :: Node -> Bool
isIncomplete (Link uri label) = isNothing uri || isNoHtml label
isIncomplete (Section title _links) = isNoHtml title
isIncomplete _ = False

instance App Node where
    -- |Generate the heading of a HomePage.
    appHeadHtml page@(HomePage _ _) = return $ myStyle +++ thetitle (pageTitle page)
    appHeadHtml _ = return $ stringToHtml "Internal error"
    editApp = editHomePage
    appBodyHtml = homePageBodyHtml
    setNode _ x = {-return-} x
    mergeApps _name xs = undefined

editHomePage item =
    do info <- ask
       let e = case edits info of [] -> [ListEdit {listOp=NoOp, elemID=TreePath []}]; xs -> xs
       item' <- runTREE (foldM formUpdateM item e) (makeTreeInfo info)
       return (item, item')
    where
      edits info = nub . catMaybes . map parseEdit . inputs $ info
      formUpdateM x e = traverseM e [x] >>= \ x' -> case x' of
                                                      [x] -> return x
                                                      xs -> error ("Internal error: " ++ show xs)

homePageBodyHtml item =
    do info <- ask
       let (f :: TREE Html) = nodeHtml noHtml item
       runTREE (pushDir item pos1 f) (makeTreeInfo info)

example =
    HomePage
    { pageTitle = stringToHtml "Start"
    , pageColumns =
        [ Column [ Section { sectionTitle = stringToHtml "Personal", links = [] } ]
        , Column [ Section { sectionTitle = stringToHtml "Local", links = [] } ]
        , Column [ Section { sectionTitle = stringToHtml "Shopping", links = [] } ]
        , Column [ Section { sectionTitle = stringToHtml "News", links = [] } ]
        , Column [ Section { sectionTitle = stringToHtml "Search", links = [] } ]
        , Column [ Section { sectionTitle = stringToHtml "Politics", links = [] } ] ] }

instance Tree Node where
    create (TreePath [_, _, _, _]) = Link Nothing noHtml
    create (TreePath [_, _, _]) = Section {sectionTitle = noHtml, links = []}
    create (TreePath [_, _]) = Column []
    create (TreePath [_]) = HomePage {pageTitle = noHtml, pageColumns = []}
    create (TreePath path) = error $ "create " ++ show path
    node _ = Nothing
    nodeHtml nav x =
        do view <- getView
           uri <- lift scriptURI
           path <- ask >>= return . toPath . stack :: TREE TreePath
           -- There are two levels of editing, one where we have navigation
           -- controls with the element, and one where we also have
           -- text entry forms.  The first, called "nav", is used when
           -- the "view" CGI variable is set to "edit".  The second,
           -- called "edit", is used for a particular element when, in
           -- addition, there is a CGI variable of the form
           -- "<elementID>_edit=1".
           edit <- ask >>= return . maybe False (const True) . lookup (showId path +-+ "edit") . inputs . appInfo
           let view' = if edit || isIncomplete x then "edit" else if view == "edit" then "nav" else view
           let nav' = case view' of
                        "show" -> noHtml
                        _ -> nav +++ editButton uri path +++ deleteButton uri path
           (result :: Html) <- html nav' x view'
           return result
    listHtml _items@(Link _ _ : _) elems = return (concatHtml (intersperse br elems))
    listHtml _items elems = return (concatHtml elems)
    getElements (HomePage {pageColumns = cols}) = cols
    getElements (Column nodes) = nodes
    getElements (Section {links = links}) = links
    getElements (Link _ _) = []
    setElements page@(HomePage _ _) cols = page {pageColumns = cols}
    setElements (Column _) sections = Column sections
    setElements sec@(Section _ _) links = sec {links = links}
    setElements link@(Link _ _) [] = link
    setElements (Link _ _) _ = error "setElements: Invalid argument"
    deleteElement pos xs = deleteElt pos xs
    -- Ignore the edit command during the traverse, it is only used to
    -- modify the rendering of the element.
    update "edit" _ x = x
    update "uri" v (Link _ x) = Link (u (unpack v)) x
    update "label" v (Link x _) = Link x (either (const . stringToHtml . unpack $ v) id (H.parseEither . unpack $ v))
    update s _ (Link _ _) = error $ "Undefined Link operation: " ++ s
    update "update" v x@(Section _ _) = x { sectionTitle = H.parse (unpack v) }
    update s _ (Section _ _) = error $ "Undefined Section operation " ++ s
    update s _ (Column _) = error $ "Undefined Columns operation " ++ s
    update s _ (HomePage _ _) = error $ "Undefined HomePage operation: " ++ s

u = \ s -> maybe (parseRelativeReference s) Just (parseURI s)

getView :: TREE String
getView = ask >>= return . maybe "show" unpack . lookup "view" . inputs . appInfo

html :: Html -> Node -> String -> TREE Html
html nav (Link uri label) "edit" =
    do uriField <- formTextfield "uri" (maybe Nothing (\ x -> Just (uriToString id x "")) uri) []
       labelField <- formTextfield "label" (Just (showHtmlFragment label)) []
       return (stringToHtml "URL:" +++ uriField +++ br +++ 
               stringToHtml "Label:" +++ labelField +++ nav)
html nav (Link uri label) view =
    let uri' = maybe "invalid" (\ x -> uriToString id x "") uri in
    return $ anchor (toHtml label) ! [strAttr "href" uri'] +++ nav
html nav section@(Section _ _) view =
    sectionHtml (if view == "show" then noHtml else nav) section (if view == "edit" then editTitle else showTitle)
    where
      showTitle section nav =
          return (sectionTitle section +++ nav)
      editTitle section nav =
          do field <- formTextfield "update" (Just (renderHtmlFragment (sectionTitle section))) []
             return (field +++ nav)
      sectionHtml :: Html -> Node -> (Node -> Html -> TREE Html) -> TREE Html
      sectionHtml nav section titleHtml =
          do (topnav, content) <- treeHtml section
             title <- titleHtml section {- maybe topnav Just -} nav
             return (tr (th title ! [strAttr "bgcolor" "#dcdcdc"]) +++
                     tr (td content) ! [strAttr "valign" "top"])
html nav column@(Column _) view =
    do (nav', content) <- treeHtml column
       let nav'' = {- maybe (maybe noHtml id nav') id -} (if view == "show" then noHtml else nav)
       return $ td (table (tr (th nav'') +++ content) ! tableattrs3) ! [strAttr "valign" "top"]
html nav page@(HomePage _ _) view =
    do (topnav, content) <- treeHtml page
       uri <- lift scriptURI
       let nav' = {- maybe topnav Just -} nav
       extra <- debug
       elem <- elemId
       return $ table (tr (heading uri page nav' elem) +++ tr (td content)) ! tableattrs0 +++ extra
    where
      heading :: URI -> Node -> Html -> String -> Html
      heading script page nav elem =
          (td 
           (table 
            (tr (th (formLink' (delURIAttrs script ["view"]) (pageTitle page) elem) +++
                 th (formLink' script (stringToHtml "Edit Links") elem) +++
                 th (formLink' script (stringToHtml "Edit Sections") elem) +++
                 th (formLink' (setURIAttrs script [("view", "edit")]) (stringToHtml "Edit Columns") elem) +++
                 --th (formLink script (stringToHtml "Edit Title") (Just (undefined :: HomePage))) +++
                 -- It is important to have a submit button at the
                 -- top of the form because otherwise hitting the
                 -- enter key on a textarea input causes submits
                 -- that appears to be going to another control,
                 -- like the top navigation insert.
                 th (submit "submit" "update") +++
                 --th (submit "submit" "undo") +++
                 th (emphasize (stringToHtml "Email my gmail account, user name ddssff")) +++
                 if view == "show" then noHtml else nav))
            ! (tableattrs3 ++ [intAttr "size" 2, strAttr "width" "100%"]))
           ! [intAttr "colspan" (length (pageColumns page) + 1), strAttr "align" "center"])
      debug = do tree <- ask
                 let info = appInfo tree
                 return $ case lookup "debug" (inputs info) of
                            Nothing -> noHtml
                            _ -> concatHtml (intersperse br (map (stringToHtml . show . second unpack) (inputs info)))
      unpack (Octets s) = map (chr . fromInteger . toInteger) . B.unpack $ s