HJScript (empty) → 0.4

raw patch · 26 files changed

+2546/−0 lines, 26 filesdep +HJavaScriptdep +basedep +hsxsetup-changed

Dependencies added: HJavaScript, base, hsx, mtl

Files

HJScript.cabal +54/−0
HJScript.hs +35/−0
HJScript/Ajax.hs +209/−0
HJScript/DOM.hs +29/−0
HJScript/DOM/AttributeNode.hs +36/−0
HJScript/DOM/Document.hs +125/−0
HJScript/DOM/ElementNode.hs +152/−0
HJScript/DOM/NamedNodeMap.hs +32/−0
HJScript/DOM/Node.hs +64/−0
HJScript/DOM/NodeTypes.hs +105/−0
HJScript/DOM/TextNode.hs +58/−0
HJScript/DOM/Window.hs +127/−0
HJScript/DOM/XHTML.hs +247/−0
HJScript/Events.hs +81/−0
HJScript/Lang.hs +331/−0
HJScript/Monad.hs +117/−0
HJScript/Objects/ActiveXObject.hs +28/−0
HJScript/Objects/Array.hs +74/−0
HJScript/Objects/Boolean.hs +34/−0
HJScript/Objects/Date.hs +186/−0
HJScript/Objects/Math.hs +92/−0
HJScript/Objects/RegExp.hs +38/−0
HJScript/Objects/String.hs +89/−0
HJScript/Objects/XMLHttpRequest.hs +70/−0
HJScript/XMLGenerator.hs +131/−0
Setup.hs +2/−0

+ HJScript.cabal view

@@ -0,0 +1,54 @@+Name:             HJScript+Version:          0.4+License:          BSD3+Author:           Joel Bjornson, joel.bjornson@gmail.com,+                  Niklas Broberg, nibro@cs.chalmers.se+Maintainer:       joel.bjornson@gmail.com,+                  nibro@cs.chalmers.se++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.++Exposed-Modules:  HJScript,+                  HJScript.Lang,+                  HJScript.Objects.Array+                  HJScript.Objects.Boolean+                  HJScript.Objects.Date+                  HJScript.Objects.Math+                  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+Other-Modules:	  HJScript.Monad++                  +Build-Depends:    base, HJavaScript, mtl, hsx+Build-Type:	  Simple+Category:	  Web, Language++Extensions:             MultiParamTypeClasses,+                        TypeFamilies,+                        FlexibleContexts,+                        FlexibleInstances,+                        TypeSynonymInstances,+                        OverlappingInstances,+                        UndecidableInstances

+ HJScript.hs view

