diff --git a/HJScript.cabal b/HJScript.cabal --- a/HJScript.cabal +++ b/HJScript.cabal @@ -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, diff --git a/HJScript.hs b/HJScript.hs deleted file mode 100644 --- a/HJScript.hs +++ /dev/null @@ -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 diff --git a/HJScript/Ajax.hs b/HJScript/Ajax.hs deleted file mode 100644 --- a/HJScript/Ajax.hs +++ /dev/null @@ -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 diff --git a/HJScript/DOM.hs b/HJScript/DOM.hs deleted file mode 100644 --- a/HJScript/DOM.hs +++ /dev/null @@ -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 diff --git a/HJScript/DOM/AttributeNode.hs b/HJScript/DOM/AttributeNode.hs deleted file mode 100644 --- a/HJScript/DOM/AttributeNode.hs +++ /dev/null @@ -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" diff --git a/HJScript/DOM/Document.hs b/HJScript/DOM/Document.hs deleted file mode 100644 --- a/HJScript/DOM/Document.hs +++ /dev/null @@ -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" diff --git a/HJScript/DOM/ElementNode.hs b/HJScript/DOM/ElementNode.hs deleted file mode 100644 --- a/HJScript/DOM/ElementNode.hs +++ /dev/null @@ -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" diff --git a/HJScript/DOM/NamedNodeMap.hs b/HJScript/DOM/NamedNodeMap.hs deleted file mode 100644 --- a/HJScript/DOM/NamedNodeMap.hs +++ /dev/null @@ -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" diff --git a/HJScript/DOM/Node.hs b/HJScript/DOM/Node.hs deleted file mode 100644 --- a/HJScript/DOM/Node.hs +++ /dev/null @@ -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" - diff --git a/HJScript/DOM/NodeTypes.hs b/HJScript/DOM/NodeTypes.hs deleted file mode 100644 --- a/HJScript/DOM/NodeTypes.hs +++ /dev/null @@ -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 diff --git a/HJScript/DOM/TextNode.hs b/HJScript/DOM/TextNode.hs deleted file mode 100644 --- a/HJScript/DOM/TextNode.hs +++ /dev/null @@ -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" diff --git a/HJScript/DOM/Window.hs b/HJScript/DOM/Window.hs deleted file mode 100644 --- a/HJScript/DOM/Window.hs +++ /dev/null @@ -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" --} diff --git a/HJScript/DOM/XHTML.hs b/HJScript/DOM/XHTML.hs deleted file mode 100644 --- a/HJScript/DOM/XHTML.hs +++ /dev/null @@ -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 diff --git a/HJScript/Events.hs b/HJScript/Events.hs deleted file mode 100644 --- a/HJScript/Events.hs +++ /dev/null @@ -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 - --} diff --git a/HJScript/Lang.hs b/HJScript/Lang.hs deleted file mode 100644 --- a/HJScript/Lang.hs +++ /dev/null @@ -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 diff --git a/HJScript/Monad.hs b/HJScript/Monad.hs deleted file mode 100644 --- a/HJScript/Monad.hs +++ /dev/null @@ -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 diff --git a/HJScript/Objects/ActiveXObject.hs b/HJScript/Objects/ActiveXObject.hs deleted file mode 100644 --- a/HJScript/Objects/ActiveXObject.hs +++ /dev/null @@ -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" diff --git a/HJScript/Objects/Array.hs b/HJScript/Objects/Array.hs deleted file mode 100644 --- a/HJScript/Objects/Array.hs +++ /dev/null @@ -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 diff --git a/HJScript/Objects/Boolean.hs b/HJScript/Objects/Boolean.hs deleted file mode 100644 --- a/HJScript/Objects/Boolean.hs +++ /dev/null @@ -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" diff --git a/HJScript/Objects/Date.hs b/HJScript/Objects/Date.hs deleted file mode 100644 --- a/HJScript/Objects/Date.hs +++ /dev/null @@ -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" diff --git a/HJScript/Objects/Math.hs b/HJScript/Objects/Math.hs deleted file mode 100644 --- a/HJScript/Objects/Math.hs +++ /dev/null @@ -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" diff --git a/HJScript/Objects/RegExp.hs b/HJScript/Objects/RegExp.hs deleted file mode 100644 --- a/HJScript/Objects/RegExp.hs +++ /dev/null @@ -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" diff --git a/HJScript/Objects/String.hs b/HJScript/Objects/String.hs deleted file mode 100644 --- a/HJScript/Objects/String.hs +++ /dev/null @@ -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) diff --git a/HJScript/Objects/XMLHttpRequest.hs b/HJScript/Objects/XMLHttpRequest.hs deleted file mode 100644 --- a/HJScript/Objects/XMLHttpRequest.hs +++ /dev/null @@ -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" diff --git a/HJScript/XMLGenerator.hs b/HJScript/XMLGenerator.hs deleted file mode 100644 --- a/HJScript/XMLGenerator.hs +++ /dev/null @@ -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 diff --git a/src/HJScript.hs b/src/HJScript.hs new file mode 100644 --- /dev/null +++ b/src/HJScript.hs @@ -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 diff --git a/src/HJScript/Ajax.hs b/src/HJScript/Ajax.hs new file mode 100644 --- /dev/null +++ b/src/HJScript/Ajax.hs @@ -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 diff --git a/src/HJScript/DOM.hs b/src/HJScript/DOM.hs new file mode 100644 --- /dev/null +++ b/src/HJScript/DOM.hs @@ -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 diff --git a/src/HJScript/DOM/AttributeNode.hs b/src/HJScript/DOM/AttributeNode.hs new file mode 100644 --- /dev/null +++ b/src/HJScript/DOM/AttributeNode.hs @@ -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" diff --git a/src/HJScript/DOM/Document.hs b/src/HJScript/DOM/Document.hs new file mode 100644 --- /dev/null +++ b/src/HJScript/DOM/Document.hs @@ -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" diff --git a/src/HJScript/DOM/ElementNode.hs b/src/HJScript/DOM/ElementNode.hs new file mode 100644 --- /dev/null +++ b/src/HJScript/DOM/ElementNode.hs @@ -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" diff --git a/src/HJScript/DOM/NamedNodeMap.hs b/src/HJScript/DOM/NamedNodeMap.hs new file mode 100644 --- /dev/null +++ b/src/HJScript/DOM/NamedNodeMap.hs @@ -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" diff --git a/src/HJScript/DOM/Node.hs b/src/HJScript/DOM/Node.hs new file mode 100644 --- /dev/null +++ b/src/HJScript/DOM/Node.hs @@ -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" + diff --git a/src/HJScript/DOM/NodeTypes.hs b/src/HJScript/DOM/NodeTypes.hs new file mode 100644 --- /dev/null +++ b/src/HJScript/DOM/NodeTypes.hs @@ -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 diff --git a/src/HJScript/DOM/TextNode.hs b/src/HJScript/DOM/TextNode.hs new file mode 100644 --- /dev/null +++ b/src/HJScript/DOM/TextNode.hs @@ -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" diff --git a/src/HJScript/DOM/Window.hs b/src/HJScript/DOM/Window.hs new file mode 100644 --- /dev/null +++ b/src/HJScript/DOM/Window.hs @@ -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" +-} diff --git a/src/HJScript/DOM/XHTML.hs b/src/HJScript/DOM/XHTML.hs new file mode 100644 --- /dev/null +++ b/src/HJScript/DOM/XHTML.hs @@ -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 diff --git a/src/HJScript/Events.hs b/src/HJScript/Events.hs new file mode 100644 --- /dev/null +++ b/src/HJScript/Events.hs @@ -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 + +-} diff --git a/src/HJScript/Lang.hs b/src/HJScript/Lang.hs new file mode 100644 --- /dev/null +++ b/src/HJScript/Lang.hs @@ -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 diff --git a/src/HJScript/Monad.hs b/src/HJScript/Monad.hs new file mode 100644 --- /dev/null +++ b/src/HJScript/Monad.hs @@ -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 diff --git a/src/HJScript/Objects/ActiveXObject.hs b/src/HJScript/Objects/ActiveXObject.hs new file mode 100644 --- /dev/null +++ b/src/HJScript/Objects/ActiveXObject.hs @@ -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" diff --git a/src/HJScript/Objects/Array.hs b/src/HJScript/Objects/Array.hs new file mode 100644 --- /dev/null +++ b/src/HJScript/Objects/Array.hs @@ -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 diff --git a/src/HJScript/Objects/Boolean.hs b/src/HJScript/Objects/Boolean.hs new file mode 100644 --- /dev/null +++ b/src/HJScript/Objects/Boolean.hs @@ -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" diff --git a/src/HJScript/Objects/Date.hs b/src/HJScript/Objects/Date.hs new file mode 100644 --- /dev/null +++ b/src/HJScript/Objects/Date.hs @@ -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" diff --git a/src/HJScript/Objects/JQuery.hs b/src/HJScript/Objects/JQuery.hs new file mode 100644 --- /dev/null +++ b/src/HJScript/Objects/JQuery.hs @@ -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 + diff --git a/src/HJScript/Objects/Math.hs b/src/HJScript/Objects/Math.hs new file mode 100644 --- /dev/null +++ b/src/HJScript/Objects/Math.hs @@ -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" diff --git a/src/HJScript/Objects/RegExp.hs b/src/HJScript/Objects/RegExp.hs new file mode 100644 --- /dev/null +++ b/src/HJScript/Objects/RegExp.hs @@ -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" diff --git a/src/HJScript/Objects/String.hs b/src/HJScript/Objects/String.hs new file mode 100644 --- /dev/null +++ b/src/HJScript/Objects/String.hs @@ -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) diff --git a/src/HJScript/Objects/XMLHttpRequest.hs b/src/HJScript/Objects/XMLHttpRequest.hs new file mode 100644 --- /dev/null +++ b/src/HJScript/Objects/XMLHttpRequest.hs @@ -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" diff --git a/src/HJScript/Utils.hs b/src/HJScript/Utils.hs new file mode 100644 --- /dev/null +++ b/src/HJScript/Utils.hs @@ -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" diff --git a/src/HJScript/XMLGenerator.hs b/src/HJScript/XMLGenerator.hs new file mode 100644 --- /dev/null +++ b/src/HJScript/XMLGenerator.hs @@ -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