HJScript-0.6.1/0000755000000000000000000000000011745460125011377 5ustar0000000000000000HJScript-0.6.1/LICENSE0000644000000000000000000000261611745460125012411 0ustar0000000000000000All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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. HJScript-0.6.1/Setup.hs0000644000000000000000000000005611745460125013034 0ustar0000000000000000import Distribution.Simple main = defaultMain HJScript-0.6.1/HJScript.cabal0000644000000000000000000000527511745460125014062 0ustar0000000000000000Name: HJScript Version: 0.6.1 License: BSD3 License-File: LICENSE Author: Joel Bjornson, Niklas Broberg Maintainer: Joel Bjornson , Niklas Broberg Synopsis: HJScript is a Haskell EDSL for writing JavaScript programs. Description: HJScript is a DSL built on top of HJavaScript, for writing client-side dynamic web pages. The programming model is fairly low-level, resembling the actual JavaScript code quite a lot, but should be easy to extend with higher-level functionality. Notable is that HJScript supports the use of literal XML syntax, as defined by the hsx package, for creating DOM ElementNodes. Also notable is that HJScript supports Ajax functionality. Homepage: http://patch-tag.com/r/nibro/hjscript Build-Type: Simple Category: Web, Language Cabal-Version: >= 1.6 source-repository head type: darcs location: http://patch-tag.com/r/nibro/hsx Library Hs-Source-Dirs: src Exposed-Modules: HJScript, HJScript.Lang, HJScript.Objects.Array HJScript.Objects.Boolean HJScript.Objects.JQuery HJScript.Objects.Date HJScript.Objects.Math HJScript.Objects.Object HJScript.Objects.RegExp HJScript.Objects.String HJScript.Objects.ActiveXObject HJScript.Objects.XMLHttpRequest HJScript.DOM, HJScript.DOM.NodeTypes HJScript.DOM.Node HJScript.DOM.ElementNode HJScript.DOM.AttributeNode HJScript.DOM.TextNode HJScript.DOM.NamedNodeMap HJScript.DOM.Window HJScript.DOM.Document HJScript.DOM.XHTML HJScript.XMLGenerator HJScript.Events HJScript.Ajax HJScript.Utils Other-Modules: HJScript.Monad Build-Depends: base < 5, HJavaScript >= 0.4.6, mtl, hsx >= 0.10.2 && < 0.11 Extensions: MultiParamTypeClasses, GADTs, TypeFamilies, FlexibleContexts, FlexibleInstances, TypeSynonymInstances, OverlappingInstances, UndecidableInstances HJScript-0.6.1/src/0000755000000000000000000000000011745460125012166 5ustar0000000000000000HJScript-0.6.1/src/HJScript.hs0000644000000000000000000000221511745460125014210 0ustar0000000000000000{-# LANGUAGE OverlappingInstances, UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : HJScript -- License : BSD-style -- Maintainer : Joel Bjornson joel.bjornson@gmail.com -- Niklas Broberg nibro@cs.chalmers.se -- Stability : experimental ----------------------------------------------------------------------------- module HJScript ( module HJScript.Monad, module HJScript.Lang, module HJScript.XMLGenerator, module HJScript.Events, module HJScript.Ajax, module HJScript.Objects.Array, module HJScript.Objects.Boolean, module HJScript.Objects.Date, module HJScript.Objects.Math, module HJScript.Objects.Object, module HJScript.Objects.RegExp, module HJScript.Objects.String ) where import HJScript.Monad import HJScript.Lang import HJScript.XMLGenerator import HJScript.Events import HJScript.Ajax import HJScript.Objects.Array import HJScript.Objects.Boolean import HJScript.Objects.Date import HJScript.Objects.Math import HJScript.Objects.Object import HJScript.Objects.RegExp import HJScript.Objects.String HJScript-0.6.1/src/HJScript/0000755000000000000000000000000011745460125013654 5ustar0000000000000000HJScript-0.6.1/src/HJScript/XMLGenerator.hs0000644000000000000000000000644111745460125016524 0ustar0000000000000000{-# LANGUAGE OverlappingInstances, UndecidableInstances #-} module HJScript.XMLGenerator ( -- ToChildNodes(..), ToAttributeNode(..), genElement, genEElement, asChild, asAttr, Attr(..) ) where --import qualified HSX.XMLGenerator as HSX (XMLGen(..)) import HSX.XMLGenerator import HJScript.Monad import HJScript.Lang import HJScript.DOM.Node import HJScript.DOM.AttributeNode import HJScript.DOM.ElementNode import HJScript.DOM.TextNode import HJScript.DOM.Document type XML = Exp ElementNode type Child = Exp Node type Attribute = Exp AttributeNode instance XMLGen HJScript' where type XMLType HJScript' = XML newtype ChildType HJScript' = HJSChild Child newtype AttributeType HJScript' = HJSAttr Attribute genElement = element genEElement = eElement xmlToChild = HJSChild . castToNode pcdataToChild str = HJSChild . castToNode $ document # createTextNode (string str) element :: (EmbedAsChild HJScript' c, EmbedAsAttr HJScript' a) => Name -> [a] -> [c] -> HJScript XML element (ns, ln) atts xmls = do let name = (maybe id (\x y -> y ++ ':':x) ns) ln elem <- fmap val $ varWith $ document # createElement (string name) cxml <- fmap concat $ mapM asChild xmls ats <- fmap concat $ mapM asAttr atts mapM (\attr -> elem # setAttributeNode attr) $ map stripAttr ats mapM (\child -> elem # appendChild child) $ map stripChild cxml return elem eElement :: EmbedAsAttr HJScript' a => Name -> [a] -> HJScript XML eElement n attrs = element n attrs ([] :: [Child]) instance XMLGenerator HJScript' -------------------------------------------- -- EmbedAsChild and EmbedAsAttr instance EmbedAsChild HJScript' Child where asChild = asChild . HJSChild instance EmbedAsChild HJScript' JString where asChild jstr = asChild $ castToNode $ document # createTextNode jstr --instance EmbedAsChild HJScript' String where -- asChild = asChild . string instance EmbedAsChild HJScript' Char where asChild = asChild . (:[]) -- This instance should already be there, probably doesn't work due -- to type families not being fully supported yet. instance EmbedAsChild HJScript' XML where asChild = return . return . xmlToChild instance EmbedAsAttr HJScript' Attribute where asAttr = asAttr . HJSAttr instance (IsName n, IsAttrNodeValue a) => EmbedAsAttr HJScript' (Attr n a) where asAttr (k := a) = asAttr $ do let (ns, ln) = toName k name = (maybe id (\x y -> y ++ ':':x) ns) ln v <- toAttrNodeValue a an <- inVar $ document # createAttribute (string name) an # value .=. v return an class IsAttrNodeValue a where toAttrNodeValue :: a -> HJScript JString instance JShow a => IsAttrNodeValue a where toAttrNodeValue = return . jshow instance IsAttrNodeValue a => IsAttrNodeValue (HJScript a) where toAttrNodeValue = (>>= toAttrNodeValue) ----------------------------------- -- SetAttr and AppendChild. instance SetAttr HJScript' XML where setAll en ats = do ev <- inVar en as <- ats mapM (\attr -> ev # setAttributeNode attr) (map stripAttr as) return ev instance AppendChild HJScript' XML where appAll en cns = do ev <- inVar en cs <- cns mapM (\child -> ev # appendChild child) (map stripChild cs) return ev stripAttr (HJSAttr a) = a stripChild (HJSChild c) = c HJScript-0.6.1/src/HJScript/Utils.hs0000644000000000000000000001565511745460125015324 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : HJScript.Utils -- License : BSD-style -- Maintainer : Joel Bjornson joel.bjornson@gmail.com -- Niklas Broberg nibro@cs.chalmers.se -- Stability : experimental ----------------------------------------------------------------------------- module HJScript.Utils ( -- Elements and properties dispNone, dispBlock,dispInline, thisElem, thisXHTMLElement, thisNode, -- Predicates hasClass, hasChild, isVisible, isInVisible, -- Pures methods for accessing elements and values. elemById, elemsByTag, fstElemByTag, allElems, parentElem, elemVal, -- HJScript monadic methods for accessing elements and changing properties. msg, getElemById, getElemsByTag, getFstElemByTag, getAllElems, getParentElem, getElemsByClass, getFstElemByClass, getSiblings, hideElem , showElem, showInline, showBlock , remFirstChild, remChildren, remElem, appendChildren, setChild, toggleVis, toggleVisBlock, toggleVisInline, setVal ) where import HJScript.Lang import HJScript.Objects.Array import HJScript.DOM -- Display properties dispNone :: JString dispNone = string "none" dispBlock :: JString dispBlock = string "block" dispInline :: JString dispInline = string "inline" thisElem :: Exp ElementNode thisElem = JThis thisXHTMLElement :: Exp ElementNode thisXHTMLElement = JThis thisNode :: Exp Node thisNode = JThis -------------------------------------------------------------------------------- -- Properties -------------------------------------------------------------------------------- hasClass :: (IsJString e) => e -> Exp ElementNode-> JBool hasClass name elem = (val $ elem' # className) .==. (toJString name) where elem' = asXHTMLElement elem hasChild :: IsElementNode e => Exp e -> JBool hasChild elem = elem # firstChild .!=. jnull isVisible :: IsElementNode n => Exp n -> JBool isVisible elem = (val $ elem # style # display) .!=. dispNone isInVisible :: IsElementNode n => Exp n -> JBool isInVisible elem = (val $ elem # style # display) .==. dispNone -------------------------------------------------------------------------------- -- Pure functions -------------------------------------------------------------------------------- elemById :: IsJString e => e -> Exp ElementNode elemById id = document # getElementById (toJString id) elemsByTag :: IsJString e => e -> JArray ElementNode elemsByTag name = document # getElementsByTagName (toJString name) fstElemByTag :: IsJString e => e -> Exp ElementNode fstElemByTag = val . headArr . elemsByTag allElems :: JArray ElementNode allElems = elemsByTag (string "*") parentElem :: IsElementNode e => (Exp e) -> Exp ElementNode parentElem elem = castObject $ elem # parentNode -- Creating elements txtNode :: IsJString s => s -> Exp TextNode txtNode str = document # createTextNode (toJString str) elemNode :: IsJString s => s -> Exp ElementNode elemNode str = document # createElement (toJString str) -------------------------------------------------------------------------------- -- Non pure funtions -------------------------------------------------------------------------------- -- Alerts a message msg :: IsExp e t => e -> HJScript () msg e = window # alert (toExp e) getElemById :: IsJString e => e -> HJScript (Exp ElementNode) getElemById = return . elemById getElemsByTag :: IsJString e => e -> HJScript (JArray ElementNode) getElemsByTag = return . elemsByTag getFstElemByTag :: IsJString e => e -> HJScript (Exp ElementNode) getFstElemByTag = return . fstElemByTag getAllElems :: HJScript (JArray ElementNode) getAllElems = return allElems getParentElem :: IsElementNode e => Exp e -> HJScript (Exp ElementNode) getParentElem = return . parentElem getElemsByClass :: (IsJString e) => e -> HJScript (JArray ElementNode) getElemsByClass c = filterArray (hasClass c) allElems getFstElemByClass :: IsJString e => e -> HJScript (JObject ElementNode) getFstElemByClass c = do elems <- getElemsByClass c return $ val $ headArr elems -- Get all siblings to an element. getSiblings :: IsElementNode e => Exp e -> HJScript (JArray Node) getSiblings elem = do elems <- varWith $ elem # parentElem # childNodes filterArray (.!=. thisNode) (val elems) -- Hide an element by setting its's style display -- property to "none" hideElem :: IsElementNode e => Exp e -> HJScript () hideElem elem = elem # style # display .=. dispNone -- Shows an element by setting it's style disply property to "block". showElem :: IsElementNode e => Exp e -> HJScript () showElem = showBlock -- Shows an element by setting it's styel display property to "inline". showInline :: IsElementNode e => Exp e -> HJScript () showInline elem = elem # style # display .=. dispInline -- Shows an element by setting it's styel display property to "block". showBlock :: IsElementNode e => Exp e -> HJScript () showBlock elem = elem # style # display .=. dispBlock -- Removes the first children of an element remFirstChild :: IsElementNode e => Exp e -> HJScript () remFirstChild elem = elem # removeChild (elem # firstChild) -- Removes all children remChildren :: IsElementNode e => Exp e -> HJScript () remChildren elem = while (elem # hasChild) $ remFirstChild elem -- Remove an element remElem :: IsElementNode e => Exp e -> HJScript () remElem elem = elem # parentElem # removeChild elem' where elem' = castObject elem :: Exp Node appendChildren :: (IsElementNode n, IsNode t) => JArray t -> Exp n -> HJScript () appendChildren childs elem = do mapArrayH_ (\child -> elem # appendChild child) childs -- Remove all children and add a new child element. setChild :: (IsNode n1, IsElementNode n2) => Exp n1 -> Exp n2 -> HJScript () setChild e1 e2 = do e2 # remChildren e2 # appendChild e1 -- Toggle visible function toggleVis :: (IsElementNode n) => Exp n -> HJScript () toggleVis = toggleVisBlock toggleVisBlock :: (IsElementNode n) => Exp n -> HJScript () toggleVisBlock elem = (isInVisible elem) ? (elem # showBlock ) <|> (elem # hideElem) toggleVisInline :: (IsElementNode n) => Exp n -> HJScript () toggleVisInline elem = (isInVisible elem) ? (elem # showInline ) <|> (elem # hideElem) elemVal :: IsElementNode n => Exp n -> JString elemVal elem = elem # (deref "value") setVal :: IsElementNode n => JString -> Exp n -> HJScript () setVal val elem = elem # (derefVar "value") .=. val newTxtNode :: IsJString s => s -> HJScript (Exp TextNode) newTxtNode = inVar . txtNode newElem :: IsJString s => s -> HJScript (Exp ElementNode) newElem = inVar . elemNode -------------------------------------------------------------------------------- -- Helpers -------------------------------------------------------------------------------- -- Should be placed in a another module, but the problem is where. -- Not in ElementNode since it requries Style. style :: IsElementNode e => Exp e -> Exp Style style = deref "style" display :: Exp Style -> Var String display = derefVar "display" HJScript-0.6.1/src/HJScript/Lang.hs0000644000000000000000000002504611745460125015100 0ustar0000000000000000{-# LANGUAGE FlexibleInstances, OverlappingInstances, TypeSynonymInstances, UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : HJScript.Lang -- License : BSD-style -- Maintainer : Joel Bjornson joel.bjornson@gmail.com, -- Niklas Broberg nibro@cs.chalmers.se -- Stability : experimental ----------------------------------------------------------------------------- module HJScript.Lang ( -- Operators preinc, postinc, predec, postdec, (.+.), (.-.), (.*.), (./.), (.&&.), (.||.), (.==.), (.!=.), (.>.), (.<.) , (.>=.), (.<=.) , (.=.), (.+=.), (?), (<|>), -- Method calls this, callMethod, callVoidMethod, callProc, -- Functions and declarations function, procedure, functionDecl, procedureDecl, -- Control flow for, forIn, forInVar, while, doWhile, doIf, doElse, doIfElse, doIfNoElse, noElse, -- Objects var, varWith, inVar, new, delete, ( # ), ( #. ), rec, first, second, x, y, -- Helpers ( #! ) , jnull, jShow, castObject, hasFeature, break, continue, true ,ifOp, false, int, float, bool, string, -- Re-exports from internal module HJScript.Monad HJScript, IsHJScript(..), outputBlock, outputStmt, -- Evaluating HJScript evaluateHJScript, evalHJScript, -- Re-export all of Language.HJavaScript.Syntax module Language.HJavaScript.Syntax ) where import Language.HJavaScript.Syntax import HJScript.Monad import Prelude hiding (break) -- Infix operators infixr 2 .||. infixr 3 .&&. infix 4 .=. , .==. , .!=., .>., .<. , .<=. , .>=. , ? , `doIfNoElse` , `doIfElse` infixl 6 .+. , .-. infixl 7 .*., ./. infixl 8 # , #! , #. , <|> ------------------------------------------------------------------- -- Operators ------------------------------------------------------------------- type HJSJBinOperator t r = Exp t -> Exp t -> Exp r -- | Incrementing or decrementing numbers. preinc :: Num t => Var t -> HJScript () preinc = outputStmt . ExpStmt . JIncrement Pre postinc :: Num t => Var t -> HJScript () postinc = outputStmt . ExpStmt . JIncrement Pst predec :: Num t => Var t -> HJScript () predec = outputStmt . ExpStmt . JDecrement Pre postdec :: Num t => Var t -> HJScript () postdec = outputStmt . ExpStmt . JDecrement Pst binOp :: BinOp t r -> HJSJBinOperator t r binOp op e1 e2 = JBinOp (toExp e1) op (toExp e2) (.+.) :: PlusOpType a => HJSJBinOperator a a (.+.) = binOp Plus (.-.) :: Num a => HJSJBinOperator a a (.-.) = binOp Minus (.*.) :: Num a => HJSJBinOperator a a (.*.) = binOp Times (./.) :: Num a => HJSJBinOperator a a (./.) = binOp Div (.&&.) :: HJSJBinOperator Bool Bool (.&&.) = binOp And (.||.) :: HJSJBinOperator Bool Bool (.||.) = binOp Or (.==.) :: HJSJBinOperator a Bool (.==.) = binOp Equals (.!=.) :: HJSJBinOperator a Bool (.!=.) = binOp NotEquals (.>.) :: Num a => HJSJBinOperator a Bool (.>.) = binOp GThan (.<.) :: Num a => HJSJBinOperator a Bool (.<.) = binOp LThan (.>=.) :: Num a => HJSJBinOperator a Bool (.>=.) = binOp GEThan (.<=.) :: Num a => HJSJBinOperator a Bool (.<=.) = binOp LEThan -- | Assignment (.=.) :: Var t -> Exp t -> HJScript () v .=. e = outputStmt . ExpStmt $ JAssign v e -- | Plus with (.+=.) :: Num t => Var t -> Exp t -> HJScript () v .+=. e = outputStmt . ExpStmt $ JAssignWith v PlusAssign e ----------------------------------------------------------- -- Control flow ----------------------------------------------------------- -- | for for :: JInt -> JInt -> (JInt -> HJScript t) -> HJScript () for from to script = do name <- newVarName (_,body) <- hjsInside $ script (val $ JVar name) outputStmt $ For (pre name) (cond name) (inc name) body where inc name = JIncrement Pst (JVar name) :: JInt pre name = VarDeclAssign name from cond name = (val $ JVar name) .<=. to -- | for (var in object) { .. } forIn :: (IsDeref d) => d -> (JString -> HJScript ()) -> HJScript () forIn obj script = do v <- var (_, body) <- hjsInside $ script (val v) outputStmt $ ForIn v obj body -- | for (var in object) { .. } forInVar :: (IsDeref d) => d -> (Var a -> HJScript ()) -> HJScript () forInVar obj script = do v <- var (_, body) <- hjsInside $ script (obj # propertyVar (val v)) outputStmt $ ForIn v obj body -- | while while :: JBool -> HJScript t -> HJScript () while cond script = do (_,body) <- hjsInside script outputStmt $ While cond body -- | doWhile doWhile :: HJScript t -> JBool -> HJScript () doWhile = flip while -- | doIf doIf :: JBool -> HJScript t -> HJScript (Elses ()) -> HJScript () doIf cond script els = do (_,body) <- hjsInside script els' <- els outputStmt $ If cond body els' -- | doElse doElse :: HJScript () -> HJScript (Elses ()) doElse script = do (_,body) <- hjsInside script return $ Else body -- | doIfElse doIfElse :: JBool -> (HJScript t1, HJScript t2) -> HJScript () doIfElse cond (hj1,hj2) = do (_,body1) <- hjsInside hj1 (_,body2) <- hjsInside hj2 outputStmt $ If cond body1 (Else body2) -- | Alternative if-else syntax: isTrue ? (doA,doB) (?) :: JBool -> (HJScript t1, HJScript t2) -> HJScript () (?) = doIfElse -- | Providing a way of writing if-else expression as in: isTrue ? doA <|> doB (<|>) :: a -> a -> (a,a) (<|>) = (,) -- | Only an if branch doIfNoElse :: Exp Bool -> HJScript () -> HJScript () doIfNoElse cond script = doIf cond script noElse -- | No else branch. noElse :: HJScript (Elses ()) noElse = return NoElse ----------------------------------------------------------- -- HJScript function declarations ----------------------------------------------------------- -- | Anonymous function, returning an expression function :: (FormalParams a t, VarsToExps a e) => (e -> HJScript (Exp r)) -> HJScript (Exp (t -> r)) function fun = do n <- newVarNum let args = mkFParams (\_ -> ()) n let script = fun $ v2e args (ret, body) <- hjsInside script let body' = addReturn ret body return $ JFunction Nothing args body' -- | Anonymous void function. procedure :: (FormalParams a t, VarsToExps a e) => (e -> HJScript ()) -> HJScript (Exp (t -> ())) procedure fun = do n <- newVarNum let args = mkFParams (\_ -> ()) n body <- return . snd =<< (hjsInside $ fun $ v2e args) return $ JFunction Nothing args body -- | Function declaration functionDecl :: (FormalParams a t, VarsToExps a e) => String -> (e -> HJScript (Exp r)) -> HJScript () functionDecl name fun = do n <- newVarNum let args = mkFParams (\_ -> ()) n let script = fun $ v2e args (ret,body) <- hjsInside script let body' = addReturn ret body outputStmt $ ExpStmt $ JFunction (Just name) args body' -- | Procedure declaration. procedureDecl :: (FormalParams a t, VarsToExps a e) => String -> (e -> HJScript ()) -> HJScript () procedureDecl name fun = do n <- newVarNum let args = mkFParams (\_ -> ()) n let script = fun $ v2e args (_, body) <- hjsInside script outputStmt $ ExpStmt $ JFunction (Just name) args body -- | Adds a return statement to a Block. addReturn :: Exp t -> Block () -> Block t addReturn e block = Sequence block (Return e) ----------------------------------------------------------- -- A return-adding evaluator ----------------------------------------------------------- evaluateHJScript :: HJScript (Exp t) -> Block t evaluateHJScript m = let (v,b) = evalHJScript m in addReturn v b ----------------------------------------------------------- -- HJScript method calls ----------------------------------------------------------- -- Call an object method, returning an expression. callMethod :: (IsDeref d, Args e t1) => String -> e -> d -> Exp t2 callMethod = methodCall -- Method call for void methods. Returns a HJScript () since the return value is -- not of any interest. callVoidMethod :: (Args e t1, IsDeref a) => String -> e -> a -> HJScript () callVoidMethod fun args = outputStmt . ExpStmt . callMethod fun args ----------------------------------------------------------- -- Variables, objects and records ----------------------------------------------------------- -- Creates a JavaScript variable with a fresh name. var :: HJScript (Var t) var = do name <- newVarName outputStmt $ VarDecl name return $ JVar name -- Assign an expression to a new variable. varWith :: Exp t -> HJScript (Var t) varWith e = do name <- newVarName outputStmt $ VarDeclAssign name e return $ JVar name inVar :: Exp t -> HJScript (Exp t) inVar = fmap val . varWith this :: IsClass c => Exp c this = JThis callProc :: (Args e t) => Exp (t -> t1) -> e -> HJScript () callProc e = outputStmt . ExpStmt . (JCall e) -- Create new Objects. new :: (HasConstructor o e t, Args e t) => o -> e -> HJScript (Exp o) new o = fmap val . varWith . JNew o -- |delete a property -- -- Can only delete properties/variables that are created implicitly, -- not those declared with the var statement. -- -- returns true if property was deleted. false if operation was not possible. delete :: Var a -> Exp Bool delete = JDelete -- | Dereferencing operator, similar to the `dot` operator in JavaScript. -- E.g. document.forms => document # forms, same as forms document ( # ) :: a -> (a -> b) -> b a # f = f a -- Operator used for binding dereferencing without argument, -- e.g. "style #. display" ( #. ) :: (a -> b) -> (b -> c) -> (a -> c) ( #. ) = flip (.) -- Creating a record rec :: Exp a -> Exp b -> Exp (Rec a b) rec = JRec first, x :: Exp (Rec a b) -> Exp a first = JFst x = first second, y :: Exp (Rec a b) -> Exp b second = JSnd y = second ----------------------------------------------------------- -- Helpers ----------------------------------------------------------- -- | Accessing arrays. ( #! ) :: JArray t -> JInt -> Var t ( #! ) = JArrayIndex -- | Null value jnull :: IsNullable t => Exp t jnull = JNull -- | Converts to JString expression. jShow :: JShow t => Exp t -> JString jShow = JShow -- | Casting an JObject castObject :: (IsClass c1, IsClass c2) => JObject c1 -> JObject c2 castObject = JCastObject -- | Checks if an object is supported by browser hasFeature :: (IsFeature f , IsClass c) => JObject c -> f -> JBool hasFeature = JIsImpl ifOp :: JBool -> Exp t -> Exp t -> Exp t ifOp = JIfOp break :: HJScript () break = outputStmt Break continue :: HJScript () continue = outputStmt Continue true :: JBool true = JBool True false :: JBool false = JBool False int :: Int -> JInt int = JInt float :: Float -> JFloat float = JFloat bool :: Bool -> JBool bool = JBool string :: String -> JString string = JString HJScript-0.6.1/src/HJScript/Events.hs0000644000000000000000000000362611745460125015463 0ustar0000000000000000----------------------------------------------------------------------------- -- Module : HJScript.Events -- Copyright : (c) Joel Björnson 2006 -- License : BSD-style -- Maintainer : Joel Björnson, joel.bjornson@gmail.com -- Stability : experimental ----------------------------------------------------------------------------- module HJScript.Events ( -- * Data Event(..), -- * Functions showEvent ) where -- import HJScript.Lang import Data.Char (toLower) ----------------------------------------------------------- -- HJScript function for adding Events to an element ----------------------------------------------------------- -- | Events data Event = OnAbort | OnBlur | OnChange | OnClick | OnDblclick | OnError | OnFocus | OnKeyDown | OnKeyPress | OnKeyUp | OnLoad | OnMouseDown | OnMouseMove | OnMouseOut | OnMouseOver | OnMouseUp | OnReset | OnResize | OnSelect | OnSubmit | OnUnload deriving Show showEvent :: Event -> String showEvent = map toLower . show {- What are we using this code for? -- | Attach an event to an ElementNode -- Uses either addEventListener or AttachEvent depending on browser.. addEvent :: (IsElementNode n, IsHJScript s) => Event -> s -> JObject n -> HJScript () addEvent ev fun elm = do fun' <- procedure $ \() -> toHJScript fun doIf (hasAddEL) (addEventListener (toJsExp $ showEventAddE ev,fun',false) elm) $ doElse $ doIfNoElse (hasAddEL) (attachEvent (toJsExp $ showEventAddE ev,fun') elm) where hasAddEL = window `hasFeature` "addEventListener" hasAtEL = window `hasFeature` "attachEvent" -- | Show event for attache event method (used in I.E.) showEventAttE :: Event -> String showEventAttE event = "on" ++ map toLower (show event) -- | Show event for add event method (used in Mz.) showEventAddE :: Event -> String showEventAddE = map toLower . show -}HJScript-0.6.1/src/HJScript/Ajax.hs0000644000000000000000000001242611745460125015100 0ustar0000000000000000{-# LANGUAGE OverlappingInstances, UndecidableInstances #-} ----------------------------------------------------------------------------- -- Module : HJScript.Ajax -- Copyright : (c) Joel Björnson 2006 -- License : BSD-style -- Maintainer : Joel Björnson, joel.bjornson@gmail.com -- Stability : experimental ----------------------------------------------------------------------------- module HJScript.Ajax ( -- * Data ReqParam,ReqParams, IsReqParams(..),noParams, -- * High level asyncGetReq, asyncPostReq, -- * Parameters (=:), (<&>), addGetParams, -- * Low level, openAsync,openAsyncPost,sendNull,sendPost, setCallBack, succCallBack,isReady, isReadySucc, crtXMLHttpRequest, setPostReqHeader, module HJScript.Objects.XMLHttpRequest ) where import HJScript.Lang import HJScript.Objects.XMLHttpRequest import HJScript.Objects.ActiveXObject import HJScript.DOM import Data.List (intersperse) import Control.Monad.Trans -- | Http data HttpMethod = Get | Post deriving Show -- | Allowing path selections form XMLHttpRequest objects. --instance HasDomSel (JsObject a XMLHttpRequest) where -- toDomElement req = req # responseXML # documentElement ---------------------------------------------------- -- High level interface ---------------------------------------------------- -- Get request asyncGetReq :: (IsReqParams ps, IsExp e String) => e -> ps -> (JObject XMLHttpRequest -> HJScript ()) -> HJScript () asyncGetReq url params callb = do req <- crtXMLReq req # openAsyncGet url' req # setCallBack callb' req # sendNull where url' = url `addGetParams` params callb' req = doIf (isReadySucc req) (callb req) noElse -- | Post request asyncPostReq :: (IsReqParams ps, IsExp e String) => e -> ps -> (JObject XMLHttpRequest -> HJScript ()) -> HJScript () asyncPostReq url params callb = do req <- crtXMLReq req # openAsync Post url req # setCallBack callb' req # setPostReqHeader req # sendPost (toReqParams params) where callb' req = doIf (isReadySucc req) (callb req) noElse ---------------------------------------------------- -- Type ReqParam ---------------------------------------------------- type ReqParam = (JString, JString) type ReqParams = [ReqParam] noParams :: ReqParams noParams = [] class IsReqParams a where toReqParams :: a -> [ReqParam] instance (IsExp e1 String, IsExp e2 String) => IsReqParams (e1,e2) where toReqParams (e1,e2) = [(toExp e1, toExp e2)] instance IsReqParams ReqParams where toReqParams = id -- Operator to add a paramname and a paramvalue (=:) :: IsReqParams (a, b) => a -> b -> ReqParams e1 =: e2 = toReqParams (e1,e2) -- Operator to add params (<&>) :: (IsReqParams p1 , IsReqParams p2) => p1 -> p2 -> ReqParams p1 <&> p2 = (toReqParams p1) ++ (toReqParams p2) instance IsExp ReqParam String where toExp (p,v) = p .+. string "=" .+. v instance IsExp [ReqParam] String where toExp pvs = foldr (.+.) (string "") pvs' where pvs' = intersperse (string "&") (map toExp pvs) addGetParams :: (IsExp e String , IsReqParams ps) => e -> ps -> JString addGetParams url params | null params' = toExp url | otherwise = toExp url .+. string "?" .+. toExp params' where params' = toReqParams params ---------------------------------------------------- -- Helpers.. ---------------------------------------------------- openAsync :: (IsExp e String) => HttpMethod -> e -> JObject XMLHttpRequest -> HJScript () openAsync meth url = openReq (toExp $ show meth) (toExp url) true openAsyncGet :: (IsExp e String) => e -> JObject XMLHttpRequest -> HJScript () openAsyncGet = openAsync Get openAsyncPost :: (IsExp e String) => e -> JObject XMLHttpRequest -> HJScript () openAsyncPost = openAsync Post sendNull :: JObject XMLHttpRequest -> HJScript () sendNull = sendReq jnull -- Sends post data sendPost pst = sendReq $ toExp pst -- SetCallBack setCallBack fun req = do callback <- procedure $ \() -> fun req req # onReadyStateChange .=. callback where callback = procedure $ \() -> fun req succCallBack :: JObject XMLHttpRequest -> JBool succCallBack req = req # statusReq .==. int 200 isReady :: JObject XMLHttpRequest -> JBool isReady req = req # readyState .==. int 4 isReadySucc req = isReady req .&&. succCallBack req -- | Creates a new XMLHttpRequest crtXMLHttpRequest :: HJScript (Exp XMLHttpRequest) crtXMLHttpRequest = new XMLHttpRequest () crtXMLReq :: HJScript (Exp XMLHttpRequest) crtXMLReq = do req <- var doIf hasXMLHttpReq (new XMLHttpRequest () >>= \xmlHttp -> (req .=. xmlHttp)) $ doElse $ doIf hasActiveX (new ActiveXObject msXMLHttp >>= \actX -> (req .=. (castObject actX))) $ doElse $ window # alert (string "JavaScript operation not supported") return (val req) -- Sets post request setPostReqHeader req = req # setRequestHeader contt appl where contt = string "Content-Type" appl = string "application/x-www-form-urlencoded" -- Is XMLHttpRequest implemented ? hasXMLHttpReq, hasActiveX :: JBool hasXMLHttpReq = window `hasFeature` XMLHttpRequest hasActiveX = window `hasFeature` ActiveXObject HJScript-0.6.1/src/HJScript/Monad.hs0000644000000000000000000000625211745460125015253 0ustar0000000000000000{-# LANGUAGE FlexibleInstances, OverlappingInstances, TypeSynonymInstances, UndecidableInstances, GADTs #-} ----------------------------------------------------------------------------- -- | -- Module : HJScript.Monad -- License : BSD-style -- Maintainer : Joel Bjornson joel.bjornson@gmail.com, -- Niklas Broberg nibro@cs.chalmers.se -- Stability : experimental ----------------------------------------------------------------------------- module HJScript.Monad ( -- * Data types and classes HJScript, HJScript', IsHJScript(..), -- * Functions evalHJScript, runHJScript, outputBlock, outputStmt, newVarName, newVarNum, hjsInside, ) where import Language.HJavaScript.Syntax import Control.Monad.Writer import Control.Monad.State import HSX.XMLGenerator (XMLGenT, unXMLGenT) -- | HJScript Monad type HJScript'= StateT HJState (Writer (Block ())) type HJScript = XMLGenT HJScript' -- | To keep track of number of created variables type HJState = Int -- | Init state initState :: HJState initState = 0 -- | Shows a HJScript () instance Show (HJScript ()) where show script = show . snd $ evalHJScript script -- | Block as a Monoid instance Monoid (Block ()) where mempty = EmptyBlock mappend EmptyBlock b = b mappend b EmptyBlock = b mappend b1 (Sequence b2 s) = Sequence (mappend b1 b2) s -- | Evaluate a script returning a tuple of the produced value and -- a block of code. evalHJScript :: HJScript t -> (t, Block ()) evalHJScript m = runWriter $ evalStateT (unXMLGenT m) initState -- | Runs a script returning the value, the new state and -- the block of code. runHJScript :: HJScript t -> HJState -> (t, HJState, Block ()) runHJScript m state = let ((v,state'),block) = runWriter $ runStateT (unXMLGenT m) state in (v,state',block) -- Get the state getHJState :: HJScript HJState getHJState = lift get -- Set the state putHJState :: HJState -> HJScript () putHJState = lift . put -- | Adds a statement outputStmt :: Stmt () -> HJScript () outputStmt = outputBlock . toBlock -- | Adds a block outputBlock :: Block () -> HJScript () outputBlock = lift . lift . tell -- Creates a fresh variable number newVarNum :: HJScript Int newVarNum = lift $ do n <- get put $ n + 1 return n -- Creates a fresh variable name newVarName :: HJScript String newVarName = do n <- newVarNum return $ "var" ++ "_" ++ (show n) -- | Runs one script inside another hjsInside :: HJScript t -> HJScript (t, Block ()) hjsInside script = do state <- getHJState let (v,state',block) = runHJScript script state putHJState state' return (v,block) ------------------------------------------------------------------- -- IsHJScript ------------------------------------------------------------------- -- | IsHJscript class with function toHJScript for converting -- instances to HJScript () class IsHJScript a where toHJScript :: a -> HJScript () instance IsHJScript (HJScript t) where toHJScript s = s >> return () instance IsHJScript (Block ()) where toHJScript = outputBlock instance IsHJScript (Stmt ()) where toHJScript = outputStmt instance IsHJScript (Exp t) where toHJScript = toHJScript . ExpStmt HJScript-0.6.1/src/HJScript/DOM.hs0000644000000000000000000000171011745460125014626 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : HJScript.DOM -- Copyright : (c) Joel Bjornson 2008 -- License : BSD-style -- Maintainer : Joel Bjornson joel.bjornson@gmail.com -- Niklas Broberg nibro@cs.chalmers.se -- Stability : experimental ----------------------------------------------------------------------------- module HJScript.DOM ( module HJScript.DOM.NodeTypes, module HJScript.DOM.Node, module HJScript.DOM.Document, module HJScript.DOM.ElementNode, module HJScript.DOM.AttributeNode, module HJScript.DOM.TextNode, module HJScript.DOM.Window, module HJScript.DOM.XHTML ) where import HJScript.DOM.NodeTypes (NodeType(..), nodeTypeVal) import HJScript.DOM.Node import HJScript.DOM.Document import HJScript.DOM.ElementNode import HJScript.DOM.AttributeNode import HJScript.DOM.TextNode import HJScript.DOM.Window import HJScript.DOM.XHTML HJScript-0.6.1/src/HJScript/DOM/0000755000000000000000000000000011745460125014273 5ustar0000000000000000HJScript-0.6.1/src/HJScript/DOM/NodeTypes.hs0000644000000000000000000000526511745460125016551 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : HJScript.DOM.NodeTypes -- License : BSD-style -- Maintainer : Joel Bjornson joel.bjornson@gmail.com -- Niklas Broberg nibro@cs.chalmers.se -- Stability : experimental ----------------------------------------------------------------------------- module HJScript.DOM.NodeTypes ( NodeType(..), -- Node types Node(..), ElementNode(..), AttributeNode(..), TextNode(..), -- CDataSectionNode, EntityReferenceNode, EntityNode, -- ProcessingInstructionNode, CommentNode, DocumentTypeNode, -- DocumentFragmentNode, NotationNode, -- Functions nodeTypeVal, -- Document to avoid cycle Document(..) ) where import HJScript.Lang ---------------------------------------------------- -- Node types ---------------------------------------------------- -- | Different node types data NodeType = NodeElement | NodeAttribute | NodeText | NodeCDataSection | NodeEntety | NodeEntetyRef | NodeProccInstr | NodeComment | NodeDocument | NodeDocType | NodeDocFrag | NodeNotation -- Maps node type to type value nodeTypeVal :: NodeType -> JInt nodeTypeVal tp = JInt $ case tp of NodeElement -> 1 NodeAttribute -> 2 NodeText -> 3 NodeCDataSection -> 4 NodeEntety -> 5 NodeEntetyRef -> 6 NodeProccInstr -> 7 NodeComment -> 8 NodeDocument -> 9 NodeDocType -> 10 NodeDocFrag -> 11 NodeNotation -> 12 ---------------------------------------------------- -- Classes for shared properties and methods ---------------------------------------------------- -- Generic Node data Node = Node deriving Show -- ElementNode data ElementNode = ElementNode deriving Show -- AttributeNode data AttributeNode = AttributeNode deriving Show -- TextNode data TextNode = TextNode deriving Show {- I see no need to include these at this point. -- CDataSectionNode data CDataSectionNode = CDataSectionNode deriving Show -- EntityReferenceNode data EntityReferenceNode = EntityReferenceNode deriving Show -- EntityNode data EntityNode = EntityNode deriving Show -- ProcessingInstructionNode data ProcessingInstructionNode = ProcessingInstructionNode deriving Show -- CommentNode data CommentNode = CommentNode deriving Show -- DocumentTypeNode data DocumentTypeNode = DocumentTypeNode deriving Show -- DocumentFragmentNode data DocumentFragmentNode = DocumentFragmentNode deriving Show -- NotationNode data NotationNode = NotationNode deriving Show -} -- We need to include this here to avoid a cyclic dependency data Document = Document deriving Show HJScript-0.6.1/src/HJScript/DOM/NamedNodeMap.hs0000644000000000000000000000163611745460125017125 0ustar0000000000000000module HJScript.DOM.NamedNodeMap where import HJScript.Lang import HJScript.DOM.NodeTypes (AttributeNode) ---------------------------------------------------- -- the NamedNodeMap object type ---------------------------------------------------- data NamedNodeMap = NamedNodeMap deriving Show instance IsClass NamedNodeMap ---------------------------------------------------- -- properties ---------------------------------------------------- length :: Exp NamedNodeMap -> JInt length = deref "length" ---------------------------------------------------- -- methods ---------------------------------------------------- getNamedItem :: JString -> Exp NamedNodeMap -> Exp AttributeNode getNamedItem = methodCall "getNamedItem" item :: JInt -> Exp NamedNodeMap -> Exp AttributeNode item = methodCall "item" removeNamedItem :: JString -> Exp NamedNodeMap -> Exp AttributeNode removeNamedItem = methodCall "removeNamedItem"HJScript-0.6.1/src/HJScript/DOM/TextNode.hs0000644000000000000000000000305711745460125016366 0ustar0000000000000000module HJScript.DOM.TextNode ( TextNode(..), text, length, appendData, deleteData, insertData, replaceData, splitText, substringData ) where import HJScript.Lang import HJScript.DOM.NodeTypes import HJScript.DOM.Node import Prelude hiding (length) ---------------------------------------------------- -- the TextNode object type ---------------------------------------------------- -- data TextNode = TextNode deriving Show (in NodeTypes) instance IsClass TextNode instance IsNode TextNode ---------------------------------------------------- -- properties ---------------------------------------------------- -- data is a keyword text :: Exp TextNode -> Var String text = derefVar "data" length :: Exp TextNode -> JInt length = deref "length" ---------------------------------------------------- -- methods ---------------------------------------------------- appendData :: JString -> Exp TextNode -> HJScript () appendData = callVoidMethod "appendData" deleteData :: JInt -> JInt -> Exp TextNode -> HJScript () deleteData = curry $ callVoidMethod "deleteData" insertData :: JInt -> JString -> Exp TextNode -> HJScript () insertData = curry $ callVoidMethod "insertData" replaceData :: JInt -> JInt -> JString -> Exp TextNode -> HJScript () replaceData st ln txt = callVoidMethod "replaceData" (st,ln,txt) -- curry3 !! splitText :: JInt -> Exp TextNode -> Exp TextNode splitText = methodCall "splitText" substringData :: JInt -> JInt -> Exp TextNode -> JString substringData = curry $ methodCall "substringData"HJScript-0.6.1/src/HJScript/DOM/XHTML.hs0000644000000000000000000001403111745460125015522 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : HJScript.DOM.XHTML -- License : BSD-style -- Maintainer : Joel Bjornson joel.bjornson@gmail.com -- Niklas Broberg nibro@cs.chalmers.se -- Stability : experimental ----------------------------------------------------------------------------- module HJScript.DOM.XHTML ( -- * Standard properties IsXHTMLElement, asXHTMLElement, className, -- * XHTML DOM elements Anchor(..), Area(..), Base(..), Body(..), Event(..), Form(..), Frame(..), Frameset(..), History(..), IFrame(..), Image(..), InputButton(..), InputCheckbox(..), InputFile(..), InputHidden(..), InputPassword(..), InputRadio(..), InputReset(..), InputSubmit(..), InputText(..), Link(..),Location(..), Meta(..), Navigator(..), Object(..), Option(..), Screen(..), Select(..), Style(..), Table(..), TableData(..), TableHeader(..), TableRow(..), Textarea(..) ) where import HJScript.DOM.NodeTypes import HJScript.Lang import HJScript.DOM.Node import HJScript.DOM.ElementNode import HJScript.Objects.Object(Object(..)) ----------------------------------- -- Class gathering all standard methods class IsElementNode a => IsXHTMLElement a -- General XHTML element type. data XHTMLElement = XHTMLElement deriving Show instance IsClass XHTMLElement instance IsElementNode XHTMLElement instance IsXHTMLElement XHTMLElement asXHTMLElement :: IsElementNode n => Exp n -> Exp XHTMLElement asXHTMLElement = castObject -- Standard methods className :: IsXHTMLElement n => Exp n -> Var String className = derefVar "className" dir :: IsXHTMLElement n => Exp n -> Var String dir = derefVar "lang" lang :: IsXHTMLElement n => Exp n -> Var String lang = derefVar "lang" title :: IsXHTMLElement n => Exp n -> Var String title = derefVar "title" -- Going to and from ElementNode. generalize :: IsXHTMLElement a => Exp a -> Exp ElementNode generalize = castObject specialize :: IsXHTMLElement a => Exp ElementNode -> Exp a specialize = castObject -- A lot more work should be done here, to the point -- where each separate element should have its own -- module. -- Anchor data Anchor = Anchor deriving Show instance IsClass Anchor instance IsNode Anchor instance IsElementNode Anchor instance IsXHTMLElement Anchor -- Area data Area = Area deriving Show instance IsNode Area instance IsClass Area instance IsElementNode Area instance IsXHTMLElement Area -- Base data Base = Base deriving Show instance IsClass Base instance IsNode Base instance IsElementNode Base instance IsXHTMLElement Base -- Body data Body = Body deriving Show instance IsClass Body instance IsNode Body instance IsElementNode Body instance IsXHTMLElement Body -- Event data Event = Event deriving Show instance IsClass Event -- Form data Form = Form deriving Show instance IsClass Form instance IsNode Form instance IsElementNode Form instance IsXHTMLElement Form -- Frame data Frame = Frame deriving Show instance IsClass Frame instance IsNode Frame instance IsElementNode Frame instance IsXHTMLElement Frame -- Frameset data Frameset = Frameset deriving Show instance IsClass Frameset -- History data History = History deriving Show instance IsClass History -- IFrame data IFrame = IFrame deriving Show instance IsClass IFrame instance IsNode IFrame instance IsElementNode IFrame instance IsXHTMLElement IFrame -- Image data Image = Image deriving Show instance IsClass Image instance IsNode Image instance IsElementNode Image instance IsXHTMLElement Image -- InputButton data InputButton = InputButton deriving Show instance IsClass InputButton instance IsNode InputButton instance IsElementNode InputButton instance IsXHTMLElement InputButton -- InputCheckbox data InputCheckbox = InputCheckbox deriving Show instance IsClass InputCheckbox instance IsNode InputCheckbox instance IsElementNode InputCheckbox instance IsXHTMLElement InputCheckbox -- InputFile data InputFile = InputFile deriving Show instance IsClass InputFile -- InputHidden data InputHidden = InputHidden deriving Show instance IsClass InputHidden -- InputPassword data InputPassword = InputPassword deriving Show instance IsClass InputPassword -- InputRadio data InputRadio = InputRadio deriving Show instance IsClass InputRadio -- InputReset data InputReset = InputTextInputReset deriving Show instance IsClass InputReset -- InputSubmit data InputSubmit = InputSubmit deriving Show instance IsClass InputSubmit -- InputText data InputText = InputText deriving Show instance IsClass InputText instance IsNode InputText instance IsElementNode InputText instance IsXHTMLElement InputText -- Link data Link = Link deriving Show instance IsClass Link instance IsNode Link instance IsElementNode Link instance IsXHTMLElement Link -- Location data Location = Location deriving Show instance IsClass Location -- Meta data Meta = Meta deriving Show instance IsClass Meta -- Navigator data Navigator = Navigator deriving Show instance IsClass Navigator -- Option data Option = Option deriving Show instance IsClass Option -- Screen data Screen = Screen deriving Show instance IsClass Screen -- Select data Select = Select deriving Show instance IsClass Select -- Style data Style = Style deriving Show instance IsClass Style -- Table data Table = Table deriving Show instance IsClass Table instance IsNode Table instance IsElementNode Table instance IsXHTMLElement Table -- TableData data TableData = TableData deriving Show instance IsClass TableData instance IsNode TableData instance IsElementNode TableData instance IsXHTMLElement TableData -- TableHeader data TableHeader = TableHeader deriving Show instance IsClass TableHeader instance IsNode TableHeader instance IsElementNode TableHeader instance IsXHTMLElement TableHeader -- TableRow data TableRow = TableRow deriving Show instance IsClass TableRow instance IsNode TableRow instance IsElementNode TableRow instance IsXHTMLElement TableRow -- Textarea data Textarea = Textarea deriving Show instance IsClass Textarea instance IsNode Textarea instance IsElementNode Textarea instance IsXHTMLElement Textarea HJScript-0.6.1/src/HJScript/DOM/AttributeNode.hs0000644000000000000000000000151111745460125017376 0ustar0000000000000000module HJScript.DOM.AttributeNode ( AttributeNode(..), name, specified, value ) where import HJScript.Lang import HJScript.DOM.NodeTypes import HJScript.DOM.Node ---------------------------------------------------- -- the AttributeNode object type ---------------------------------------------------- -- data AttributeNode = AttributeNode deriving Show (in NodeTypes instance IsClass AttributeNode -- inherit all the Node properties and methods instance IsNode AttributeNode ---------------------------------------------------- -- properties ---------------------------------------------------- name :: Exp AttributeNode -> JString name = deref "name" specified :: Exp AttributeNode -> JBool specified = deref "specified" value :: Exp AttributeNode -> Var String value = derefVar "value" HJScript-0.6.1/src/HJScript/DOM/Window.hs0000644000000000000000000000647611745460125016113 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : HJScript.DOM.Window -- License : BSD-style -- Maintainer : Joel Bjornson joel.bjornson@gmail.com -- Niklas Broberg nibro@cs.chalmers.se -- Stability : experimental ----------------------------------------------------------------------------- module HJScript.DOM.Window ( -- Constructor function window, Window, -- Properties frames, closed, defaultStatus, winDocument, winLength, winName, opener, parent, self, status, top, blur, focus, -- Methods alert, close, confirm, createPopup, resizeBy, resizeTo, promt, moveBy, moveTo, navigate, open, scrollBy, scrollTo, ) where import HJScript.Lang import HJScript.DOM.NodeTypes import HJScript.DOM.XHTML data Window = Window deriving Show instance IsClass Window -- Accessing the window object window :: Exp Window window = JConst "window" -- Window properties closed :: Exp Window -> JBool closed = deref "closed" defaultStatus :: Exp Window -> JString defaultStatus = deref "defaultStatus" winDocument :: Exp Window -> Exp Document winDocument = deref "document" frames :: Exp Window -> JArray Frame frames = deref "frames" winLength :: Exp Window -> Var Int winLength = derefVar "length" winName :: Exp Window -> Var String winName = derefVar "name" opener :: Exp Window -> Exp Window opener = deref "opener" parent :: Exp Window -> Exp Window parent = deref "parent" self :: Exp Window -> Exp Window self = deref "self" status :: Exp Window -> Var String status = derefVar "status" top :: Exp Window -> Exp Window top = deref "top" -- Window methods alert :: Exp t -> Exp Window -> HJScript () alert = callVoidMethod "alert" blur :: Exp Window -> HJScript () blur = callVoidMethod "blur" () {- Not yet supported. clearInterval, clearTimeout :: Exp Window -> HJScript () clearInterval = callVoidMethod "clearInterval" clearTimeout = callVoidMethod "clearTimeout" -} close :: Exp Window -> HJScript () close = callVoidMethod "close" () confirm :: JString -> Exp Window -> JBool confirm = methodCall "confirm" createPopup :: Exp Window -> Exp Window createPopup = methodCall "createPopup" () focus :: Exp Window -> HJScript () focus = callVoidMethod "focus" () moveBy :: JInt -> JInt -> Exp Window -> HJScript () moveBy x y = callVoidMethod "moveBy" (x,y) moveTo :: JInt -> JInt -> Exp Window -> HJScript () moveTo x y = callVoidMethod "moveTo" (x,y) open :: JString -> JString -> Exp Window -> HJScript () open url sett = callVoidMethod "open" (url, sett) promt :: JString -> Exp Window -> JString promt = methodCall "promt" -- Not standard? navigate :: JString -> Exp Window -> HJScript () navigate = callVoidMethod "navigate" scrollBy :: JInt -> JInt -> Exp Window -> HJScript () scrollBy x y = callVoidMethod "scrollBy" (x,y) scrollTo :: JInt -> JInt -> Exp Window -> HJScript () scrollTo x y = callVoidMethod "scrollTo" (x,y) resizeBy :: JInt -> JInt -> Exp Window -> HJScript () resizeBy x y = callVoidMethod "resizeBy" (x,y) resizeTo :: JInt -> JInt -> Exp Window -> HJScript () resizeTo x y = callVoidMethod "resizeTo" (x,y) {- Not yet supported setInterval, setTimeout :: JString -> JInt -> Exp Window -> HJScript () setInterval = callVoidMethod "setInterval" setTimeout = callVoidMethod "setTimeout" -}HJScript-0.6.1/src/HJScript/DOM/Node.hs0000644000000000000000000000315511745460125015520 0ustar0000000000000000module HJScript.DOM.Node ( Node(..), IsNode(..), NodeType(..), nodeTypeVal, nodeName, nodeType, nodeValue, ownerDocument, prefix, cloneNode ) where import HJScript.Lang --import HJScript.DOM.Document import HJScript.DOM.NodeTypes ---------------------------------------------------- -- the Node object type ---------------------------------------------------- -- data Node = Node deriving Show (is in NodeTypes) instance IsClass Node class IsClass n => IsNode n where castToNode :: JObject n -> JObject Node castToNode = castObject castFromNode :: JObject Node -> JObject n castFromNode = castObject instance IsNode Node where castToNode = id castFromNode = id ---------------------------------------------------- -- Properties for Nodes ---------------------------------------------------- -- We move all properties dealing with children, siblings -- and parents to ElementNode, since in our simple model -- they only make sense on (subclasses of) Element nodes -- anyway. nodeName :: IsNode n => Exp n -> JString nodeName = deref "nodeName" nodeType :: IsNode n => Exp n -> JInt nodeType = deref "nodeType" nodeValue :: IsNode n => Exp n -> Var String nodeValue = derefVar "nodeValue" ownerDocument :: IsNode n => Exp n -> Exp Document ownerDocument = deref "ownerDocument" prefix :: IsNode n => Exp n -> Exp String prefix = deref "prefix" ---------------------------------------------------- -- Methods for Nodes ---------------------------------------------------- cloneNode :: IsNode n => JBool -> Exp n -> Exp n cloneNode = methodCall "cloneNode" HJScript-0.6.1/src/HJScript/DOM/ElementNode.hs0000644000000000000000000001061411745460125017030 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : HJScript.DOM.ElementNode -- Copyright : (c) Joel Bjornson 2008 -- License : BSD-style -- Maintainer : Joel Bjornson joel.bjornson@gmail.com -- Niklas Broberg nibro@cs.chalmers.se -- Stability : experimental ----------------------------------------------------------------------------- module HJScript.DOM.ElementNode ( ElementNode(..), IsElementNode, -- Properties attributes, childNodes, firstChild, lastChild, localName, nextSibling, parentNode, previousSibling, tagName, scrollTop, scrollTopVar, scrollHeight, scrollHeightVar, -- Methods appendChild, cloneNode, getAttribute, getAttributeNode, hasAttribute, hasAttributes, hasChildNodes, insertBefore, normalize, removeAttribute, removeAttributeNode, removeChild, replaceChild, setAttribute, setAttributeNode ) where import HJScript.Lang import HJScript.DOM.NodeTypes import HJScript.DOM.Node import HJScript.DOM.NamedNodeMap ---------------------------------------------------- -- The ElementNode type ---------------------------------------------------- -- data ElementNode = ElementNode deriving Show instance IsClass ElementNode instance IsNode ElementNode class IsClass n => IsElementNode n instance IsElementNode ElementNode ---------------------------------------------------- -- Properties ---------------------------------------------------- attributes :: IsElementNode n => Exp n -> Exp NamedNodeMap attributes = deref "attributes" childNodes :: IsElementNode n => Exp n -> JArray Node childNodes = deref "childNodes" firstChild :: IsElementNode n => Exp n -> Exp Node firstChild = deref "firstChild" lastChild :: IsElementNode n => Exp n -> Exp Node lastChild = deref "lastChild" localName :: IsElementNode n => Exp n -> JString localName = deref "localName" nextSibling :: IsElementNode n => Exp n -> Exp Node nextSibling = deref "nextSibling" parentNode :: IsElementNode n => Exp n -> Exp Node parentNode = deref "parentNode" previousSibling :: IsElementNode n => Exp n -> Exp Node previousSibling = deref "previousSibling" tagName :: IsElementNode o => Exp o -> JString tagName = deref "tagName" scrollTop :: IsElementNode o => Exp o -> Exp JInt scrollTop = deref "scrollTop" scrollTopVar :: IsElementNode o => Exp o -> Var JInt scrollTopVar exp = JDerefVar exp "scrollTop" scrollHeight :: IsElementNode o => Exp o -> Exp JInt scrollHeight = deref "scrollHeight" scrollHeightVar :: IsElementNode o => Exp o -> Var JInt scrollHeightVar exp = JDerefVar exp "scrollHeight" ---------------------------------------------------- -- Methods ---------------------------------------------------- appendChild :: (IsElementNode n, IsNode c) => Exp c -> Exp n -> HJScript () appendChild = callVoidMethod "appendChild" getAttribute :: IsElementNode n => JString -> Exp n -> JString getAttribute = methodCall "getAttribute" getAttributeNode :: IsElementNode n => JString -> Exp n -> Exp AttributeNode getAttributeNode = methodCall "getAttributeNode" hasAttribute :: IsElementNode n => JString -> Exp n -> JBool hasAttribute = methodCall "hasAttribute" hasAttributes :: IsElementNode n => Exp n -> JBool hasAttributes = methodCall "hasAttributes" () hasChildNodes :: IsElementNode n => Exp n -> JBool hasChildNodes = methodCall "hasChildNodes" () insertBefore :: IsElementNode n => Exp Node -> Exp Node -> Exp n -> HJScript () insertBefore b a = callVoidMethod "insertBefore" (b,a) normalize :: IsElementNode n => Exp n -> HJScript () normalize = callVoidMethod "normalize" () removeAttribute :: IsElementNode n => JString -> Exp n -> HJScript () removeAttribute = callVoidMethod "removeAttribute" removeAttributeNode :: IsElementNode n => Exp AttributeNode -> Exp n -> HJScript () removeAttributeNode = callVoidMethod "removeAttributeNode" removeChild :: (IsElementNode n, IsNode c) => Exp c -> Exp n -> HJScript () removeChild = callVoidMethod "removeChild" replaceChild :: (IsElementNode n, IsNode c, IsNode d) => Exp c -> Exp d -> Exp n -> HJScript () replaceChild = curry $ callVoidMethod "replaceChild" setAttribute :: IsElementNode n => JString -> JString -> Exp n -> HJScript () setAttribute = curry $ callVoidMethod "setAttribute" setAttributeNode :: IsElementNode n => Exp AttributeNode -> Exp n -> HJScript () setAttributeNode = callVoidMethod "setAttributeNode" HJScript-0.6.1/src/HJScript/DOM/Document.hs0000644000000000000000000000643211745460125016412 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : HJScript.DOM.Document -- License : BSD-style -- Maintainer : Joel Bjornson joel.bjornson@gmail.com -- Niklas Broberg nibro@cs.chalmers.se -- Stability : experimental ----------------------------------------------------------------------------- module HJScript.DOM.Document ( -- Data Document, -- Constructor function document, -- Properties anchors, applets, embeds, forms, images, links, stylesheets, alinkColor, body, cookie, documentElement, domain, lastModified, linkColor, referrer, url, vlinkColor, -- Methods createAttribute, createElement, createTextNode, getElementById, getElementsByTagName, write, writeln ) where import HJScript.Lang import HJScript.DOM.NodeTypes import HJScript.DOM.XHTML -- In NodeTypes to avoid cyclic dependency: -- data Document = Document deriving Show instance IsClass Document -- Access the document object document :: Exp Document document = JConst "document" ---------------------------------------------------- -- Properties ---------------------------------------------------- anchors :: Exp Document -> JArray Anchor anchors = deref "anchors" -- Not standard? applets :: Exp Document -> JArray Object applets = deref "applets" -- Not standard? embeds :: Exp Document -> JArray ElementNode embeds = deref "embeds" forms :: Exp Document -> JArray Form forms = deref "forms" images :: Exp Document -> JArray Image images = deref "images" links :: Exp Document -> JArray Link links = deref "links" -- Not standard? stylesheets :: Exp Document -> JArray Style stylesheets = deref "stylesheets" -- Not standard? alinkColor :: Exp Document -> JString alinkColor = deref "alinkColor" body :: Exp Document -> Exp Body body = deref "body" cookie :: Exp Document -> Var String cookie = derefVar "cookie" documentElement :: Exp Document -> Exp ElementNode documentElement = deref "documentElement" domain :: Exp Document -> JString domain = deref "domain" lastModified :: Exp Document -> JString lastModified = deref "lastModified" -- Not standard? linkColor :: Exp Document -> JString linkColor = deref "linkColor" referrer :: Exp Document -> JString referrer = deref "referrer" url :: Exp Document -> JString url = deref "url" title :: Exp Document -> JString title = deref "title" vlinkColor :: Exp Document -> JString vlinkColor = deref "vlinkColor" ---------------------------------------------------- -- Methods ---------------------------------------------------- createAttribute :: JString -> Exp Document -> Exp AttributeNode createAttribute = methodCall "createAttribute" createElement :: JString -> Exp Document -> Exp ElementNode createElement = methodCall "createElement" createTextNode :: JString -> Exp Document -> Exp TextNode createTextNode = methodCall "createTextNode" getElementById :: JString -> Exp Document -> Exp ElementNode getElementById = methodCall "getElementById" getElementsByTagName :: JString -> Exp Document -> JArray ElementNode getElementsByTagName = methodCall "getElementsByTagName" write :: JString -> Exp Document -> HJScript () write = callVoidMethod "write" writeln :: JString -> Exp Document -> HJScript () writeln = callVoidMethod "writeln"HJScript-0.6.1/src/HJScript/Objects/0000755000000000000000000000000011745460125015245 5ustar0000000000000000HJScript-0.6.1/src/HJScript/Objects/Boolean.hs0000644000000000000000000000170411745460125017162 0ustar0000000000000000{-# LANGUAGE OverlappingInstances, UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : HJScript.Objects.Boolean -- License : BSD-style -- Maintainer : Joel Bjornson joel.bjornson@gmail.com, -- Niklas Broberg nibro@cs.chalmers.se -- Stability : experimental ----------------------------------------------------------------------------- module HJScript.Objects.Boolean ( Boolean(..), booleanToString, valueOf ) where import HJScript.Lang data Boolean = Boolean deriving Show instance IsClass Boolean instance IsDeref Boolean -- | Constructors instance HasConstructor Boolean JBool Bool instance HasConstructor Boolean JString String instance HasConstructor Boolean JInt Int -- Methods booleanToString :: JObject Boolean -> JString booleanToString = methodCallNoArgs "toString" valueOf :: JObject Boolean -> JBool valueOf = methodCallNoArgs "valueOf" HJScript-0.6.1/src/HJScript/Objects/RegExp.hs0000644000000000000000000000171211745460125016774 0ustar0000000000000000{-# LANGUAGE OverlappingInstances, UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : HJScript.Objects.RegExp -- License : BSD-style -- Maintainer : Joel Bjornson joel.bjornson@gmail.com, -- Niklas Broberg nibro@cs.chalmers.se -- Stability : experimental ----------------------------------------------------------------------------- module HJScript.Objects.RegExp ( -- Data RegExp(..), -- Functions test, exec, compile ) where import HJScript.Lang data RegExp = RegExp deriving Show instance IsClass RegExp instance IsDeref RegExp -- | Constructors for RegExp instance HasConstructor RegExp JString String -- Methods test :: JString -> JObject RegExp -> JBool test = callMethod "test" exec :: JString -> JObject RegExp -> JString exec = callMethod "test" compile :: JString -> JObject RegExp -> HJScript () compile = callVoidMethod "compile" HJScript-0.6.1/src/HJScript/Objects/XMLHttpRequest.hs0000644000000000000000000000402011745460125020446 0ustar0000000000000000{-# LANGUAGE OverlappingInstances, UndecidableInstances #-} ----------------------------------------------------------------------------- -- Module : HJScript.Objects.XMLHttpRequest -- Copyright : (c) Joel Björnson 2006 -- License : BSD-style -- Maintainer : Joel Björnson, joel.bjornson@gmail.com -- Stability : experimental -- XMLHttpRequest implementation ----------------------------------------------------------------------------- module HJScript.Objects.XMLHttpRequest ( -- * Data XMLHttpRequest(..), -- * Properties statusReq, onReadyStateChange, responseXML, responseText, readyState, -- * Methods openReq, sendReq, setRequestHeader ) where import HJScript.Lang import HJScript.DOM.Document (Document) -- | XMLHttpRequest data XMLHttpRequest = XMLHttpRequest deriving Show instance IsClass XMLHttpRequest instance HasConstructor XMLHttpRequest () () ---------------------------------------------------- -- Special XMLHttpRequest properties ---------------------------------------------------- statusReq :: JObject XMLHttpRequest -> JInt statusReq = deref "status" onReadyStateChange :: JObject XMLHttpRequest -> Var (() -> ()) onReadyStateChange = derefVar "onreadystatechange" responseXML :: JObject XMLHttpRequest -> JObject Document responseXML = deref "responseXML" responseText :: JObject XMLHttpRequest -> JString responseText = deref "responseText" readyState :: JObject XMLHttpRequest -> JInt readyState = deref "readyState" ---------------------------------------------------- -- Special XMLHttpRequest methods ---------------------------------------------------- openReq :: JString -> JString -> JBool -> JObject XMLHttpRequest -> HJScript () openReq a1 a2 a3 = callVoidMethod "open" (a1, a2, a3) sendReq :: JString -> JObject XMLHttpRequest -> HJScript () sendReq = callVoidMethod "send" setRequestHeader :: JString -> JString -> JObject XMLHttpRequest -> HJScript () setRequestHeader = curry $ callVoidMethod "setRequestHeader" HJScript-0.6.1/src/HJScript/Objects/Object.hs0000644000000000000000000000122011745460125017002 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses #-} ----------------------------------------------------------------------------- -- | -- Module : Language.HJavaScript.Objects.Array -- Copyright : (c) 2010 Joel Bjornson -- License : BSD-style -- Maintainer : Joel Bjornson joel.bjornson@gmail.com -- Niklas Broberg nibro@cs.chalmers.se -- Stability : experimental ----------------------------------------------------------------------------- module HJScript.Objects.Object where import Language.HJavaScript.Syntax -- | plain old Object data Object = Object deriving Show instance IsClass Object instance HasConstructor Object () () HJScript-0.6.1/src/HJScript/Objects/JQuery.hs0000644000000000000000000000347011745460125017024 0ustar0000000000000000{-# LANGUAGE OverlappingInstances, UndecidableInstances #-} module HJScript.Objects.JQuery where import HJScript.Lang import HJScript.DOM.Window import HJScript.DOM.ElementNode data JQuery = JQuery deriving Show instance IsClass JQuery -- | Constructors for Date instance HasConstructor JQuery JString String jQuery :: Exp JQuery jQuery = JConst "jQuery" selectExpr :: Exp c -> JObject JQuery selectExpr e = methodCall "jQuery" e window jSize :: JObject JQuery -> JInt jSize = methodCallNoArgs "size" length :: JObject JQuery -> JInt length = deref "length" get :: JInt -> JObject JQuery -> Exp ElementNode get = methodCall "get" empty :: JObject JQuery -> Exp JQuery empty = methodCall "empty" () jVal :: JObject JQuery -> JString jVal = methodCall "val" () jSetVal :: JString -> JObject JQuery -> JString jSetVal = methodCall "val" jText :: JObject JQuery -> JString jText = methodCall "text" () jSetText :: JString -> JObject JQuery -> Exp JQuery jSetText = methodCall "text" append :: Exp a -> JObject JQuery -> Exp JQuery append = methodCall "append" prepend :: Exp a -> JObject JQuery -> Exp JQuery prepend = methodCall "prepend" ready :: HJScript () -> HJScript () ready script = do fn <- procedure $ \() -> script runExp $ methodCall "jQuery" fn window change :: HJScript () -> JObject JQuery -> HJScript () change script query = do fn <- procedure $ \() -> script runExp $ methodCall "change" fn query submit :: HJScript () -> JObject JQuery -> HJScript () submit script query = do fn <- procedure $ \() -> script runExp $ methodCall "submit" fn query select :: HJScript () -> JObject JQuery -> HJScript () select script query = do fn <- procedure $ \() -> script runExp $ methodCall "select" fn query runExp :: Exp a -> HJScript () runExp = outputStmt . ExpStmt HJScript-0.6.1/src/HJScript/Objects/ActiveXObject.hs0000644000000000000000000000137011745460125020274 0ustar0000000000000000{-# LANGUAGE OverlappingInstances, UndecidableInstances #-} ----------------------------------------------------------------------------- -- Module : HJScript.Objects.ActiveXObject -- Copyright : (c) Joel Björnson 2006 -- License : BSD-style -- Maintainer : Joel Björnson, joel.bjornson@gmail.com -- Stability : experimental -- Microsoft active-x object. ----------------------------------------------------------------------------- module HJScript.Objects.ActiveXObject ( ActiveXObject(..), msXMLHttp ) where import HJScript.Lang -- ActiveXObject data ActiveXObject = ActiveXObject deriving Show instance IsClass ActiveXObject instance HasConstructor ActiveXObject JString String msXMLHttp = string "Microsoft.XMLHTTP" HJScript-0.6.1/src/HJScript/Objects/String.hs0000644000000000000000000000426511745460125017056 0ustar0000000000000000{-# LANGUAGE OverlappingInstances, UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : HJScript.Object.String -- Copyright : (c) Joel Bjornson 008 -- License : BSD-style -- Maintainer : Joel Bjornson joel.bjornson@gmail.com, -- Niklas Broberg nibro@cs.chalmers.se -- Stability : experimental ----------------------------------------------------------------------------- module HJScript.Objects.String ( -- * String properties strLength, -- * String methods toUpperCase, toLowerCase, anchor, big, blink, bold, charAt, charCodeAt, strConcat, indexOf, italics,lastIndexOf, link, replace, substr, substring ) where import HJScript.Lang instance IsClass String ---------------------------------------------------- -- String properties ---------------------------------------------------- strLength :: JString -> JInt strLength = deref "length" ---------------------------------------------------- -- String methods ---------------------------------------------------- toUpperCase :: JString -> JString toUpperCase = callMethod "toUpperCase" () toLowerCase :: JString -> JString toLowerCase = callMethod "toLowerCase" () anchor :: JString -> JString anchor = callMethod "anchor" () big :: JString -> JString big = callMethod "big" () blink :: JString -> JString blink = callMethod "blink" () bold :: JString -> JString bold = callMethod "bold" () charAt :: JInt -> JString -> JString charAt = callMethod "charAt" charCodeAt :: JInt -> JString -> JInt charCodeAt = callMethod "charCodeAt" strConcat :: JString -> JString -> JString strConcat = callMethod "concat" indexOf :: JString -> JInt indexOf = callMethod "indexOf" () italics :: JString -> JString italics = callMethod "italics" () lastIndexOf :: JString -> JInt lastIndexOf = callMethod "lastIndexOf" () link :: JString -> JString link = callMethod "link" () replace :: JString -> JString -> JString replace = callMethod "replace" substr :: JInt -> JString -> JString substr = callMethod "substr" substring :: JInt -> JInt -> JString -> JString substring x y = callMethod "substring" (x,y) HJScript-0.6.1/src/HJScript/Objects/Array.hs0000644000000000000000000000423111745460125016657 0ustar0000000000000000{-# LANGUAGE OverlappingInstances, UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : HJScript.Objects.Array -- License : BSD-style -- Maintainer : Joel Bjornson joel.bjornson@gmail.com -- Niklas Broberg nibro@cs.chalmers.se -- Stability : experimental ----------------------------------------------------------------------------- module HJScript.Objects.Array ( -- Properties arrLength, -- Methods push, headArr, mapArray, mapArrayH, mapArrayH_, foreach, filterArray ) where import HJScript.Lang -- | Constructors for Array instance HasConstructor (Array t) () () instance HasConstructor (Array t) (JInt) Int headArr :: JArray t -> Var t headArr arr = arr #! (int 0) -- | Properties for Array arrLength :: JArray t -> JInt arrLength = deref "length" -- | Methods on array push :: Exp t -> JArray t -> HJScript () push arg = callVoidMethod "push" arg -- | Map array mapArray :: (Exp t1 -> Exp t2) -> JArray t1 -> HJScript (JArray t2) mapArray fun arr = do retArr <- new Array () for (int 0) (arrLength arr .-. (int 1)) $ \index -> do let elem = fun $ val (arr #! index) retArr # push elem return retArr -- | mapArrayH mapArrayH :: (Exp t1 -> HJScript (Exp t2)) -> JArray t1 -> HJScript (JArray t2) mapArrayH fun arr = do retArr <- new Array () for (int 0) (arrLength arr .-. (int 1)) $ \index -> do elem <- fun $ val (arr #! index) retArr # push elem return retArr -- | Throw away produced value. mapArrayH_ :: (Exp t1 -> HJScript t2) -> JArray t1 -> HJScript () mapArrayH_ fun arr = for (int 0) (arrLength arr .-. (int 1)) $ \index -> fun $ val (arr #! index) -- | Synonym for mapArrayH_ foreach :: JArray t1 -> (Exp t1 -> HJScript t2) -> HJScript () foreach = flip mapArrayH_ -- | Select array elements with a condition. filterArray :: (Exp t -> JBool) -> JArray t -> HJScript (JArray t) filterArray cond elems = do arr <- new Array () foreach elems $ maybeAdd arr return arr where maybeAdd arr elem = doIfNoElse (elem # cond) $ arr # push elem HJScript-0.6.1/src/HJScript/Objects/Math.hs0000644000000000000000000000363111745460125016475 0ustar0000000000000000{-# LANGUAGE OverlappingInstances, UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : HJScript.Objects.Math -- License : BSD-style -- Maintainer : Joel Bjornson joel.bjornson@gmail.com, -- Niklas Broberg nibro@cs.chalmers.se -- Stability : experimental ----------------------------------------------------------------------------- module HJScript.Objects.Math ( Math(..), abs, acos, asin, atan, cos, exp, floor, log, max, min, pow, random, round, sin, sqrt, tan ) where import HJScript.Lang import Prelude hiding ( abs,acos,asin,atan,cos,exp,floor,log, max,min,round,sin,sqrt,tan) -- | Math Class data Math = Math deriving Show instance IsClass Math instance IsDeref Math callMathMeth :: Num t => String -> Exp t -> JFloat callMathMeth name exp = callMethod name exp Math abs :: Num t => Exp t -> JFloat abs = callMathMeth "abs" acos :: Num t => Exp t -> JFloat acos = callMathMeth "acos" asin :: Num t => Exp t -> JFloat asin = callMathMeth "asin" atan :: Num t => Exp t -> JFloat atan = callMathMeth "atan" cos :: Num t => Exp t -> JFloat cos = callMathMeth "cos" exp :: Num t => Exp t -> JFloat exp = callMathMeth "exp" floor :: Num t => Exp t -> JFloat floor = callMathMeth "floor" log :: Num t => Exp t -> JFloat log = callMathMeth "log" max :: Num t => Exp t -> JFloat max = callMathMeth "max" min :: Num t => Exp t -> JFloat min = callMathMeth "min" pow :: Num t => Exp t -> JFloat pow = callMathMeth "pow" random :: Num t => Exp t -> JFloat random = callMathMeth "random" round :: Num t => Exp t -> JFloat round = callMathMeth "round" sin :: Num t => Exp t -> JFloat sin = callMathMeth "sin" sqrt ::Num t => Exp t -> JFloat sqrt = callMathMeth "sqrt" tan :: Num t => Exp t -> JFloat tan = callMathMeth "tan" HJScript-0.6.1/src/HJScript/Objects/Date.hs0000644000000000000000000001130611745460125016457 0ustar0000000000000000{-# LANGUAGE OverlappingInstances, UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : HJScript.Object.Date -- Copyright : (c) Joel Bjornson 2008 -- License : BSD-style -- Maintainer : Joel Bjornson joel.bjornson@gmail.com, -- Niklas Broberg nibro@cs.chalmers.se -- Stability : experimental ----------------------------------------------------------------------------- module HJScript.Objects.Date ( Date(..), -- * Get methods getDate, getDay, getMonth, getFullYear, getHours, getMinutes, getSeconds, getMilliseconds, getUTCDay, getUTCMonth, getUTCFullYear, getUTCHours, getUTCMinutes, getUTCSeconds, getUTCMilliseconds, getTime, getTimezoneOffset, getUTCDate, -- * Set methods setDate, setMonth, setFullYear, setYear, setHours, setMinutes, setSeconds, setMilliseconds, setTime, setUTCDate, setUTCMonth, setUTCFullYear, setUTCHours, setUTCMinutes, setUTCSeconds, setUTCMilliseconds, dateToString, toGMTString, toUTCString, toLocaleString ) where import HJScript.Lang data Date = Date deriving Show instance IsClass Date -- | Constructors for Date instance HasConstructor Date () () -- * Get functions getDate :: JObject Date -> JInt getDate = methodCallNoArgs "getDate" getDay :: JObject Date -> JInt getDay = methodCallNoArgs "getDay" getMonth :: JObject Date -> JInt getMonth = methodCallNoArgs "getMonth" getFullYear :: JObject Date -> JInt getFullYear = methodCallNoArgs "getFullYear" getHours :: JObject Date -> JInt getHours = methodCallNoArgs "getHours" getMinutes :: JObject Date -> JInt getMinutes = methodCallNoArgs "getMinutes" getSeconds ::JObject Date -> JInt getSeconds = methodCallNoArgs "getSeconds" getMilliseconds :: JObject Date -> JInt getMilliseconds = methodCallNoArgs "getMilliseconds" getUTCDay :: JObject Date -> JString getUTCDay = methodCallNoArgs "getUTCDay" getUTCMonth :: JObject Date -> JInt getUTCMonth = methodCallNoArgs "getUTCMonth" getUTCFullYear :: JObject Date -> JInt getUTCFullYear = methodCallNoArgs "getUTCFullYear" getUTCHours :: JObject Date -> JString getUTCHours = methodCallNoArgs "getUTCHours" getUTCMinutes :: JObject Date -> JString getUTCMinutes = methodCallNoArgs "getUTCMinutes" getUTCSeconds :: JObject Date -> JString getUTCSeconds = methodCallNoArgs "getUTCSeconds" getUTCMilliseconds :: JObject Date -> JString getUTCMilliseconds = methodCallNoArgs "getUTCMilliseconds" getTime :: JObject Date -> JString getTime = methodCallNoArgs "getTime" getTimezoneOffset :: JObject Date -> JString getTimezoneOffset = methodCallNoArgs "getTimezoneOffset" getUTCDate :: JObject Date -> JString getUTCDate = methodCallNoArgs "getUTCDate" -- * Set functions setDate :: JInt -> JObject Date -> HJScript () setDate = callVoidMethod "setDate" setMonth :: JInt -> JObject Date -> HJScript () setMonth = callVoidMethod "setMonth" setFullYear :: JInt -> JObject Date -> HJScript () setFullYear = callVoidMethod "setFullYear" setYear :: JInt -> JObject Date -> HJScript () setYear = callVoidMethod "setYear" setHours :: JInt -> JObject Date -> HJScript () setHours = callVoidMethod "setHours" setMinutes :: JInt -> JObject Date -> HJScript () setMinutes = callVoidMethod "setMinutes" setSeconds :: JInt -> JObject Date -> HJScript () setSeconds = callVoidMethod "setSeconds" setMilliseconds :: JInt -> JObject Date -> HJScript () setMilliseconds = callVoidMethod "setMilliseconds" setTime :: JInt -> JObject Date -> HJScript () setTime = callVoidMethod "setTime" setUTCDate :: JInt -> JObject Date -> HJScript () setUTCDate = callVoidMethod "setUTCDate" setUTCMonth :: JInt -> JObject Date -> HJScript () setUTCMonth = callVoidMethod "setUTCMonth" setUTCFullYear :: JInt -> JObject Date -> HJScript () setUTCFullYear = callVoidMethod "setUTCFullYear" setUTCHours :: JInt -> JObject Date -> HJScript () setUTCHours = callVoidMethod "setUTCHours" setUTCMinutes :: JInt -> JObject Date -> HJScript () setUTCMinutes = callVoidMethod "setUTCMinutes" setUTCSeconds :: JInt -> JObject Date -> HJScript () setUTCSeconds = callVoidMethod "setUTCSeconds" setUTCMilliseconds :: JInt -> JObject Date -> HJScript () setUTCMilliseconds = callVoidMethod "setUTCMilliseconds" dateToString :: JObject Date -> JString dateToString = methodCallNoArgs "toString" toGMTString :: JObject Date -> JString toGMTString = methodCallNoArgs "toGMTString" toUTCString :: JObject Date -> JString toUTCString = methodCallNoArgs "toUTCString" toLocaleString :: JObject Date -> JString toLocaleString = methodCallNoArgs "toLocaleString"