Monad.hs

------------------------------------------------------------------
-- |
-- Module      :  Language.JSMW.Monad
-- Copyright   :  (c) Dmitry Golubovsky, 2009
-- License     :  BSD-style
-- 
-- Maintainer  :  golubovsky@gmail.com
-- Stability   :  experimental
-- Portability :  portable
-- 
--
--
-- A special monad: the core of the Writer.
------------------------------------------------------------------

module Language.JSMW.Monad (
 -- * The Monad itself
  JSMW 
 ,runJSMW
 ,runJSMWWith
 ,getBlock
 ,currDocBody
 -- * Compilation control
 ,once
 ,mkNewVar
 ,writeStmt
 -- * Create Javascript values, Monadic versions
 ,stringM
 ,numberM
 ,boolM
 -- * Layout control
 ,ECRF
 ,passive
 ,nest
 ,container
 -- * Element references
 -- $ref
 ,ref
 ,ref2ecrf
 ,inside
 -- * Inline style and other decorations
 ,CSSDeco (..)
 ,setStyle
 -- * Event handling
 ,OnHandler
 ,setHandler
 ,ask
  )where

import Control.Monad
import Control.Monad.State
import Control.Monad.RWS
import BrownPLT.JavaScript
import Data.DOM
import Data.DOM.Dom
import Data.DOM.Node
import Data.DOM.Html2
import Data.DOM.Events
import Data.DOM.HTMLBodyElement
import Data.DOM.CSSStyleDeclaration

-- | A type of the writer: based on the 'RWS' Monad. The Reader part holds an expression
-- to reference the curent HTML container element. The Writer part is the list of Javascript
-- statements being formed. Container may be any DOM Element, but not a Text node 
-- or anything else.

type JSMW e a = RWS (Expression e) [Statement ()] Int a

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

-- | Run the code writer (raw way, returns both state and log) with explicitly
-- specified container.

runJSMWWith :: (CElement e)
            => (Expression e)                         -- ^ container
            -> Int                                    -- ^ Initial state (usually 0)
            -> JSMW e (Expression a)                  -- ^ The JSMW expression to process
            -> (Expression a, Int, [Statement ()])    -- ^ Result: (final expression, 
                                                      --   final state,
                                                      --   produced statements),
runJSMWWith e st q = runRWS q e st

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

-- | Obtain a block statement from the result of 'runJSWM'. The last expression
-- forms a \'return\' statement, so the resulting block may be used as a function\'s body.

getBlock :: (Expression a, Int, [Statement ()]) -> Statement ()

getBlock (fin, _, stmts) = BlockStmt () (stmts ++ [ReturnStmt () (Just (fin /\ ()))])

-- | 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 :: (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    :: (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 :: (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 ())

-- | Create a unique variable name. This function increments the internal state of the
-- monad and produces a string consisting of the letter \'v\' and a unique number.

mkNewVar :: JSMW e String

mkNewVar = do
  modify (+ 1)
  n <- get
  return ('v' : show n)
  
-- | Write out a statement. This function utilizes the Writer part of the monad, and
-- adds the Javascript statement provided to the Writer's log.

writeStmt :: Statement () -> JSMW e ()

writeStmt = tell . (: [])


-- | The JSMW code consists of monadic smart constructors forming Javascript
-- method calls. These constructors are inlined each time they are referenced.
-- The "once" combinator causes a variable assignment statement to be formed
-- with the variable assigned to the expression returned. All future references
-- will be to the variable rather than to the expression. Since the expression
-- will be evaluated when assigned to the variable, referencing the variable
-- will reference the result, and possible effect will not be repeated.

once :: Expression a -> JSMW e (Expression a)

once e@(VarRef _ _) = return e

once e = do
  nv <- mkNewVar
  let et = exprType e
      eo = e /\ ()
      stm = VarDeclStmt () [VarDecl () (Id () nv) (Just eo)]
      vr = VarRef et (Id et nv)
  writeStmt stm
  return vr

-- | Create a Javascript string literal out of a string, monadic version.

stringM :: String -> JSMW e (Expression String)

stringM s = once =<< (return $ string s)

-- | Create a Javascript numeric literal out of a numeric value, monadic version.

numberM :: (Integral n) => n -> JSMW e (Expression Double)

numberM = return . number

-- | Create a Javascript boolean literal out of a Boolean, monadic version.

boolM :: Bool -> JSMW e (Expression Bool)

boolM = return . bool