packages feed

jsmw (empty) → 0.1

raw patch · 9 files changed

+945/−0 lines, 9 filesdep +DOMdep +WebBitsdep +basesetup-changed

Dependencies added: DOM, WebBits, base, mtl

Files

+ Data/DOM/JSMWExt.hs view
@@ -0,0 +1,54 @@+------------------------------------------------------------------+-- |+-- Module      :  Data.DOM.JSMWExt+-- Copyright   :  (c) Dmitry Golubovsky, 2009+-- License     :  BSD-style+-- +-- Maintainer  :  golubovsky@gmail.com+-- Stability   :  experimental+-- Portability :  portable+-- +--+--+-- DOM extensions specific to JSMW+------------------------------------------------------------------++module Data.DOM.JSMWExt (+  addChildren+ ,alert+ ,status +) where++import Data.DOM+import Data.DOM.Dom+import BrownPLT.JavaScript+import Language.JSMW.Monad++-- | 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 (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 (Expression ())++alert s = do+  vs <- once =<< return s+  once =<< return (CallExpr () (VarRef () (Id () "alert")) [vs /\ ()])++-- | Update window status line.++status :: Expression String -> JSMW e (Expression ())++status s = do+  vs <- once =<< return s+  writeStmt $ ExprStmt () $ AssignExpr () OpAssign (VarRef () (Id () "window.status")) (vs /\ ())+  return $ NullLit ()++
+ Data/JSRef.hs view
@@ -0,0 +1,54 @@+------------------------------------------------------------------+-- |+-- Module      :  Data.JSRef+-- Copyright   :  (c) Dmitry Golubovsky, 2009+-- License     :  BSD-style+-- +-- Maintainer  :  golubovsky@gmail.com+-- Stability   :  experimental+-- Portability :  portable+-- +--+--+-- Mutable Javascript reference objects+------------------------------------------------------------------++module Data.JSRef (+  JSRef+ ,newJSRef+ ,readJSRef+ ,writeJSRef+) where++import Language.JSMW.Monad+import Data.DOM+import BrownPLT.JavaScript++-- | An opaque data type parameterized by the type of the stored value.++data JSRef a = JSRef a++-- | Create a mutable Javascript reference object and initialize it.++newJSRef :: Expression a -> JSMW e (Expression (JSRef a))++newJSRef x = do+  let et = JSRef (exprType x)+      obj = ObjectLit et [(PropId et (Id et "_val"), x /\ et)]+  return obj >>= once++-- | Store a value in a mutable Javascript reference object.++writeJSRef :: Expression (JSRef a) -> Expression a -> JSMW e (Expression (JSRef a))++writeJSRef r v = once =<< setjsProperty "_val" v r++-- | Retrieve a value from a mutable Javascript reference object.++readJSRef :: Expression (JSRef a) -> JSMW e (Expression a)++readJSRef r = do+  let et = undefined :: a+      v = DotRef et (r /\ et) (Id et "_val")+  return v+
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Dmitry Golubovsky 2008.+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Dmitry Golubovsky nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Language/JSMW.hs view
@@ -0,0 +1,29 @@+------------------------------------------------------------------+-- |+-- Module      :  Language.JSMW+-- Copyright   :  (c) Dmitry Golubovsky, 2009+-- License     :  BSD-style+-- +-- Maintainer  :  golubovsky@gmail.com+-- Stability   :  experimental+-- Portability :  portable+-- +--+--+-- Re-export commonly used modules.+------------------------------------------------------------------++module Language.JSMW (+  module Language.JSMW.Monad+ ,module Language.JSMW.Cond+ ,module Language.JSMW.Arith+ ,module Data.JSRef+ ,module Data.DOM.JSMWExt+) where++import Language.JSMW.Monad+import Language.JSMW.Cond+import Language.JSMW.Arith+import Data.JSRef+import Data.DOM.JSMWExt+
+ Language/JSMW/Arith.hs view
@@ -0,0 +1,151 @@+------------------------------------------------------------------+-- |+-- Module      :  Language.JSMW.Arith+-- Copyright   :  (c) Dmitry Golubovsky, 2009+-- License     :  BSD-style+-- +-- Maintainer  :  golubovsky@gmail.com+-- Stability   :  experimental+-- Portability :  portable+-- +--+--+-- Encoding of Javascript arithmetic and mathematic operations.+------------------------------------------------------------------++module Language.JSMW.Arith (+ -- * Arithmetic operators+ -- $arith+ -- $comp+  lt, le, gt, ge, eq, ne, (===), (=/=),+ -- * Logical operators+ -- $logic+  land, lor+ -- * Tests for being a number+ ,isNAN+ -- * Primitive conversions+ ,toString+ ,parseInt+ ,parseFloat) where++import BrownPLT.JavaScript+import Data.DOM+import Language.JSMW.Monad++-- $arith Instance of the 'Num' class can be defined for Javascript expressions+-- provided that their type annotation also belongs to the 'Num' class. Therefore+-- it is possible to overload the '+', '-', etc. operators so that using them+-- in JSMW code would result in correct Javascript code:+--+-- @'number' 5 - ('number' 1 - 'number' 4)@ +--+-- results in+--+-- @(5.0 - (1.0 - 4.0))@.+--+-- Also, addition is defined for String expressions, so this is possible:+--+-- @'alert' (g + 'string' \" Greater than 3\")@+--+-- Unlike the methods of the 'Num' class, comparison operators (members of the 'Ord'+-- class) cannot be overloaded in suitable manner. For Javascript expressions,+-- the following infix operators are provided, with the same fixity as the corresponding+-- Haskell operators.++arithBin op x y = let et = exprType x in ParenExpr et (InfixExpr et op x y)++arithPfx op x = let et = exprType x in ParenExpr et (PrefixExpr et op x)++arithFun fn x = let et = exprType x in ParenExpr et (CallExpr et (VarRef et $ Id et fn) [x])++boolBin op x y = (arithBin op x y) /\ (undefined :: Bool)++instance Num (Expression Double) where+  (+) = arithBin OpAdd+  (-) = arithBin OpSub+  (*) = arithBin OpMul+  negate = arithPfx PrefixMinus+  abs = arithFun "Math.abs"+  signum = arithFun "(function(x){return (x<0)?(-1):(x>0)?1:0})"+  fromInteger n = NumLit (undefined :: a) (fromIntegral n)++instance Num (Expression String) where+  (+) = arithBin OpAdd+  (*) x y = error "(*) undefined on strings"+  abs x = error "abs undefined on strings"+  signum x = error "signum undefined on strings"+  fromInteger = string . show++instance Fractional (Expression Double) where+  (/) = arithBin OpDiv+  fromRational n = NumLit (undefined :: a) (fromRational n)++lt :: Expression a -> Expression a -> Expression Bool+le :: Expression a -> Expression a -> Expression Bool+gt :: Expression a -> Expression a -> Expression Bool+ge :: Expression a -> Expression a -> Expression Bool+eq :: Expression a -> Expression a -> Expression Bool+ne :: Expression a -> Expression a -> Expression Bool+(===) :: Expression a -> Expression a -> Expression Bool+(=/=) :: Expression a -> Expression a -> Expression Bool++lt = boolBin OpLT+le = boolBin OpLEq+gt = boolBin OpGT+ge = boolBin OpGEq+eq = boolBin OpEq+ne = boolBin OpNEq++(===) = boolBin OpStrictEq+(=/=) = boolBin OpStrictNEq++infix 4 `lt`, `le`, `gt`, `ge`, `eq`, `ne`, ===, =/=++-- $logic Similarly, logical operators for Javascript expressions are provided.++land :: Expression Bool -> Expression Bool -> Expression Bool+lor  :: Expression Bool -> Expression Bool -> Expression Bool++land = arithBin OpLAnd+lor = arithBin OpLOr++infixr 3 `land`+infixr 2 `lor`++-- | Test if a given value is a number.++isNAN :: Expression Double -> JSMW e (Expression Bool)++isNAN n = do+  let dt = undefined :: Bool+  nx <- once =<< return n+  once =<< return (CallExpr dt (VarRef dt (Id dt "isNaN")) [nx /\ dt])++-- | Obtain a string representation of an arbitrary Javascript expression.++toString :: Expression a -> JSMW e (Expression String)++toString x = do+  vx <- once =<< return x+  once =<< return (CallExpr "" (DotRef "" (vx /\ "") (Id "" "toString")) [])++-- | Parse an integer.++parseInt :: Expression String -> Expression Double -> JSMW e (Expression Double)++parseInt s r = do+  let dt = undefined :: Double+  str <- once =<< return s+  rdx <- once =<< return r+  once =<< return (CallExpr dt (VarRef dt (Id dt "parseInt")) [str /\ dt, rdx /\ dt])++-- | Parse a floating point number.++parseFloat :: Expression String -> JSMW e (Expression Double)++parseFloat s = do+  let dt = undefined :: Double+  str <- once =<< return s+  once =<< return (CallExpr dt (VarRef dt (Id dt "parseFloat")) [str /\ dt])++
+ Language/JSMW/Cond.hs view
@@ -0,0 +1,134 @@+------------------------------------------------------------------+-- |+-- 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)]+
+ Language/JSMW/Monad.hs view
@@ -0,0 +1,402 @@+------------------------------------------------------------------+-- |+-- 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++
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ jsmw.cabal view
@@ -0,0 +1,89 @@+Cabal-Version:      >= 1.2+Name:               jsmw+Version:            0.1+Copyright:          2009, Dmitry Golubovsky+Maintainer:         golubovsky@gmail.com+License:            BSD3+License-File:       LICENSE+Build-Type:         Simple+Author:             Dmitry Golubovsky+Synopsis:           Javascript Monadic Writer base package.+Description:+    An EDSL inspired in part by HJ(ava)Script and HSP aimed at coding in typed+    Javascript. It uses WebBits as the underlying representation of Javascript.+    .+    This package provides the basic API sufficient to create simple dynamic web pages.+    .+    Below is a simple example of a program that increments or decrements a value+    in an input field depending on whether /Enter/ or /Shift-Enter/ was pressed.+    .+    Save this program in a file, and run @runghc@ on the file. Javascript will be output+    to be placed into HEAD element of a blank HTML page. Give the page body attribute:+    .+    > <body onload="javascript:main()">+    .+    to run the script when the page loads.+    .+    A live example of this program is available here:+    .+    <http://code.haskell.org/yc2js/examples/ex1.html>+    .+    > module Main where+    > +    > import Prelude hiding (putStrLn)+    > import System.IO.UTF8+    > import BrownPLT.JavaScript+    > import BrownPLT.JavaScript.PrettyPrint+    > import Control.Monad+    > import Language.JSMW+    > import Data.DOM+    > import Data.DOM.Dom+    > import Data.DOM.Html2+    > import Data.DOM.Events+    > import Data.DOM.KeyEvent+    > import Data.DOM.HTMLHRElement+    > import Data.DOM.HTMLInputElement+    > +    > main = putStrLn $ show $ stmt $ +    >   FunctionStmt undefined (Id undefined "main") [] (getBlock ( runJSMW 0 q))+    > +    > +    > q = do+    >   passive (mkText $ string +    >     "Example 1: Press Enter to increase value, Shift-Enter to decrease value")+    >   passive mkHr+    >   mkInput `container` (do +    >     setHandler "keypress" plusOne+    >     ask >>= set'value (string "0") >>= focus)+    > +    > plusOne :: OnHandler TKeyEvent THTMLInputElement+    > +    > plusOne e = do+    >   c <- getm'keyCode e+    >   switch (c) $ do+    >     cDOM_VK_ENTER --> do i <- ask +    >                          v <- getm'value i+    >                          vv <- switch v $ do+    >                            "" --> stringM "0"+    >                            none (return v)+    >                          n <- parseInt vv 0+    >                          shft <- get'shiftKey e+    >                          n2 <- switch shft $ do+    >                            True --> return (n - number 1)+    >                            False --> return (n + number 1)+    >                          once =<< (toString n2 >>= flip set'value i)+    >                          return false+    >     none (return true)+    > ++Category:           Language++Library+    build-depends: base >= 4.0.0, mtl, WebBits == 0.15, DOM == 2.0.1+    Extensions: FlexibleInstances, TypeSynonymInstances, MultiParamTypeClasses, +                FunctionalDependencies, CPP+    Exposed-modules:+        Language.JSMW, Language.JSMW.Monad, Language.JSMW.Arith, +        Language.JSMW.Cond, Data.DOM.JSMWExt, Data.JSRef++