------------------------------------------------------------------
-- |
-- Module      :  Language.JSMW.DOM
-- Copyright   :  (c) Dmitry Golubovsky, 2009
-- License     :  BSD-style
-- 
-- Maintainer  :  golubovsky@gmail.com
-- Stability   :  experimental
-- Portability :  portable
-- 
--
--
-- JSMW DOM specific stuff for use with the older DOM package.
------------------------------------------------------------------
module Language.JSMW.DOM (
 -- * DOM-specific part of the Monad
  runJSMW
 ,currDocBody
 -- * Layout control
 ,ECRF
 ,passive
 ,nest
 ,container
 -- * Element references
 -- $ref
 ,ref
 ,ref2ecrf
 ,inside
 -- * DOM short-cuts
 ,addChild
 ,documentBody
 ,documentHead
 ,inlineStyle
 ,inlineStyleDecl
 -- * Inline style and other decorations
 ,CSSDeco (..)
 ,setStyle
 -- * Event handling
 ,OnHandler
 ,setHandler
 ,ask) where

import Language.JSMW.Monad
import Control.Monad
import Control.Monad.State
import Control.Monad.RWS
import BrownPLT.JavaScript

import Language.JSMW.Type
import Data.DOM.Dom
import Data.DOM.Node
import Data.DOM.Html2
import Data.DOM.Events
import Data.DOM.HTMLBodyElement
import Data.DOM.CSSStyleDeclaration
import Data.DOM.WindowObj
import Data.DOM.Window
import Data.DOM.Css
import Data.DOM.Document
import Data.DOM.HTMLDocument

instance JContainer THTMLBodyElement

-- | Run the code writer (raw way, returns both state and log). Container will be
-- initialized into the body of the current HTML document. Same as
-- @ 'runJSMWWith' 'currDocBody' @

runJSMW :: Int                                    -- ^ Initial state (usually 0)
        -> JSMW THTMLBodyElement (Expression a)   -- ^ The JSMW expression to process
        -> (Expression a, Int, [Statement ()])    -- ^ Result: (final expression, 
                                                  --   final state,
                                                  --   produced statements),

runJSMW st q = runJSMWWith currDocBody st q

-- | Body of the current document: use it to start the toplevel instance
-- of the Writer as a container for 'runJSMWWith'.

currDocBody :: Expression THTMLBodyElement

currDocBody = VarRef THTMLBodyElement (Id THTMLBodyElement "window.document.body")

-- | Type of a function creating HTML elements, e. g. 'mkButton', 'mkDiv'

type ECRF e n = Expression THTMLDocument -> JSMW e (Expression n)

-- | Insert a passive element into the current container. 

passive :: (CNode n, CElement e) 
        => ECRF e n                     -- ^ function that creates a HTML element
        -> JSMW e (Expression ())       -- ^ 'passive' does not return a value

passive crf = do
  cntr <- ask
  doc <- get'ownerDocument cntr
  e <- once =<< crf doc
  once =<< addChild e cntr
  return $ NullLit ()


