ghcjs hello world

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
-- demo: http://chrisdone.com/crap/ghcjs/test1/test.html

{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-}
module Test where

import Prelude hiding (print)
import Foreign.C.Types
import Foreign.Ptr
import Foreign.StablePtr

data JSObject
data DOMElement = DOMElement { dePtr :: Ptr JSObject, deName :: String }
instance Show DOMElement where
  show (DOMElement _ptr name) = "DOMElement " ++ name

--------------------------------------------------------------------------------
-- Making HSJS lists.

foreign import ccall "zdhszicons" -- $hs.cons
  jscons :: CChar -> Ptr JSObject -> Ptr JSObject
foreign import ccall "zdhszinil" -- $hs.nil
  jsnil :: Ptr JSObject

-- | Constructing HSJS list from HS list.
list2JSList :: Enum a => [a] -> Ptr JSObject
list2JSList [] = jsnil
list2JSList (x:xs) =
  let t = list2JSList xs
  in jscons (toEnum . fromEnum $ x) t

--------------------------------------------------------------------------------
-- Deconstructing HSJS functions to Haskell.

foreign import ccall "list_is_null"
  jsNull :: Ptr a -> IO Bool
foreign import ccall "list_head"
  jsHead :: Ptr a -> IO (Ptr a)
foreign import ccall "string_head"
  jsHeadChar :: Ptr CChar -> IO CChar
foreign import ccall "string_tail"
  jsStringTail :: Ptr CChar -> IO (Ptr CChar)
foreign import ccall "list_tail"
  jsTail :: Ptr a -> IO (Ptr a)

jsListToList :: Ptr a -> IO [Ptr a]
jsListToList list = do
  isNull <- jsNull list
  if isNull
     then return []
     else do x <- jsHead list
             rest <- jsTail list
             xs <- jsListToList rest
             return (x:xs)

jsStringToString :: Ptr CChar -> IO String
jsStringToString list = do
  isNull <- jsNull list
  if isNull
     then return []
     else do x <- jsHeadChar list
             rest <- jsStringTail list
             xs <- jsStringToString rest
             return ((toEnum.fromEnum) x : xs)

--------------------------------------------------------------------------------
-- For closure/callbacks.

foreign import ccall "mywrapper"
  mkJSCallback :: StablePtr (IO a) -> IO (FunPtr (IO a))

--------------------------------------------------------------------------------
-- Debug help.

foreign import ccall "alert"
  jsalert :: Ptr JSObject -> IO ()
foreign import ccall "console_log"
  jsconsole_log :: Ptr JSObject -> IO ()

-- | Alert some string to the user.
alert :: String -> IO ()
alert = jsalert . list2JSList

-- | Print some object in the JS console.
print :: Show a => a -> IO ()
print = jsconsole_log . list2JSList . show

--------------------------------------------------------------------------------
-- Timer functions.

foreign import ccall "setTimeout"
  jsSetTimeout :: FunPtr (IO ()) -> Int -> IO ()
foreign import ccall "setInterval"
  jsSetInterval :: FunPtr (IO ()) -> Int -> IO ()

--------------------------------------------------------------------------------
-- DOM functions.

foreign import ccall "getElementsByTagName"
  jsGetElementsByTagName :: Ptr JSObject -> IO (Ptr JSObject)
foreign import ccall "tagName"
  jsTagName :: Ptr JSObject -> IO (Ptr CChar)
foreign import ccall "jqClick"
  jqClick :: Ptr JSObject -> FunPtr (IO Bool) -> IO ()

mkDOMElement :: Ptr JSObject -> IO DOMElement
mkDOMElement el = do
  namePtr <- jsTagName el
  name <- jsStringToString namePtr
  return $ DOMElement el name

-- | Get a list of DOM elements by their tag name.
getElementsByTagName :: String -> IO [DOMElement]
getElementsByTagName name = do
  els <- (>>= jsListToList) $ jsGetElementsByTagName $ list2JSList $ name
  mapM mkDOMElement els

-- | Get a list of DOM elements by their tag name.
click :: DOMElement -> IO Bool -> IO ()
click (DOMElement{dePtr}) m = do
  haskellClosure <- newStablePtr m
  jsFunction <- mkJSCallback haskellClosure
  jqClick dePtr jsFunction

--------------------------------------------------------------------------------
-- Demo.

main :: IO ()
main = do
  els <- getElementsByTagName "body"
  case els of
    (body:_) -> click body $ do
      alert "'Ello, World!"
      return False
    _ -> return ()
27:1: Warning: Use foldr
Found:
list2JSList [] = jsnil
list2JSList (x : xs)
= let t = list2JSList xs in jscons (toEnum . fromEnum $ x) t
Why not:
list2JSList xs
= foldr (\ x -> jscons (toEnum . fromEnum $ x)) jsnil xs
115:56: Warning: Redundant $
Found:
list2JSList $ name
Why not:
list2JSList name