Cond.hs

------------------------------------------------------------------
-- |
-- Module      :  Language.JSMW.Cond
-- Copyright   :  (c) Dmitry Golubovsky, 2009
-- License     :  BSD-style
-- 
-- Maintainer  :  golubovsky@gmail.com
-- Stability   :  experimental
-- Portability :  portable
-- 
--
--
-- Encoding of Javascript conditionals.
------------------------------------------------------------------

module Language.JSMW.Cond (
-- * Switch
-- $switch
  switch
 ,(-->)
 ,none
  ) where

import Control.Monad
import Control.Monad.RWS
import Control.Monad.Writer
import BrownPLT.JavaScript
import BrownPLT.JavaScript.PrettyPrint
import Data.DOM
import Data.DOM.Dom
import Language.JSMW.Monad

#ifdef __HADDOCK__

import Data.DOM.JSMWExt
import Language.JSMW.Arith

#endif

class Switchable a b where
  toSwitch :: a -> Expression b

instance (Integral a) => Switchable a Double where
  toSwitch = number

instance Switchable Bool Bool where
  toSwitch = bool

instance Switchable String String where
  toSwitch = string

-- Switch with labels of type s, scrutinee of type r, defined on container c,
-- with case branches returning expressions of type e.

type Switch s r c e a = Writer [(s, Maybe (Expression r), JSMW c (Expression e))] a

-- $switch The following functions help encode the Javascript @switch@ and @case@ statements.
-- The @Switchable@ class seen in the type signatures, and its necessary instances are 
-- defined internally by this module. The @switch@ statement can be encoded for numeric,
-- boolean, and string scrutinees.
--
-- Unlike Javascript @switch@, a value can be returned from JSMW 'switch' (see
-- the second example). All expressions matching case labels must return values of the same
-- type.
--
-- Below are examples of @switch@ statements encoded in JSMW.
--
-- @
--  let p = 'number' 5 - ('number' 1 - 'number' 4)
--  'switch' p $ do
--    5 '-->' 'alert' ('string' \"This is Five\")
--    8 '-->' 'alert' ('string' \"This is Eight\")
--    'none' $ 'toString' p >>= 'alert'  
--  ...
--  n2 <- 'switch' ctrl $ do
--    True '-->' return (n - 'number' 1)
--    False '-->' return (n + 'number' 1)
-- @



-- | Encode a @switch@ statement.

switch :: (Switchable s r, CElement c) 
       => Expression r -> Switch s r c e a -> JSMW c (Expression e)

switch scrut sw = do
  sv <- once =<< return scrut
  let ccst = execWriter sw
      rt = undefined :: e
  ccs <- mapM (\(_, cex, cjsmw) -> do
    st <- get
    curc <- once =<< ask
    let (finx, fins, stms) = runJSMWWith curc st cjsmw
        blk = getBlock (finx, fins, stms)
        bstms = unBlock blk
        unBlock (BlockStmt a bss) = bss
        unBlock s = [s]
    put fins
    let constr = case cex of
                   Just cex -> CaseClause rt (cex /\ rt)
                   Nothing -> CaseDefault rt
    return (constr bstms)) ccst
  let swstmt = BlockStmt rt [SwitchStmt rt (sv /\ rt) ccs
                           , ThrowStmt rt (StringLit rt nmmsg)]
      nmmsg = "No match in switch statement, scrutinee: " ++ show (expr scrut)
      fun = FuncExpr rt [] swstmt
  fv <- mkNewVar
  writeStmt (ExprStmt () (AssignExpr () OpAssign (VarRef () (Id () fv)) (fun /\ ())))
  once =<< return (CallExpr rt (VarRef rt (Id rt fv)) [])

-- | Encode a case label. The first (left) argument is a literal describing
-- the value of the label. Note that the left argument must be a Haskell
-- literal, not a Javascript expression. In other words, for boolean labels,
-- use 'True' rather than 'true'. The second (right) argument is a JSMW monadic
-- expression matching the label. @Break@ statements are inserted automatically
-- (that is, fall-through case labels are not permitted).

(-->) :: (Switchable s r, CElement c) => s -> JSMW c (Expression e) -> Switch s r c e ()

x --> y = tell [(x, Just $ toSwitch x, y)]

-- | Encode a @default:@ case label, that is, what action should be taken if none
-- of the case labels matches the scrutinee.
--
-- In both 'none' and '-->', JSMW monadic expression should be of the same type.
-- Also note that if no case label matches the scrutinee value, and no default
-- label has been defined, an exception will be thrown showing the scrutinee
-- name that did not match.

none :: (Switchable s r, CElement c) => JSMW c (Expression e) -> Switch s r c e ()

none y = tell [(undefined, Nothing, y)]