-- | Nest an element inside another element via monadic composition.
-- Example usage: 
--
--  @'ask' >>= 'nest' 'mkButton' >>= 'nest' ('mkText' $ 'string' \"Foo\")@
--
-- inserts a button with text \"Foo\" into the current container.
--
-- The type system makes sure that only an instance of a DOM Element
-- can nest other elements, e. g. 
--
-- @ ... mkText (string \"Foo\") >>= nest mkDiv@
--
-- would not typecheck.
--
-- Example: a text, a newline, and two buttons: @'ask'@ retrieves the current
-- container.
--
-- @
-- q = do
--   passive (mkText $ string \"Hello\")
--   passive mkBr
--   ask >>= nest mkButton >>= nest (mkText $ string \"Foo\")
--   ask >>= nest mkButton >>= nest (mkText $ string \"Bar\")
-- @

nest :: (CNode n, CElement e, CElement p) 
     => ECRF e n                    -- ^ function that creates a HTML element to nest
     -> Expression p                -- ^ parent element (implicit if '>>=' is used)
     -> JSMW e (Expression n)       -- ^ nested element is returned (per 'addChild')

nest crf par = do
  doc <- once =<< get'ownerDocument par
  c <- once =<< crf doc
  once =<< addChild c par

-- | Specify a new container that in nested into the current one. As long as the container
-- is active, all subsequently defined elements will be inserted into it. 
--
-- Example: a Button with two text labels separated with a newline:
--
-- @
--   mkButton \`container\` (do
--     passive (mkText $ string \"Hello\") 
--     passive mkBr
--     passive (mkText $ string \"GoodBye\"))
-- @
--
-- Everything defined within a @do@ expression is inserted into the button
-- which is the new container.

container :: (JContainer n, CElement n, CElement e) 
          => ECRF e n                -- ^ function that creates a new container
          -> JSMW n (Expression x)   -- ^ whatever goes into that container
          -> JSMW e (Expression ())  -- ^ 'container' does not return a value

container crf cnt = do
  curc <- once =<< ask
  doc <- once =<< get'ownerDocument curc
  newc <- once =<< crf doc
  once =<< addChild newc curc
  carg <- mkNewVar
  st <- get
  let et = exprType newc
      (finx, fins, stms) = runJSMWWith (VarRef et (Id et carg)) st cnt
      blk = getBlock (finx, fins, stms)
      fun = ParenExpr () (FuncExpr () [Id () carg] blk)
      call = CallExpr () fun [newc /\ ()]
  writeStmt (ExprStmt () call)
  put fins
  return $ NullLit ()

-- $ref Sometimes it may be necessary to create an element, but \"engage\" it later.
-- Element references help achieve this. References also can be useful when 
-- several elements have to interact with each other: elements created
-- with 'nest' or 'container' are accessible only from the \"inside\" code.
-- To enable interaction, a reference to an element has to be made known
-- to another element's event handler.
--
-- A rather contrived example below shows how to create an input element, and insert it
-- into a button later.
--
-- @
-- import qualified Data.DOM.HTMLInputElement as I
-- ...
-- inp <- 'ref' 'I.mkInput' -- create a reference
-- inp \`inside\` ('setStyle' [\"border-color\" := \"green\"]) -- do something with the reference
-- ...
-- inpr <- 'ref2ecrf' inp -- simulate an element creation function
-- mkButton \`container\` (inpr \`container\` (ask >>= 'I.set'value' ('string' \"foo\")))
-- @

-- | Create an element for future use, and return a reference to it.
-- The element may be inserted into a container different from one it was
-- created with (when 'ref' was called). But it should be used within the same
-- document it was created inside.

ref :: (CNode e, CElement n) => ECRF e n -> JSMW e (Expression n)

ref crf = do
  cntr <- ask
  doc <- get'ownerDocument cntr
  e <- once =<< crf doc
  return e
  
-- | Turn an element reference into element creation function. It can be useful
-- when an element created earlier has to be used as a container, or a passive element,
-- or nested. The type signature of 'ref2ecrf' reflects the fact that the element
-- was created when one container was current, but may be used with another container.

ref2ecrf :: (CElement e1, CElement e2, CNode n) => Expression n -> JSMW e1 (ECRF e2 n)

ref2ecrf n = return $ \d -> return n

-- | Essentially same as 'container' except that a reference to an element
-- has to be supplied rather than an element creation function. Another
-- difference from 'container': element referenced is not added as a child to
-- the current container.

inside    :: (JContainer n, CElement n, CElement e) 
          => Expression n            -- ^ reference to an element              
          -> JSMW n (Expression x)   -- ^ whatever goes into that element
          -> JSMW e (Expression ())  -- ^ 'inside' does not return a value

inside    e cnt = do
  newc <- once =<< return e
  carg <- mkNewVar
  st <- get
  let et = exprType newc
      (finx, fins, stms) = runJSMWWith (VarRef et (Id et carg)) st cnt
      blk = getBlock (finx, fins, stms)
      fun = ParenExpr () (FuncExpr () [Id () carg] blk)
      call = CallExpr () fun [newc /\ ()]
  writeStmt (ExprStmt () call)
  put fins
  return $ NullLit ()


-- | Data type for building inline style assignment expressions.

data CSSDeco = String := String
 
-- | An action to use within a container to update its inline style.
-- 'setStyle' called with an empty list does not change the inline
-- style. Note that style settings are compile-time only.
--
-- Example: a DIV element with style settings applied and a text:
--
-- @
--   mkDiv \`container\` (do
--     setStyle [\"display\" := \"inline\"
--              ,\"float\" := \"right\"
--              ,\"width\" := \"45%\"
--              ,\"text-align\" := \"center\"
--              ,\"background-color\" := \"green\"
--              ,\"color\" := \"white\"
--              ,\"font-weight\" := \"bold\"]
--     passive (mkText $ string \"Styled\"))
-- @


setStyle :: (CHTMLElement e) => [CSSDeco] -> JSMW e (Expression ())

setStyle csp = do
  istd <- once =<< (ask >>= inlineStyleDecl)
  mapM (\(p := v) -> once =<< setProperty (string p) (string v) (string "") istd) csp 
  return $ NullLit ()

-- | A type for a on-style event handler. It represents a function which
-- takes an event and returns a boolean.

type OnHandler e c = Expression e -> JSMW c (Expression Bool)


-- | Set a on-style (e. g. onclick) event handler on the current container.
--
-- Example: a button with a click handler which shows the X coordinate of the click.
--
-- @
--  mkButton \`container\` (do
--    passive (mkText $ string \"Click Me\")
--    setHandler \"click\" clickHandler)
--  ...
--  clickHandler :: OnHandler TMouseEvent THTMLButtonElement
--  clickHandler e = do
--    getm'clientX e >>= toString >>= alert
--    return true
-- @
--
-- A handler function has one argument which gets the reference to the event caught.
-- The handler function also may implicitly address the container it was set on by
-- calling 'ask' or 'passive'. For example, calling @passive (mkText $ string \"x\")@
-- within a handler will result in a text node being added to the container.
--
-- Also note that the 'OnHandler' type may be parameterized by the type of containers
-- it can be set on. In the example above, the handler may only be set on buttons.
--
-- The MSIE-specific code to obtain event from the static attribute of the current
-- window is inserted in the beginning of the handler automatically.

setHandler :: (JContainer c, CHTMLElement c, CEvent e) 
            => String -> OnHandler e c -> JSMW c (Expression ())

setHandler s x = do
  ctr <- once =<< ask
  earg <- mkNewVar
  st <- get
  let et = undefined :: e
      prop = "on" ++ s
      evar = VarRef et (Id et earg)
      (finx, fins, stms) = runJSMWWith ctr st (x evar)
      msievent = IfSingleStmt () (PrefixExpr () PrefixLNot (evar /\ ()))
                   (BlockStmt () [ExprStmt () 
                                   (AssignExpr () OpAssign (evar /\ ()) 
                                                           (VarRef () (Id () "window.event")))])
      blk = getBlock (finx, fins, msievent : stms)
      fun = FuncExpr () [Id () earg] blk
      seth = ExprStmt () $ AssignExpr () OpAssign (DotRef () (ctr /\ ()) (Id () prop)) (fun /\ ())
  writeStmt seth
  put fins
  return (NullLit ())

-- | Same as 'appendChild', but with type signature reflecting that returned
-- value is the node added.

addChild :: (Monad m, CNode c, CNode p) => Expression c -> Expression p -> m (Expression c)

addChild = appendChild

-- |Obtain an inline style ('TCSSStyleDeclaration') interface of an object

inlineStyleDecl ::
          (Monad mn, CHTMLElement this) =>
            Expression this -> mn (Expression TCSSStyleDeclaration)
inlineStyleDecl thisp
  = do let et = undefined :: TCSSStyleDeclaration
       let r = DotRef et (thisp /\ et) (Id et "style")
       return r

-- | Access the @<BODY>@ node of the current HTML document. Same as 'get\'body', but with
-- proper type of the returned value.

documentBody ::  (Monad mn, CHTMLDocument this) => 
  Expression this -> mn (Expression THTMLBodyElement)

documentBody = get'body

-- | Access the @<HEAD>@ node of the current HTML document.

documentHead ::
          (Monad mn, CHTMLDocument this) =>
            Expression this -> mn (Expression THTMLHeadElement)
documentHead thisp
  = do let et = undefined :: THTMLHeadElement
       let r = DotRef et (thisp /\ et) (Id et "head")
       return r

-- |Obtain an inline style ('TCSS2Properties') interface of an object

inlineStyle ::
          (Monad mn, CHTMLElement this) =>
            Expression this -> mn (Expression TCSS2Properties)
inlineStyle thisp
  = do let et = undefined :: TCSS2Properties
       let r = DotRef et (thisp /\ et) (Id et "style")
       return r