@@ -0,0 +1,35 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+{-# OPTIONS_GHC -fallow-overlapping-instances #-}
+{-# OPTIONS_GHC -fallow-undecidable-instances #-}+-----------------------------------------------------------------------------
+-- |
+-- Module      :  HJScript
+-- License     :  BSD-style
+-- Maintainer  :  Joel Bjornson joel.bjornson@gmail.com+--                Niklas Broberg nibro@cs.chalmers.se
+-- Stability   :  experimental
+-----------------------------------------------------------------------------+module HJScript+  (+    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.RegExp,+    module HJScript.Objects.String+  ) where++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.RegExp+import HJScript.Objects.String

+ HJScript/Ajax.hs view

@@ -0,0 +1,209 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+{-# OPTIONS_GHC -fallow-overlapping-instances #-}
+{-# OPTIONS_GHC -fallow-undecidable-instances #-}+-----------------------------------------------------------------------------+-- 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/DOM.hs view

@@ -0,0 +1,29 @@+-----------------------------------------------------------------------------
+-- |
+-- 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/DOM/AttributeNode.hs view

@@ -0,0 +1,36 @@+module 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/DOM/Document.hs view

@@ -0,0 +1,125 @@+-----------------------------------------------------------------------------
+-- |
+-- 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/DOM/ElementNode.hs view

@@ -0,0 +1,152 @@+-----------------------------------------------------------------------------
+-- |
+-- 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, +  +    -- 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
++----------------------------------------------------+-- Variable properties+----------------------------------------------------+{- Most of these are undefined on Elements, why are they here?
+
+className :: IsElementNode n => Exp n -> Var String+className = derefElemVar "className"++border :: IsElementNode n => Exp n -> Var Int+border = derefElemVar "border"++href :: IsElementNode n => Exp n -> Var String+href = derefElemVar "href"++domId :: IsElementNode n => Exp n -> Var String+domId = derefElemVar "id"++lang :: IsElementNode n => Exp n -> Var String+lang = derefElemVar "lang"++longDesc :: IsElementNode n => Exp n -> Var String+longDesc = derefElemVar "longDesc"++src :: IsElementNode n => Exp n -> Var String +src = derefElemVar "src"++target :: IsElementNode o => Exp o -> Var String+target = derefElemVar "target"++title ::  IsElementNode o => Exp o -> Var String+title = derefElemVar "title"+-}
+
+----------------------------------------------------+-- 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"
+
+----------------------------------------------------+-- 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/DOM/NamedNodeMap.hs view

@@ -0,0 +1,32 @@+module 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/DOM/Node.hs view

@@ -0,0 +1,64 @@+module 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/DOM/NodeTypes.hs view

@@ -0,0 +1,105 @@+-----------------------------------------------------------------------------
+-- |
+-- 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/DOM/TextNode.hs view

@@ -0,0 +1,58 @@+module 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/DOM/Window.hs view

@@ -0,0 +1,127 @@+-----------------------------------------------------------------------------
+-- |
+-- 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/DOM/XHTML.hs view

@@ -0,0 +1,247 @@+-----------------------------------------------------------------------------
+-- |
+-- 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, 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
+
+-----------------------------------
+-- Class gathering all standard methods
+
+class IsElementNode a => IsXHTMLElement a
+
+-- 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++-- Object+data Object = Object deriving Show+instance IsClass Object++-- 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/Events.hs view

@@ -0,0 +1,81 @@+-----------------------------------------------------------------------------+-- 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/Lang.hs view

@@ -0,0 +1,331 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+{-# OPTIONS_GHC -fallow-overlapping-instances #-}
+{-# OPTIONS_GHC -fallow-undecidable-instances #-}+-----------------------------------------------------------------------------
+-- |
+-- 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+    callMethod, callVoidMethod,+    +    -- Functions and declarations+    function, procedure, functionDecl, procedureDecl, call,+    +    -- Control flow+    for, while, doWhile, doIf, doElse, doIfElse, doIfNoElse, noElse,+    +    -- Objects+    var, varWith, inVar, new ,( # ), ( #. ),+    +    -- Helpers    +    ( #! ) , jnull, jShow, castObject, hasFeature, +    break, continue, true ,ifOp, false, int, float, bool, string,+
+    -- Re-exports from internal module HJScript.Monad+    HJScript, IsHJScript(..), 
+    evalHJScript, runHJScript,
+    outputBlock, outputStmt,
+    
+    -- Re-export all of Language.HJavaScript.Syntax
+    module Language.HJavaScript.Syntax
+
+  )  where++import Language.HJavaScript.Syntax+import HJScript.Monad+import Prelude hiding (null, 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+    +-- | 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 =>+            (a -> HJScript (Exp r)) ->  HJScript (Exp (t -> r))+function fun = do +  let args = mkFParams fun+  let script = fun args+  (ret, body) <-  hjsInside script+  let body' = addReturn ret body+  return $ JFunction Nothing args body'++-- | Anonymous void function.+procedure :: FormalParams a t => +             (a -> HJScript ()) -> HJScript (Exp (t -> ()))+procedure fun = do+  let args = mkFParams fun+  body <- return . snd =<< (hjsInside $ fun args)+  return $ JFunction Nothing args body++-- | Function declaration+functionDecl :: FormalParams a t =>+                String -> (a -> HJScript (Exp r)) -> HJScript ()+functionDecl name fun = do+  let args = mkFParams fun+  let script = fun args+  (ret,body) <- hjsInside script+  let body' = addReturn ret body+  outputStmt $ ExpStmt $ JFunction (Just name) args body'+   +-- | Procedure declaration.+procedureDecl ::  FormalParams a t =>  +                  String -> (a -> HJScript ()) -> HJScript ()++procedureDecl name fun = do+  let args = mkFParams fun+  let script = fun 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)++-- | Calling a function.+call :: (Args e t) => Exp (t -> t1) -> e -> HJScript ()+call e = outputStmt . ExpStmt . (JCall e)++-----------------------------------------------------------+-- 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 and objects+-----------------------------------------------------------+-- 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
++-- Create new Objects.+new ::  (HasConstructor o e t, Args e t) => o -> e -> HJScript (Exp o)+new o = fmap val . varWith . JNew o                     ++-- | 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 (.) ++-----------------------------------------------------------+-- 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/Monad.hs view

@@ -0,0 +1,117 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+{-# OPTIONS_GHC -fallow-overlapping-instances #-}
+{-# OPTIONS_GHC -fallow-undecidable-instances #-}+-----------------------------------------------------------------------------
+-- |
+-- 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,+    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 initState++-- | 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 -> HJState -> (t, Block ())+evalHJScript m = runWriter . evalStateT (unXMLGenT m)++-- | 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 name+newVarName :: HJScript String+newVarName = lift $ do+  n <- get+  put $ n + 1+  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/Objects/ActiveXObject.hs view

@@ -0,0 +1,28 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+{-# OPTIONS_GHC -fallow-overlapping-instances #-}
+{-# OPTIONS_GHC -fallow-undecidable-instances #-}+-----------------------------------------------------------------------------
+-- 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/Objects/Array.hs view

@@ -0,0 +1,74 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+{-# OPTIONS_GHC -fallow-overlapping-instances #-}
+{-# OPTIONS_GHC -fallow-undecidable-instances #-}+-----------------------------------------------------------------------------
+-- |
+-- 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, mapArray, mapArrayH, mapArrayH_, foreach, filterArray+    +  ) where+  +import HJScript.Lang++-- | Constructors for Array+instance HasConstructor (Array t) () ()+instance HasConstructor (Array t) (JInt) Int++-- | 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 1) (arrLength arr) $ \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 1) (arrLength arr) $ \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 1) (arrLength arr) $  \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/Objects/Boolean.hs view

@@ -0,0 +1,34 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+{-# OPTIONS_GHC -fallow-overlapping-instances #-}
+{-# OPTIONS_GHC -fallow-undecidable-instances #-}+-----------------------------------------------------------------------------+-- |
+-- 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/Objects/Date.hs view

@@ -0,0 +1,186 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+{-# OPTIONS_GHC -fallow-overlapping-instances #-}
+{-# OPTIONS_GHC -fallow-undecidable-instances #-}+-----------------------------------------------------------------------------+-- |
+-- 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"

+ HJScript/Objects/Math.hs view

@@ -0,0 +1,92 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+{-# OPTIONS_GHC -fallow-overlapping-instances #-}
+{-# OPTIONS_GHC -fallow-undecidable-instances #-}+-----------------------------------------------------------------------------+-- |
+-- 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/Objects/RegExp.hs view

@@ -0,0 +1,38 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+{-# OPTIONS_GHC -fallow-overlapping-instances #-}
+{-# OPTIONS_GHC -fallow-undecidable-instances #-}+-----------------------------------------------------------------------------+-- |
+-- 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/Objects/String.hs view

@@ -0,0 +1,89 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+{-# OPTIONS_GHC -fallow-overlapping-instances #-}
+{-# OPTIONS_GHC -fallow-undecidable-instances #-}+-----------------------------------------------------------------------------+-- |
+-- 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/Objects/XMLHttpRequest.hs view

@@ -0,0 +1,70 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+{-# OPTIONS_GHC -fallow-overlapping-instances #-}
+{-# OPTIONS_GHC -fallow-undecidable-instances #-}+-----------------------------------------------------------------------------
+-- 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/XMLGenerator.hs view

@@ -0,0 +1,131 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+{-# OPTIONS_GHC -fallow-overlapping-instances #-}
+{-# OPTIONS_GHC -fallow-undecidable-instances #-}++module HJScript.XMLGenerator (
+        ToChildNodes(..), ToAttributeNode(..),
+        
+        genElement, genEElement, asChild, asAttr, Attr(..)
+        ) where
+
+import qualified HSX.XMLGenerator as HSX (XMLGenerator(..))
+import HSX.XMLGenerator hiding (XMLGenerator(..))
+import HSX.XMLGenerator (genElement, genEElement)
+
+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 HSX.XMLGenerator HJScript' where
+ type HSX.XML       HJScript' = XML
+ type HSX.Child     HJScript' = Child
+ type HSX.Attribute HJScript' = Attribute
+ genElement = element
+ genEElement = eElement
+
+element :: Name -> [(HJScript Attribute)] -> [(HJScript [Child])] -> 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 <- toChildNodes xmls
+  ats  <- mapM toAttributeNode atts
+  mapM (\attr  -> elem # setAttributeNode attr) ats
+  mapM (\child -> elem # appendChild child) cxml
+  return elem
+
+eElement :: Name -> [(HJScript Attribute)] -> HJScript (Exp ElementNode)
+eElement n attrs = element n attrs []
+
+class ToChildNodes a where
+ toChildNodes :: a -> HJScript [Child]
+
+instance ToChildNodes a => EmbedAsChild a (HJScript [Child]) where
+ asChild = toChildNodes
+
+instance ToChildNodes Child where
+ toChildNodes node = return [node]
+
+instance ToChildNodes XML where
+ toChildNodes xml = return [castToNode xml]
+
+instance ToChildNodes a => ToChildNodes [a] where
+ toChildNodes as = do
+   xss <- mapM toChildNodes as
+   return $ concat xss
+
+instance ToChildNodes JString where
+ toChildNodes str = return [castToNode $ document # createTextNode str]
+ 
+instance ToChildNodes String where
+ toChildNodes = toChildNodes . string
+
+instance (ToChildNodes x, TypeCast (m x) (HJScript' x)) => ToChildNodes (XMLGenT m x) where
+ toChildNodes (XMLGenT x) = (XMLGenT $ typeCast x) >>= toChildNodes
+
+
+class ToAttributeNode a where
+ toAttributeNode :: a -> HJScript Attribute
+
+instance ToAttributeNode a => EmbedAsAttr a (HJScript Attribute) where
+ asAttr = toAttributeNode
+
+instance ToAttributeNode Attribute where
+ toAttributeNode = return
+
+instance (IsName n, IsAttrNodeValue a) => ToAttributeNode (Attr n a) where
+ toAttributeNode (k := a) = do
+   let (ns,ln) = toName k
+       name    = (maybe id (\x y -> y ++ ':':x) ns) ln
+   v  <- toAttrNodeValue a
+   an <- fmap val $ varWith $ document # createAttribute (string name)
+   an # value .=. v
+   return an
+
+instance ToAttributeNode a => ToAttributeNode (HJScript a) where
+ toAttributeNode = (>>= toAttributeNode)
+
+
+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) as
+        return ev
+
+instance TypeCast (m x) (HJScript' XML) => 
+        SetAttr HJScript' (XMLGenT m x) where
+ setAll (XMLGenT hjen) ats = (XMLGenT $ typeCast hjen) >>= (flip setAll) ats
+
+
+instance AppendChild HJScript' XML where
+ appAll en cns = do
+        ev <- inVar en
+        cs <- cns
+        mapM (\child -> ev # appendChild child) cs
+        return ev
+
+instance TypeCast (m x) (HJScript' XML) =>
+        AppendChild HJScript' (XMLGenT m x) where
+ appAll (XMLGenT hjen) chs = (XMLGenT $ typeCast hjen) >>= (flip appAll) chs

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain