-- A helper module to provide useful functions to work with DOM. It cannot be
-- cabalized with JSMW because it depends on dynamically-generated (from IDL files)
-- code.
-- Minimal set of IDL modules to be compiled: dom, html2 (or html5), css, cssomview.

module DOMHelper where

import Control.Monad.RWS
import Language.JSMW
import BrownPLT.JavaScript.Syntax
import Foreign.WebIDL.Dom.Node
import Foreign.WebIDL.Dom.Document
import Foreign.WebIDL.Dom.Element
import Foreign.WebIDL.Dom.Text
import Foreign.WebIDL.Html2.HTMLBodyElement
import Foreign.WebIDL.Html2.HTMLDocument
import Foreign.WebIDL.Html2.HTMLElement
import Foreign.WebIDL.Html2.HTMLHeadElement
import Foreign.WebIDL.Events.Event
import Foreign.WebIDL.Css.CSSStyleDeclaration
import Foreign.WebIDL.Css.CSS2Properties
import Foreign.WebIDL.Views.ElementView
import Foreign.WebIDL.Views.ClientRect

instance JContainer THTMLBodyElement

-- Element creation function type.

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

-- Type for an event handler.

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

-- Body of the current document to use as a toplevel container.

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

-- Insert a passive element into a current container

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

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

-- Specify a new container, nested into the current one.

container :: (JContainer n, CElement n, JContainer e, CElement e)
          => ECRF e n s
          -> JSMW n x (Expression y)
          -> JSMW e s (Expression n)

container crf cnt = do
  let st = undefined :: s
  curc <- once =<< ask
  doc <- once =<< get'ownerDocument curc
  newc <- once =<< crf doc
  once =<< return . asNode =<< addChild (newc /\ st) curc
  carg <- mkNewVar
  blk <- nestBlock newc cnt 
  let fun = ParenExpr st (FuncExpr st [Id st carg] (blk /\ st))
      call = CallExpr st fun [newc /\ st]
  writeStmt (ExprStmt st call)
  return newc

-- Install an event handler on an element.

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

setHandler ss x = do
  ctr <- once =<< ask
  earg <- mkNewVar
  let st = undefined :: s
      prop = "on" ++ ss
      evar = VarRef st (Id st earg)
      msievent = IfSingleStmt st (PrefixExpr st PrefixLNot evar)
                   (evar `assign` (VarRef st (Id st "window.event")))
  (BlockStmt bt sts) <- nestBlock ctr (x evar /\ st)
  let blk' = BlockStmt bt ((msievent /\ bt): sts)
      fun = FuncExpr st [Id st earg] blk'
  writeStmt $ (DotRef st (ctr /\ st) (Id st prop)) `assign` fun
  return (NullLit ())

-- Create a text node (short-cut for createTextNode)

mkText :: (Monad mn, CDocument this) => 
   Expression String -> Expression this -> mn (Expression TText)
mkText = createTextNode

-- Insert a child element into a node (short-cut for appendChild)

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

-- | Add multiple children to a node. Unlike 'addChild', this function
-- returns the parent element.

addChildren :: (CNode p, CNode c) => [Expression c] -> Expression p -> JSMW e s (Expression p)

addChildren [] p = once =<< return p
addChildren (c:cs) p = do
  once =<< addChild c p
  addChildren cs p

-- | Pop up an alert window.

alert :: Expression String -> JSMW e s (Expression ())

alert s = do
  vs <- once =<< return s
  once =<< return (CallExpr () (VarRef () (Id () "alert")) [vs /\ ()])

-- | 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 s                  -- ^ function that creates a HTML element to nest
     -> Expression p                -- ^ parent element (implicit if '>>=' is used)
     -> JSMW e s (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

-- $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 s -> JSMW e s (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 s (ECRF e2 n s2)

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, JContainer e, CElement n) 
          => Expression n             -- ^ reference to an element              
          -> JSMW n s (Expression x)  -- ^ whatever goes into that element
          -> JSMW e s (Expression ()) -- ^ 'inside' returns nothing

inside    e cnt = do
  newc <- once =<< return e
  carg <- mkNewVar
  let et = exprType e
  blk <- nestBlock (VarRef et (Id et carg)) cnt
  let st = undefined :: s
      fun = ParenExpr st (FuncExpr st [Id st carg] (blk /\ st))
      call = CallExpr st fun [newc /\ st]
  writeStmt (ExprStmt st call)
  return unit


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

infixr 0 :=

data CSSDeco = String := Expression 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 s (Expression ())

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

-- |Run a list of setters on the current container making sure that the code will be used.

runSetters :: (JContainer e)
           => [Expression e -> JSMW e s (Expression a)]
           -> JSMW e s (Expression ())

runSetters xs = mapM_ (\x -> ask >>= x >>= once) xs >> return unit

-- |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

-- |Obtain an ElementView interface of an object. This is possible because
-- ElementView is implemented on Element.

elementView :: (Monad mn, CElement this) =>
                 Expression this -> mn (Expression TElementView)

elementView thisp = return (thisp /\ TElementView)

-- |Obtain a bounding rectangle of an element by its \'id\' attribute.

getRectById :: (CDocument this, JContainer e) 
            => Expression String
            -> Expression this
            -> JSMW e s (Expression TClientRect)

getRectById s d = do
  e <- getElementById s d >>= return . asElement >>= once
  switch (isNull e) $ do
    True --> return (NullLit TClientRect)
    False --> getRect e

-- |Obtain a bounding rectangle of an element.

getRect :: (CElement this) 
        => Expression this
        -> JSMW e s (Expression TClientRect)

getRect e = elementView e >>= 
            getBoundingClientRect >>=
            return . asClientRect >>= 
            once