module Main (module Main) where

import GuaranteedCGI hiding (map, a, i, button, submit)
import qualified GuaranteedCGI as CGI
import Prelude hiding (head)
import Monad (when)
import Maybe (maybeToList)

main :: IO ()
main = run start

startTree :: Tree String
startTree =
    Node "/"
	[ Node "etc"
	    [ Node "X11" []
            ]
	, Node "bin" []
	, Node "dev" []
	, Node "lib" []
	, Node "usr"
	    [ Node "bin" []
            , Node "lib" []
            , Node "local"
                [ Node "bin" []
                , Node "lib" []
                ]
            , Node "share" []
            , Node "X11R6" []
            ]
	, Node "home" 
	    [ Node "tom" []
	    , Node "bart" []
	    ]
	]

data STATE =
    STATE
    { sTree         :: Tree (Bool, String)
    , sClipboard    :: [Tree (Bool, String)]
    }

start :: CGI ()
start = do
    mainScreen $
	STATE
	{ sTree	     = fmap ((,) True) startTree
        , sClipboard = []
	}

mainScreen :: STATE -> CGI ()
mainScreen state =
    ask $ do
        myPage "Tree Editor" $ do
            table $ do
                uaBORDER "1"
                uaCELLSPACING "0"
                tbody $ do
                    tr $ do
                        td $ do
                            myButton "COLLAPSE ALL" $ do
                                mainScreen $
                                    state { sTree = fmap (\(_, x) -> (True, x)) tree }
                        td $ do
                            myButton "EXPAND ALL" $ do
                                mainScreen $
                                    state { sTree = fmap (\(_, x) -> (False, x)) tree }
                        td $ do
                            myButton "CLEAR CLIPBOARD" $ do
                                mainScreen $
                                    state { sClipboard = [] }
            text $ "Clipboard contains " ++ show (length clipboard) ++ " trees"
            table $ do
                uaBORDER "1"
                uaCELLSPACING "0"
		tbody $ do
		    treeRows
  where
    STATE { sTree = tree, sClipboard = clipboard } = state
    zipWithApply = zipTreesWith ($)

    treeRows =
	(flip foldTree)
	    (fmap (const (,,,)) tree
		`zipWithApply` toTrees tree
		`zipWithApply` toContext tree
		`zipWithApply` toMaybeContext tree
		`zipWithApply` toDepths tree)
	    (\( subTree@(Node (isCollapsed, name) children)
	      , context
	      , contextM
	      , depth
	      )
	      chs -> do

		let hasChildren = not (null children)
		    hasCollapsedChildren = isCollapsed && hasChildren

                    remove clipbF =
                        case contextM Nothing of
                            Nothing -> ask $ do
                                myPage "NO TREE" $ do
                                    text "You have removed the whole tree"
                            Just tree' -> do
                                mainScreen $
                                    state
                                    { sTree = tree'
                                    , sClipboard = clipbF clipboard
                                    }

                tr $ do
                    td $ do
                        myButton "DELETE" $ do
                            remove id

                    td $ do
                        myButton "CUT" $ do
                            remove (++ [subTree])

                    td $ do
                        myButton "PASTE" $ do
                            mainScreen $
                                state
                                { sTree = context (Node (False, name) (children ++ clipboard))
                                , sClipboard = []
                                }

                    td $ do
                        myButton "ADD" $ do
                            addScreen
                                (mainScreen state) $
                                \newName -> 
                                    mainScreen $
                                        state
                                        { sTree = 
                                            context $ 
                                                Node (False, name)
                                                     (children ++ [Node (False, newName) []])
                                        }

                    td $ do
                        myButton "EDIT" $ do
                            editScreen
                                (mainScreen state)
                                name $
                                \newName ->
                                    mainScreen $
                                        state
                                        { sTree =
                                            context $ Node (isCollapsed, newName) children
                                        }

                    td $ do
                        let setColl c =
                                state { sTree = context (Node (c, name) children) }
                        when hasChildren $ do
                            if isCollapsed
                                then myButton "EXPAND" $ do
                                        mainScreen $ setColl False
                                else myButton "COLLAPSE" $ do
                                        mainScreen $ setColl True

		    td $ do
                        uaALIGN "left"
			uaSTYLE $ "padding-left: " ++ show depth ++ "cm"
			let t () = text name
			if hasCollapsedChildren
			    then strong (t ())
			    else (t ())

		when (not isCollapsed) $ sequence_ chs
	    )

