HJScript 0.4 → 0.4.4
raw patch · 51 files changed
+2809/−2505 lines, 51 filesdep ~HJavaScriptdep ~hsx
Dependency ranges changed: HJavaScript, hsx
Files
- HJScript.cabal +18/−15
- HJScript.hs +0/−35
- HJScript/Ajax.hs +0/−209
- HJScript/DOM.hs +0/−29
- HJScript/DOM/AttributeNode.hs +0/−36
- HJScript/DOM/Document.hs +0/−125
- HJScript/DOM/ElementNode.hs +0/−152
- HJScript/DOM/NamedNodeMap.hs +0/−32
- HJScript/DOM/Node.hs +0/−64
- HJScript/DOM/NodeTypes.hs +0/−105
- HJScript/DOM/TextNode.hs +0/−58
- HJScript/DOM/Window.hs +0/−127
- HJScript/DOM/XHTML.hs +0/−247
- HJScript/Events.hs +0/−81
- HJScript/Lang.hs +0/−331
- HJScript/Monad.hs +0/−117
- HJScript/Objects/ActiveXObject.hs +0/−28
- HJScript/Objects/Array.hs +0/−74
- HJScript/Objects/Boolean.hs +0/−34
- HJScript/Objects/Date.hs +0/−186
- HJScript/Objects/Math.hs +0/−92
- HJScript/Objects/RegExp.hs +0/−38
- HJScript/Objects/String.hs +0/−89
- HJScript/Objects/XMLHttpRequest.hs +0/−70
- HJScript/XMLGenerator.hs +0/−131
- src/HJScript.hs +35/−0
- src/HJScript/Ajax.hs +209/−0
- src/HJScript/DOM.hs +29/−0
- src/HJScript/DOM/AttributeNode.hs +36/−0
- src/HJScript/DOM/Document.hs +125/−0
- src/HJScript/DOM/ElementNode.hs +133/−0
- src/HJScript/DOM/NamedNodeMap.hs +32/−0
- src/HJScript/DOM/Node.hs +64/−0
- src/HJScript/DOM/NodeTypes.hs +105/−0
- src/HJScript/DOM/TextNode.hs +58/−0
- src/HJScript/DOM/Window.hs +127/−0
- src/HJScript/DOM/XHTML.hs +256/−0
- src/HJScript/Events.hs +81/−0
- src/HJScript/Lang.hs +363/−0
- src/HJScript/Monad.hs +124/−0
- src/HJScript/Objects/ActiveXObject.hs +28/−0
- src/HJScript/Objects/Array.hs +77/−0
- src/HJScript/Objects/Boolean.hs +34/−0
- src/HJScript/Objects/Date.hs +186/−0
- src/HJScript/Objects/JQuery.hs +75/−0
- src/HJScript/Objects/Math.hs +92/−0
- src/HJScript/Objects/RegExp.hs +38/−0
- src/HJScript/Objects/String.hs +89/−0
- src/HJScript/Objects/XMLHttpRequest.hs +70/−0
- src/HJScript/Utils.hs +211/−0
- src/HJScript/XMLGenerator.hs +114/−0
HJScript.cabal view
@@ -1,13 +1,13 @@ Name: HJScript-Version: 0.4+Version: 0.4.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 +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. @@ -15,10 +15,12 @@ as defined by the hsx package, for creating DOM ElementNodes. Also notable is that HJScript supports Ajax functionality. +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.RegExp@@ -26,24 +28,25 @@ 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.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+ HJScript.Utils+Other-Modules: HJScript.Monad -Build-Depends: base, HJavaScript, mtl, hsx-Build-Type: Simple-Category: Web, Language+Build-Depends: base, HJavaScript >= 0.4.4, mtl, hsx >= 0.4.4+Build-Type: Simple+Category: Web, Language Extensions: MultiParamTypeClasses, TypeFamilies,
− HJScript.hs
@@ -1,35 +0,0 @@-{-# 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
@@ -1,209 +0,0 @@-{-# 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
@@ -1,29 +0,0 @@------------------------------------------------------------------------------ --- | --- 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
@@ -1,36 +0,0 @@-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
@@ -1,125 +0,0 @@------------------------------------------------------------------------------ --- | --- 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
@@ -1,152 +0,0 @@------------------------------------------------------------------------------ --- | --- 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
@@ -1,32 +0,0 @@-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
@@ -1,64 +0,0 @@-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
@@ -1,105 +0,0 @@------------------------------------------------------------------------------ --- | --- 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
@@ -1,58 +0,0 @@-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
@@ -1,127 +0,0 @@------------------------------------------------------------------------------ --- | --- 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
@@ -1,247 +0,0 @@------------------------------------------------------------------------------ --- | --- 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
@@ -1,81 +0,0 @@--------------------------------------------------------------------------------- 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
@@ -1,331 +0,0 @@-{-# 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
@@ -1,117 +0,0 @@-{-# 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
@@ -1,28 +0,0 @@-{-# 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
@@ -1,74 +0,0 @@-{-# 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
@@ -1,34 +0,0 @@-{-# 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
@@ -1,186 +0,0 @@-{-# 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
@@ -1,92 +0,0 @@-{-# 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
@@ -1,38 +0,0 @@-{-# 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
@@ -1,89 +0,0 @@-{-# 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
@@ -1,70 +0,0 @@-{-# 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
@@ -1,131 +0,0 @@-{-# 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
+ src/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
+ src/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
+ src/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
+ src/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"
+ src/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"
+ src/HJScript/DOM/ElementNode.hs view
@@ -0,0 +1,133 @@+----------------------------------------------------------------------------- +-- | +-- 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"
+ src/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"
+ src/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" +
+ src/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
+ src/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"
+ src/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" +-}
+ src/HJScript/DOM/XHTML.hs view
@@ -0,0 +1,256 @@+----------------------------------------------------------------------------- +-- | +-- 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 + +----------------------------------- +-- 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++-- 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
+ src/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++-}
+ src/HJScript/Lang.hs view
@@ -0,0 +1,363 @@+{-# 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+ this, callMethod, callVoidMethod, callProc,+ + -- Functions and declarations+ function, procedure, functionDecl, procedureDecl,+ + -- Control flow+ for, while, doWhile, doIf, doElse, doIfElse, doIfNoElse, noElse,+ + -- Objects+ var, varWith, inVar, new ,( # ), ( #. ),+ 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+ +-- | 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 ++-- | 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
+ src/HJScript/Monad.hs view
@@ -0,0 +1,124 @@+{-# 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,+ 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
+ src/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"
+ src/HJScript/Objects/Array.hs view
@@ -0,0 +1,77 @@+{-# 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, 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
+ src/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"
+ src/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"
+ src/HJScript/Objects/JQuery.hs view
@@ -0,0 +1,75 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+{-# OPTIONS_GHC -fallow-overlapping-instances #-} +{-# OPTIONS_GHC -fallow-undecidable-instances #-}+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+
+ src/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"
+ src/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"
+ src/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)
+ src/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"
+ src/HJScript/Utils.hs view
@@ -0,0 +1,211 @@+----------------------------------------------------------------------------- +-- | +-- 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"
+ src/HJScript/XMLGenerator.hs view
@@ -0,0 +1,114 @@+{-# 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 (XMLGen(..)) +import HSX.XMLGenerator hiding (XMLGen(..)) +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.XMLGen HJScript' where + type HSX.XML HJScript' = XML + newtype HSX.Child HJScript' = HJSChild Child + newtype HSX.Attribute HJScript' = HJSAttr Attribute + genElement = element + genEElement = eElement + xmlToChild = HJSChild . castToNode + +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 . HSX.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