diff --git a/Data/DOM/JSMWExt.hs b/Data/DOM/JSMWExt.hs new file mode 100644 --- /dev/null +++ b/Data/DOM/JSMWExt.hs @@ -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 () + + diff --git a/Data/JSRef.hs b/Data/JSRef.hs new file mode 100644 --- /dev/null +++ b/Data/JSRef.hs @@ -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 + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Language/JSMW.hs b/Language/JSMW.hs new file mode 100644 --- /dev/null +++ b/Language/JSMW.hs @@ -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 + diff --git a/Language/JSMW/Arith.hs b/Language/JSMW/Arith.hs new file mode 100644 --- /dev/null +++ b/Language/JSMW/Arith.hs @@ -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]) + + diff --git a/Language/JSMW/Cond.hs b/Language/JSMW/Cond.hs new file mode 100644 --- /dev/null +++ b/Language/JSMW/Cond.hs @@ -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)] + diff --git a/Language/JSMW/Monad.hs b/Language/JSMW/Monad.hs new file mode 100644 --- /dev/null +++ b/Language/JSMW/Monad.hs @@ -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 + + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/jsmw.cabal b/jsmw.cabal new file mode 100644 --- /dev/null +++ b/jsmw.cabal @@ -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: + . + > + . + to run the script when the page loads. + . + A live example of this program is available here: + . + + . + > 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 + +