----------------------------------------------------------------------

addScreen :: CGI () -> (String -> CGI ()) -> CGI ()
addScreen back add = do
    ask $ do
        myPage "New node" $ do
            text "Name: "
            i <- textInputField (uaSIZE "30")
            mySubmit
                (F1 i)
                (\(F1 i') -> add (value i'))
                (uaVALUE "ADD")
            br empty
            myButton "CANCEL" back

----------------------------------------------------------------------

editScreen :: CGI () -> String -> (String -> CGI ()) -> CGI ()
editScreen back name change = do
    ask $ do
        myPage "Edit node" $ do
            text "Name: "
            i <- textInputField $ do
                uaSIZE "30"
                uaVALUE name
            mySubmit
                (F1 i)
                (\(F1 i') -> change (value i'))
                (uaVALUE "CHANGE")
            br empty
            myButton "CANCEL" back

----------------------------------------------------------------------
-- The Tree datatype
-- 
-- In most new haskell environments it's distributed in Data.Tree module,
-- however, some older GHC version had a Show instance unsuitable for WASH.
-- It's irrelevant for this example, but we would be in trouble if we wanted
-- to load the initial tree from a database or file.

data Tree a = Node a [Tree a] deriving (Show, Read)

instance Functor Tree where
    fmap f (Node x ts) = Node (f x) (map (fmap f) ts)

zipTreesWith :: (a -> b -> c) -> Tree a -> Tree b -> Tree c
zipTreesWith f (Node x xts) (Node y yts) 
    = Node (f x y) (zipWith (zipTreesWith f) xts yts)

toContextGeneric :: (Tree a -> b) -> (b -> [Tree a]) -> Tree a -> Tree (b -> b)
toContextGeneric wrap1 wrap2 t = toCtx id t
  where
    toCtx ctx (Node elt children) =
        Node 
            ctx
            [ toCtx (\x -> let (before, _ : after) = splitAt i children
                            in  ctx (wrap1 (Node elt (before ++ wrap2 x ++ after))))
                    c
            | (i,c) <- zip [0..] children ]

toContext :: Tree a -> Tree (Tree a -> Tree a)
toContext = toContextGeneric id return

toListContext :: Tree a -> Tree ([Tree a] -> [Tree a])
toListContext = toContextGeneric return id

toMaybeContext :: Tree a -> Tree (Maybe (Tree a) -> Maybe (Tree a))
toMaybeContext = toContextGeneric Just maybeToList

toDepths :: Tree a -> Tree Int
toDepths t = foldTree f t 0
  where
    f _ cs d = Node d (map ($ d+1) cs)

toTrees :: Tree a -> Tree (Tree a)
toTrees n@(Node _ cs) = Node n (map toTrees cs)

foldTree :: (a -> [b] -> b) -> Tree a -> b
foldTree f (Node a cs) = f a (map (foldTree f) cs)

----------------------------------------------------------------------
-- Some CGI helpers

myPage :: String -> WithHTML FORM CGI () -> WithHTML DOCUMENT CGI ()
myPage screenName c = do
    html $ do
	head $ do
	    title $ text screenName
	    meta $ do
		uaNAME "author"
		uaCONTENT "Tomasz Zielonka <tomasz.zielonka@gmail.com>"
	body $ do
	    rawtext $ unlines $
		[ "<style type=\"text/css\"><!--"
		, ".myButton {"
		, "  border-width: 0;"
		, "  background-color: transparent;"
		, "  font-weight: bold;"
		, "  color: blue;"
		, "}"
		, "--></style>"
		]
            makeForm $ do
	        c

myButton :: AdmitChildINPUT y => String -> CGI () -> WithHTML y CGI ()
myButton txt action = do
    submit0 action $ do
	uaVALUE txt
	uaCLASS "myButton"

mySubmit :: (AdmitChildINPUT y, InputHandle h) =>
            h INVALID -> (h VALID -> CGI ()) -> WithHTML INPUT CGI () -> WithHTML y CGI ()
mySubmit inputs action elts = do
    CGI.submit inputs action (uaCLASS "myButton" >> elts)