├── multiple-pages
    ├── .gitignore
    ├── Setup.lhs
    ├── data
    │   ├── main.js
    │   ├── hamlet.html
    │   ├── primes.html
    │   └── index.html
    ├── multiple-pages.cabal
    └── src
    │   └── Main.hs
├── fay-hello
    ├── js
    │   ├── Setup.hs
    │   ├── fay-hello-js.cabal
    │   ├── LICENSE
    │   └── Main.hs
    ├── install-integrated.sh
    ├── install-standalone.sh
    ├── Setup.lhs
    ├── fay-hello.cabal
    └── src
    │   └── Main.hs
├── try-purescript
    ├── Setup.hs
    ├── data
    │   ├── busy.gif
    │   ├── run_button.png
    │   └── tryps.css
    ├── codemirror
    │   ├── theme
    │   │   └── elegant.css
    │   ├── LICENSE
    │   ├── addon
    │   │   └── edit
    │   │   │   └── matchbrackets.js
    │   ├── lib
    │   │   └── codemirror.css
    │   └── mode
    │   │   └── haskell
    │   │       └── haskell.js
    ├── LICENSE
    ├── try-purescript.cabal
    ├── prepare.sh
    ├── README.markdown
    ├── Main.hs
    └── jsbits
    │   └── tryps.js
├── weblog
    ├── hello
    │   └── hello.hs
    ├── balls1
    │   ├── ball.png
    │   ├── balls1.html
    │   └── balls1.hs
    ├── balls2
    │   ├── ball.png
    │   ├── balls2.html
    │   └── balls2.hs
    ├── event
    │   ├── event.hs
    │   └── event.html
    ├── ffi
    │   └── ffi.hs
    ├── fibonacci
    │   └── fibonacci.hs
    ├── mouse
    │   ├── mouse.html
    │   └── mouse.hs
    ├── counter
    │   ├── counter.html
    │   └── counter.hs
    ├── calculator
    │   ├── calculator.html
    │   └── calculator.hs
    ├── sync
    │   ├── sync.hs
    │   └── sync.html
    ├── race
    │   ├── race.hs
    │   └── race.html
    └── build.sh
├── sources.txt
├── .gitignore
├── mloc-js
    ├── Setup.lhs
    ├── mloc-js.cabal
    └── src
    │   ├── Demo
    │       ├── LazyLoading.hs
    │       ├── DOM.hs
    │       ├── JavaScriptFFI.hs
    │       ├── Threading.hs
    │       └── Life.hs
    │   ├── WebKitUtils.hs
    │   └── Main.hs
├── ghcjs-hello
    ├── Setup.lhs
    ├── ghcjs-hello.cabal
    └── src
    │   └── Main.hs
├── webkit-hello
    ├── Setup.lhs
    ├── webkit-hello.cabal
    └── src
    │   └── Main.hs
├── webkit-sodium
    ├── Setup.lhs
    ├── webkit-sodium.cabal
    └── src
    │   ├── Game.hs
    │   ├── Main.hs
    │   ├── Engine.hs
    │   └── Freecell.hs
├── travis
    └── gtk.sh
├── .travis.yml
├── threads
    └── threads.hs
└── README.md


/multiple-pages/.gitignore:
--------------------------------------------------------------------------------
1 | /*.lkshf
2 | 


--------------------------------------------------------------------------------
/fay-hello/js/Setup.hs:
--------------------------------------------------------------------------------
1 | import Distribution.Simple
2 | main = defaultMain
3 | 


--------------------------------------------------------------------------------
/try-purescript/Setup.hs:
--------------------------------------------------------------------------------
1 | import Distribution.Simple
2 | main = defaultMain
3 | 


--------------------------------------------------------------------------------
/weblog/hello/hello.hs:
--------------------------------------------------------------------------------
1 | module Main where
2 | 
3 | main = putStrLn "Hello World!"
4 | 


--------------------------------------------------------------------------------
/sources.txt:
--------------------------------------------------------------------------------
1 | ./ghcjs-hello
2 | ./multiple-pages
3 | ./webkit-sodium
4 | ./mloc-js
5 | 
6 | 


--------------------------------------------------------------------------------
/.gitignore:
--------------------------------------------------------------------------------
1 | dist
2 | cabal-dev
3 | *.o
4 | *.hi
5 | *.chi
6 | *.chs.h
7 | /.shelly/
8 | /gtk2hs/
9 | 


--------------------------------------------------------------------------------
/weblog/balls1/ball.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/ghcjs/ghcjs-examples/HEAD/weblog/balls1/ball.png


--------------------------------------------------------------------------------
/weblog/balls2/ball.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/ghcjs/ghcjs-examples/HEAD/weblog/balls2/ball.png


--------------------------------------------------------------------------------
/fay-hello/install-integrated.sh:
--------------------------------------------------------------------------------
1 | #!/bin/sh
2 | cabal install
3 | {
4 |   cd js
5 |   cabal install
6 | }
7 | 
8 | 


--------------------------------------------------------------------------------
/try-purescript/data/busy.gif:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/ghcjs/ghcjs-examples/HEAD/try-purescript/data/busy.gif


--------------------------------------------------------------------------------
/fay-hello/install-standalone.sh:
--------------------------------------------------------------------------------
1 | #!/bin/sh
2 | cabal install
3 | (
4 |   cd js
5 |   ghcjs-cabal install
6 | )
7 | 
8 | 


--------------------------------------------------------------------------------
/try-purescript/data/run_button.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/ghcjs/ghcjs-examples/HEAD/try-purescript/data/run_button.png


--------------------------------------------------------------------------------
/fay-hello/Setup.lhs:
--------------------------------------------------------------------------------
1 | #!/usr/bin/runhaskell 
2 | > module Main where
3 | > import Distribution.Simple
4 | > main :: IO ()
5 | > main = defaultMain
6 | 
7 | 


--------------------------------------------------------------------------------
/mloc-js/Setup.lhs:
--------------------------------------------------------------------------------
1 | #!/usr/bin/runhaskell 
2 | > module Main where
3 | > import Distribution.Simple
4 | > main :: IO ()
5 | > main = defaultMain
6 | 
7 | 


--------------------------------------------------------------------------------
/ghcjs-hello/Setup.lhs:
--------------------------------------------------------------------------------
1 | #!/usr/bin/runhaskell 
2 | > module Main where
3 | > import Distribution.Simple
4 | > main :: IO ()
5 | > main = defaultMain
6 | 
7 | 


--------------------------------------------------------------------------------
/multiple-pages/Setup.lhs:
--------------------------------------------------------------------------------
1 | #!/usr/bin/runhaskell 
2 | > module Main where
3 | > import Distribution.Simple
4 | > main :: IO ()
5 | > main = defaultMain
6 | 
7 | 


--------------------------------------------------------------------------------
/webkit-hello/Setup.lhs:
--------------------------------------------------------------------------------
1 | #!/usr/bin/runhaskell 
2 | > module Main where
3 | > import Distribution.Simple
4 | > main :: IO ()
5 | > main = defaultMain
6 | 
7 | 


--------------------------------------------------------------------------------
/webkit-sodium/Setup.lhs:
--------------------------------------------------------------------------------
1 | #!/usr/bin/runhaskell 
2 | > module Main where
3 | > import Distribution.Simple
4 | > main :: IO ()
5 | > main = defaultMain
6 | 
7 | 


--------------------------------------------------------------------------------
/multiple-pages/data/main.js:
--------------------------------------------------------------------------------
 1 | window.onload = function(){
 2 |   goog.debug.Console.autoInstall();
 3 |   $hs_loadPath = "../../bin/multiple-pages.trampoline.jsexe/";
 4 | 
 5 |   // Must be called first
 6 |   $hs_init();
 7 |   $hs_consoleInitAndRunIO([$$ZCMain_main]);
 8 | }
 9 | 
10 | 


--------------------------------------------------------------------------------
/travis/gtk.sh:
--------------------------------------------------------------------------------
1 | #!/bin/sh -ex
2 | sudo apt-get update -qq
3 | sudo apt-get --no-install-recommends install darcs libwebkitgtk-3.0-dev
4 | git clone https://github.com/yesodweb/cabal-meta.git
5 | darcs get --lazy http://patch-tag.com/r/hamish/gtk2hs
6 | cabal install ./gtk2hs/tools
7 | 
8 | 


--------------------------------------------------------------------------------
/fay-hello/fay-hello.cabal:
--------------------------------------------------------------------------------
 1 | name: fay-hello
 2 | version: 0.0.1
 3 | cabal-version: >=1.2
 4 | build-type: Simple
 5 | license: BSD3
 6 | license-file: ""
 7 | description:
 8 | data-dir: ""
 9 | 
10 | executable fay-hello
11 |     build-depends: base -any, blaze-html -any, filepath -any,
12 |                    hamlet -any, shakespeare-js -any,
13 |                    text -any, blaze-markup -any, ghcjs -any,
14 |                    fay-hello-js -any
15 |     main-is: Main.hs
16 |     buildable: True
17 |     hs-source-dirs: src
18 | 
19 | 


--------------------------------------------------------------------------------
/weblog/event/event.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE OverloadedStrings #-}
 2 | 
 3 | module Main where
 4 | 
 5 | import JavaScript.JQuery
 6 | import JavaScript.JQuery.Internal
 7 | import Data.Default
 8 | import qualified Data.Text as T
 9 | 
10 | main = do
11 |   b <- select "body"
12 |   append "<div class='mouse'></div>" b
13 |   m <- select ".mouse"
14 |   mousemove (handler m) def b
15 | 
16 | handler :: JQuery -> Event -> IO ()
17 | handler m e = do
18 |   x <- pageX e
19 |   y <- pageY e
20 |   setText (T.pack $ show (x,y)) m
21 |   return ()
22 | 
23 | 


--------------------------------------------------------------------------------
/fay-hello/js/fay-hello-js.cabal:
--------------------------------------------------------------------------------
 1 | name:                fay-hello-js
 2 | version:             0.1.0.0
 3 | license:             BSD3
 4 | license-file:        LICENSE
 5 | build-type:          Simple
 6 | cabal-version:       >=1.8
 7 | 
 8 | library
 9 |   build-depends: base >= 4 && < 5, transformers, template-haskell
10 |   exposed-modules: Paths_fay_hello_js
11 | 
12 | executable fay-hello-js
13 |   build-depends:       base >= 4 && < 5, fay, blaze-html ==0.5.*, text ==0.11.*, ghc-prim ==0.2.*, transformers, template-haskell
14 |   Main-Is: Main.hs
15 | 
16 | 


--------------------------------------------------------------------------------
/weblog/ffi/ffi.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE JavaScriptFFI, CPP #-}
 2 | 
 3 | module Main where
 4 | 
 5 | #ifdef __GHCJS__
 6 | foreign import javascript unsafe        "document.write($1+'<br/>');" writeNumber :: Int -> IO ()
 7 | foreign import javascript interruptible "setTimeout($c, $1);"         delay       :: Int -> IO ()
 8 | #else
 9 | writeNumber = error "writeNumber: only available from JavaScript"
10 | delay = error "delay: only available from JavaScript"
11 | #endif
12 | 
13 | main :: IO ()
14 | main = mapM_ (\x -> writeNumber x >> delay 1000) [1..1000]
15 | 
16 | 


--------------------------------------------------------------------------------
/webkit-hello/webkit-hello.cabal:
--------------------------------------------------------------------------------
 1 | name: webkit-hello
 2 | version: 0.0.1
 3 | cabal-version: >=1.2
 4 | build-type: Simple
 5 | license: BSD3
 6 | license-file: ""
 7 | description:
 8 | data-dir: ""
 9 | 
10 | executable webkit-hello
11 |     build-depends: base -any,
12 |                    glib -any,
13 |                    gtk -any,
14 |                    webkit >= 0.12.5,
15 |                    ghcjs-dom -any,
16 |                    mtl -any
17 |     main-is: Main.hs
18 |     buildable: True
19 |     hs-source-dirs: src
20 |     ghc-options: -threaded -rtsopts
21 | 


--------------------------------------------------------------------------------
/weblog/fibonacci/fibonacci.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE ScopedTypeVariables #-}
 2 | module Main where
 3 | 
 4 | import           Control.Concurrent
 5 | import qualified Control.Exception as E
 6 | import           Control.Monad
 7 | 
 8 | -- this is inefficient on purpose
 9 | fib :: Int -> Int
10 | fib 0 = 0
11 | fib 1 = 1
12 | fib n = fib (n-1) + fib (n-2)
13 | 
14 | fib38 = fib 38
15 | 
16 | printFib = print fib38 `E.catch` \(_::E.SomeException) -> putStrLn "not finished"
17 | 
18 | main = forever $ do
19 |          tid <- forkIO printFib
20 |          threadDelay 1000000
21 |          throwTo tid E.Overflow
22 | 


--------------------------------------------------------------------------------
/weblog/event/event.html:
--------------------------------------------------------------------------------
 1 | <!DOCTYPE html>
 2 | <html>
 3 |   <head>
 4 |     <script language="javascript" src="//ajax.googleapis.com/ajax/libs/jquery/1.10.1/jquery.min.js"></script>
 5 |     <script language="javascript" src="lib.js"></script>
 6 |     <script language="javascript" src="rts.js"></script>
 7 |     <script language="javascript" src="lib1.js"></script>
 8 |     <script language="javascript" src="out.js"></script>
 9 |     <style>html,body { height: 100%; padding: 0px; margin: 0px; }</style>
10 |   </head>
11 |   <body>
12 |   </body>
13 |   <script language="javascript">
14 |     
15 | h$main(h$mainZCMainzimain);
16 | 
17 |   </script>
18 | </html>
19 | 


--------------------------------------------------------------------------------
/weblog/mouse/mouse.html:
--------------------------------------------------------------------------------
 1 | <!DOCTYPE html>
 2 | <html>
 3 |   <head>
 4 |     <script language="javascript" src="//ajax.googleapis.com/ajax/libs/jquery/1.10.1/jquery.min.js"></script>
 5 |     <script language="javascript" src="lib.js"></script>
 6 |     <script language="javascript" src="rts.js"></script>
 7 |     <script language="javascript" src="lib1.js"></script>
 8 |     <script language="javascript" src="out.js"></script>
 9 |     <style type="text/css"> html, body { width: 100%; height: 100%; margin: 0; padding: 0; }</style>
10 |   </head>
11 |   <body>
12 |   </body>
13 |   <script language="javascript">
14 |     
15 | h$main(h$mainZCMainzimain);
16 | 
17 |   </script>
18 | </html>
19 | 


--------------------------------------------------------------------------------
/weblog/balls1/balls1.html:
--------------------------------------------------------------------------------
 1 | <!DOCTYPE html>
 2 | <html>
 3 |   <head>
 4 |     <script language="javascript" src="//ajax.googleapis.com/ajax/libs/jquery/1.10.1/jquery.min.js"></script>
 5 |     <script language="javascript" src="lib.js"></script>
 6 |     <script language="javascript" src="rts.js"></script>
 7 |     <script language="javascript" src="lib1.js"></script>
 8 |     <script language="javascript" src="out.js"></script>
 9 |     <style type="text/css"> html, body { width: 100%; height: 100%; margin: 0; padding: 0; }</style>
10 |   </head>
11 |   <body>
12 |   </body>
13 |   <script language="javascript">
14 |     
15 | h$main(h$mainZCMainzimain);
16 | 
17 |   </script>
18 | </html>
19 | 


--------------------------------------------------------------------------------
/weblog/balls2/balls2.html:
--------------------------------------------------------------------------------
 1 | <!DOCTYPE html>
 2 | <html>
 3 |   <head>
 4 |     <script language="javascript" src="//ajax.googleapis.com/ajax/libs/jquery/1.10.1/jquery.min.js"></script>
 5 |     <script language="javascript" src="lib.js"></script>
 6 |     <script language="javascript" src="rts.js"></script>
 7 |     <script language="javascript" src="lib1.js"></script>
 8 |     <script language="javascript" src="out.js"></script>
 9 |     <style type="text/css"> html, body { width: 100%; height: 100%; margin: 0; padding: 0; }</style>
10 |   </head>
11 |   <body>
12 |   </body>
13 |   <script language="javascript">
14 |     
15 | h$main(h$mainZCMainzimain);
16 | 
17 |   </script>
18 | </html>
19 | 


--------------------------------------------------------------------------------
/weblog/counter/counter.html:
--------------------------------------------------------------------------------
 1 | <!DOCTYPE html>
 2 | <html>
 3 |   <head>
 4 |     <script language="javascript" src="//ajax.googleapis.com/ajax/libs/jquery/1.10.1/jquery.min.js"></script>
 5 |     <script language="javascript" src="lib.js"></script>
 6 |     <script language="javascript" src="rts.js"></script>
 7 |     <script language="javascript" src="lib1.js"></script>
 8 |     <script language="javascript" src="out.js"></script>
 9 |     <style type="text/css"> html, body { width: 100%; height: 100%; margin: 0; padding: 0; }</style>
10 |   </head>
11 |   <body>
12 |   </body>
13 |   <script language="javascript">
14 |     
15 | h$main(h$mainZCMainzimain);
16 | 
17 |   </script>
18 | </html>
19 | 


--------------------------------------------------------------------------------
/weblog/calculator/calculator.html:
--------------------------------------------------------------------------------
 1 | <!DOCTYPE html>
 2 | <html>
 3 |   <head>
 4 |     <script language="javascript" src="//ajax.googleapis.com/ajax/libs/jquery/1.10.1/jquery.min.js"></script>
 5 |     <script language="javascript" src="lib.js"></script>
 6 |     <script language="javascript" src="rts.js"></script>
 7 |     <script language="javascript" src="lib1.js"></script>
 8 |     <script language="javascript" src="out.js"></script>
 9 |     <style type="text/css"> html, body { width: 100%; height: 100%; margin: 0; padding: 0; }</style>
10 |   </head>
11 |   <body>
12 |   </body>
13 |   <script language="javascript">
14 |     
15 | h$main(h$mainZCMainzimain);
16 | 
17 |   </script>
18 | </html>
19 | 


--------------------------------------------------------------------------------
/.travis.yml:
--------------------------------------------------------------------------------
 1 | language: haskell
 2 | before_install:
 3 |   - sudo apt-get update -qq
 4 |   - sudo apt-get --no-install-recommends install darcs libwebkitgtk-3.0-dev
 5 |   - mkdir vendor
 6 |   - cd vendor
 7 |   - darcs get --lazy http://patch-tag.com/r/hamish/gtk2hs
 8 |   - cabal install ./gtk2hs/tools
 9 |   - cd ..
10 | install:
11 |   - cabal install cabal-meta cabal-src
12 |   - cabal-meta install -fwebkit1-8 -fgtk3 --force-reinstalls || cabal-meta install -fwebkit1-8 -fgtk3 --force-reinstalls
13 | script:
14 |   - cd ghcjs-hello
15 |   - cabal test
16 |   - cd ../webkit-sodium
17 |   - cabal test
18 |   - cd ../multiple-pages
19 |   - cabal test
20 | notifications:
21 |   irc:
22 |     channels: "irc.freenode.net#ghcjs"
23 |   email: true
24 | 


--------------------------------------------------------------------------------
/multiple-pages/data/hamlet.html:
--------------------------------------------------------------------------------
 1 | <!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN" "http://www.w3.org/TR/REC-html40/loose.dtd">
 2 | <html>
 3 | <head>
 4 | <meta http-equiv="Content-Type" content="text/html; charset=UTF-8">
 5 | <script type="text/javascript" src="../../bin/multiple-pages.trampoline.jsexe/rts.js"></script>
 6 | <script type="text/javascript" src="../../bin/multiple-pages.trampoline.jsexe/main.js"></script>
 7 | <title>Multiple Pages - Hamlet</title>
 8 | </head>
 9 | <body>
10 | <h1><a href="index.html"/>Multiple Pages</a> - Hamlet</h1>
11 | <p>Have you tried <a href="http://hackage.haskell.org/package/hamlet-1.0.1.2">hamlet</a>?</p>
12 | <textarea id="hamlet-in" rows="20" cols="120"></textarea>
13 | <div id="hamlet-out"></div>
14 | </body>
15 | </html>
16 | 


--------------------------------------------------------------------------------
/webkit-sodium/webkit-sodium.cabal:
--------------------------------------------------------------------------------
 1 | name: webkit-sodium
 2 | version: 0.0.1
 3 | cabal-version: >=1.2
 4 | build-type: Simple
 5 | license: AllRightsReserved
 6 | description:
 7 | 
 8 | library
 9 |     build-depends: QuickCheck -any, base -any, mtl -any,
10 |                    sodium -any, array -any, filepath -any, random -any, ghcjs-dom -any,
11 |                    jsaddle -any, lens -any
12 | 
13 |     exposed-modules: Engine, Freecell, Game
14 |     hs-source-dirs: src
15 | 
16 | executable freecell
17 |     build-depends: QuickCheck -any, base -any, mtl -any,
18 |                    sodium -any, array -any, filepath -any, random -any, ghcjs-dom -any,
19 |                    jsaddle -any, lens -any
20 | 
21 |     main-is: Main.hs
22 |     buildable: True
23 |     hs-source-dirs: src
24 |     ghc-options: -threaded -rtsopts
25 | 


--------------------------------------------------------------------------------
/multiple-pages/data/primes.html:
--------------------------------------------------------------------------------
 1 | <!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN" "http://www.w3.org/TR/REC-html40/loose.dtd">
 2 | <html>
 3 | <head>
 4 | <meta http-equiv="Content-Type" content="text/html; charset=UTF-8">
 5 | <script type="text/javascript" src="../../bin/multiple-pages.trampoline.jsexe/rts.js"></script>
 6 | <script type="text/javascript" src="../../bin/multiple-pages.trampoline.jsexe/main.js"></script>
 7 | <title>Multiple Pages - Primes</title>
 8 | </head>
 9 | <body>
10 | <h1><a href="index.html"/>Multiple Pages</a> - Primes</h1>
11 | <p>This page has a regular input element and suggestion.
12 | Our "custom browser" knows how to augment this with the
13 | code to validate the prime as it is entered</p>
14 | <input id="prime-in">
15 | <span id="prime-out">enter a prime</span>
16 | </body>
17 | </html>
18 | 


--------------------------------------------------------------------------------
/weblog/sync/sync.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE OverloadedStrings #-}
 2 | 
 3 | module Main where
 4 | 
 5 | import GHCJS.Types
 6 | import GHCJS.Foreign
 7 | 
 8 | import Data.Text (Text)
 9 | import Control.Applicative
10 | import Text.Read (readMaybe)
11 | 
12 | main = do
13 |   o <- newObj
14 |   setProp ("input"::Text) ("123"::JSString) o
15 |   factorial o
16 |   r <- getProp ("output"::Text) o
17 |   putStrLn (fromJSString r)
18 | 
19 | factorial :: JSRef () -> IO ()
20 | factorial ref = do
21 |   x <- fromJSString <$> getProp ("input"::Text) ref
22 |   let r = case readMaybe x of
23 |             Just n | n < 0 || n > 5000 -> "invalid input"
24 |             Just n -> toJSString . show . fact $ n
25 |             Nothing -> "parse error"
26 |   setProp ("output"::Text) r ref
27 |   where
28 |     fact :: Integer -> Integer
29 |     fact n = product [1..n]
30 | 


--------------------------------------------------------------------------------
/try-purescript/codemirror/theme/elegant.css:
--------------------------------------------------------------------------------
 1 | .cm-s-elegant span.cm-number, .cm-s-elegant span.cm-string, .cm-s-elegant span.cm-atom {color: #762;}
 2 | .cm-s-elegant span.cm-comment {color: #262; font-style: italic; line-height: 1em;}
 3 | .cm-s-elegant span.cm-meta {color: #555; font-style: italic; line-height: 1em;}
 4 | .cm-s-elegant span.cm-variable {color: black;}
 5 | .cm-s-elegant span.cm-variable-2 {color: #b11;}
 6 | .cm-s-elegant span.cm-qualifier {color: #555;}
 7 | .cm-s-elegant span.cm-keyword {color: #730;}
 8 | .cm-s-elegant span.cm-builtin {color: #30a;}
 9 | .cm-s-elegant span.cm-link {color: #762;}
10 | .cm-s-elegant span.cm-error {background-color: #fdd;}
11 | 
12 | .cm-s-elegant .CodeMirror-activeline-background {background: #e8f2ff !important;}
13 | .cm-s-elegant .CodeMirror-matchingbracket {outline:1px solid grey; color:black !important;}
14 | 


--------------------------------------------------------------------------------
/multiple-pages/multiple-pages.cabal:
--------------------------------------------------------------------------------
 1 | name: multiple-pages
 2 | version: 0.0.1
 3 | cabal-version: >=1.2
 4 | build-type: Simple
 5 | license: BSD3
 6 | license-file: ""
 7 | synopsis: Dynamic web site build on multiple HTML pages
 8 | description: Shows how to add GHCJS support to static HTML files or server generated HTML files.
 9 |              .
10 |              All the files run Main.main, but it simply detects the page and loads and runs the pages "main" function.
11 | data-files: *.html
12 | data-dir: data
13 |  
14 | executable multiple-pages
15 |     build-depends: text >=0.11.2.3 && <0.12, hamlet >=1.1.0.2 && <1.2,
16 |                    blaze-html >=0.5.0.0 && <0.7, webkit >=0.12.5 && <0.13,
17 |                    mtl >=2.1.1 && <2.2, ghcjs-dom >=0.0.1 && <0.1, base -any
18 |     main-is: Main.hs
19 |     buildable: True
20 |     hs-source-dirs: src
21 |  
22 | 


--------------------------------------------------------------------------------
/ghcjs-hello/ghcjs-hello.cabal:
--------------------------------------------------------------------------------
 1 | name: ghcjs-hello
 2 | version: 0.0.1
 3 | cabal-version: >=1.8
 4 | build-type: Simple
 5 | license: BSD3
 6 | 
 7 | flag jmacro
 8 |     Description:  Include some JMacro support
 9 |     Default: False
10 | 
11 | executable ghcjs-hello
12 |     build-depends: deepseq >=1.3.0.2 && <1.4, lens -any,
13 |                    containers -any, random -any,
14 |                    template-haskell -any, base -any, blaze-html -any, filepath -any,
15 |                    hamlet -any, text -any, blaze-markup -any, shakespeare -any,
16 |                    ghcjs-dom >=0.1.1.0 && <0.2, mtl -any, sodium -any, webkit-sodium -any,
17 |                    jsaddle >=0.2.0.0 && <0.3
18 | 
19 |     if flag(jmacro)
20 |         build-depends: jmacro >=0.6.3 && <0.8
21 | 
22 |     main-is: Main.hs
23 |     buildable: True
24 |     hs-source-dirs: src
25 |     ghc-options: -threaded -with-rtsopts=-N3
26 | 
27 | 


--------------------------------------------------------------------------------
/weblog/race/race.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE JavaScriptFFI, CPP #-}
 2 | module Main where
 3 | 
 4 | import Control.Monad
 5 | import Control.Concurrent
 6 | import GHCJS.Foreign
 7 | import GHCJS.Types
 8 | 
 9 | import Data.Text (pack)
10 | 
11 | #ifdef __GHCJS__
12 | foreign import javascript unsafe "document.getElementById($1).style.left = '' + $2 + 'px'"
13 |   setPos :: JSString -> Int -> IO ()
14 | #else
15 | setPos = error "setPos: only available in JavaScript"
16 | #endif
17 | 
18 | main :: IO ()
19 | main = mapM_ runRacer [1..10] 
20 | 
21 | runRacer :: Int -> IO ()
22 | runRacer n = void $ forkIO $ do
23 |   doRace (toJSString $ "racer" ++ show n)
24 | 
25 | doRace :: JSString -> IO ()
26 | doRace str = go (0::Int)
27 |   where
28 |     go n | n > 800   = go 0
29 |          | otherwise = do
30 |              setPos str n
31 |              threadDelay 1
32 |              go (n+1)
33 | 
34 | x = pack "abc" -- workaround, sometimes the dependencies for text aren't linked without this, need to investigate
35 | 


--------------------------------------------------------------------------------
/weblog/sync/sync.html:
--------------------------------------------------------------------------------
 1 | <!DOCTYPE html>
 2 | <html>
 3 |   <head>
 4 |     <script language="javascript" src="//ajax.googleapis.com/ajax/libs/jquery/1.10.1/jquery.min.js"></script>
 5 |     <script language="javascript" src="lib.js"></script>
 6 |     <script language="javascript" src="rts.js"></script>
 7 |     <script language="javascript" src="lib1.js"></script>
 8 |     <script language="javascript" src="out.js"></script>
 9 |   </head>
10 |   <body>
11 |     <input type="text" id="factorial_input" />
12 |     <div id="factorial_output"></div>
13 |   </body>
14 |   <script language="javascript">
15 | 
16 | $('#factorial_input').on('keyup change', function(e) {
17 |   var o = { input: $('#factorial_input').val() };
18 |   h$runSync( h$c2( h$ap1_e
19 |                  , h$mainZCMainzifactorial
20 |                  , h$c1(h$ghcjszmprimZCGHCJSziPrimziJSRef_con_e, o)
21 |                  )
22 |            , false
23 |            );
24 |   $('#factorial_output').text(o.output);
25 | });
26 | 
27 |   </script>
28 | </html>
29 | 


--------------------------------------------------------------------------------
/weblog/counter/counter.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE OverloadedStrings #-}
 2 | 
 3 | module Main where
 4 | 
 5 | import           Control.Monad
 6 | import           Control.Monad.IO.Class
 7 | import           Data.Default
 8 | import           Data.Text (Text)
 9 | import qualified Data.Text as T
10 | 
11 | import           JavaScript.JQuery hiding (Event)
12 | 
13 | import           FRP.Sodium
14 | 
15 | main :: IO ()
16 | main = do
17 |   body <- select "body"
18 |   buttonEvent <- reactiveButton "Click Me!" body
19 |   counterDiv <- select "<div />"
20 |   appendJQuery counterDiv body
21 |   sync $ do
22 |     counter <- count buttonEvent
23 |     listen (values counter) (\n -> void $
24 |             setText (T.pack . show $ n) counterDiv)
25 |   return ()
26 | 
27 | reactiveButton :: Text -> JQuery -> IO (Event ())
28 | reactiveButton label parent = do
29 |   (evt, a) <- sync newEvent
30 |   button <- select "<button />"
31 |   setText label button
32 |   appendJQuery button parent
33 |   let handler _ = sync (a ())
34 |   on handler "click" def button
35 |   return evt
36 | 
37 | 


--------------------------------------------------------------------------------
/weblog/build.sh:
--------------------------------------------------------------------------------
 1 | #!/bin/bash
 2 | 
 3 | # http://weblog.luite.com/wordpress/?p=14
 4 | 
 5 | ( cd hello && ghcjs -o hello hello.hs )
 6 | ( cd ffi && ghcjs -o ffi ffi.hs )
 7 | ( cd fibonacci && ghcjs -O2 -o fibonacci fibonacci.hs)
 8 | ( cd race && ghcjs -o race race.hs && cp race.html race.jsexe/index.html )
 9 | ( cd event && ghcjs -o event event.hs && cp event.html event.jsexe/index.html )
10 | ( cd sync && ghcjs -o sync sync.hs && cp sync.html sync.jsexe/index.html )
11 | 
12 | # http://weblog.luite.com/wordpress/?p=127
13 | cabal install --ghcjs sodium random vector-space data-default
14 | 
15 | ( cd counter && ghcjs -o counter counter.hs && cp counter.html counter.jsexe/index.html )
16 | ( cd calculator && ghcjs -o calculator calculator.hs && cp calculator.html calculator.jsexe/index.html )
17 | ( cd mouse && ghcjs -o mouse mouse.hs && cp mouse.html mouse.jsexe/index.html )
18 | ( cd balls1 && ghcjs -O2 -o balls1 balls1.hs && cp balls1.html balls1.jsexe/index.html && cp ball.png balls1.jsexe )
19 | ( cd balls2 && ghcjs -O2 -o balls2 balls2.hs && cp balls2.html balls2.jsexe/index.html && cp ball.png balls2.jsexe )
20 | 
21 | 


--------------------------------------------------------------------------------
/try-purescript/LICENSE:
--------------------------------------------------------------------------------
 1 | Copyright (c) 2014 Luite Stegeman
 2 | 
 3 | Permission is hereby granted, free of charge, to any person obtaining
 4 | a copy of this software and associated documentation files (the
 5 | "Software"), to deal in the Software without restriction, including
 6 | without limitation the rights to use, copy, modify, merge, publish,
 7 | distribute, sublicense, and/or sell copies of the Software, and to
 8 | permit persons to whom the Software is furnished to do so, subject to
 9 | the following conditions:
10 | 
11 | The above copyright notice and this permission notice shall be included
12 | in all copies or substantial portions of the Software.
13 | 
14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
21 | 


--------------------------------------------------------------------------------
/try-purescript/codemirror/LICENSE:
--------------------------------------------------------------------------------
 1 | Copyright (C) 2014 by Marijn Haverbeke <marijnh@gmail.com> and others
 2 | 
 3 | Permission is hereby granted, free of charge, to any person obtaining a copy
 4 | of this software and associated documentation files (the "Software"), to deal
 5 | in the Software without restriction, including without limitation the rights
 6 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
 7 | copies of the Software, and to permit persons to whom the Software is
 8 | furnished to do so, subject to the following conditions:
 9 | 
10 | The above copyright notice and this permission notice shall be included in
11 | all copies or substantial portions of the Software.
12 | 
13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
18 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
19 | THE SOFTWARE.
20 | 


--------------------------------------------------------------------------------
/webkit-sodium/src/Game.hs:
--------------------------------------------------------------------------------
 1 | module Game where
 2 | 
 3 | import FRP.Sodium
 4 | 
 5 | 
 6 | type Coord = Double
 7 | type Point = (Coord, Coord)
 8 | type Vector = (Coord, Coord)
 9 | type Rect = (Point, Vector)   -- Central point and size from centre to edge
10 | type Sprite = (Rect, String)
11 | 
12 | data MouseEvent = MouseDown Point | MouseMove Point | MouseUp Point
13 |     deriving Show
14 | 
15 | plus :: Point -> Vector -> Point
16 | plus (x0, y0) (x1, y1) = (x0 + x1, y0 + y1)
17 | 
18 | minus :: Point -> Point -> Vector
19 | minus (x0, y0) (x1, y1) = (x0 - x1, y0 - y1)
20 | 
21 | -- | True if the point is inside the rectangle
22 | inside :: Point -> Rect -> Bool
23 | inside (x, y) ((ox, oy), (wx, wy)) =
24 |     x >= ox - wx && x <= ox + wx &&
25 |     y >= oy - wy && y <= oy + wy
26 | 
27 | -- | This tree structure is used to give a list of behaviours from different
28 | -- parts of the FRP logic, so the engine can efficiently draw only the things
29 | -- that have changed. This could be done just as a plain old list, this is a
30 | -- bit more flexible, and also, it allows for us to later add the ability to
31 | -- switch subtrees by means of Sodium's switch primitive.
32 | data BehaviorTree a = BehaviorTree a :++ BehaviorTree a
33 |                     | BehaviorNode (Behavior a)
34 | infixr 5 :++
35 | 
36 | 


--------------------------------------------------------------------------------
/weblog/race/race.html:
--------------------------------------------------------------------------------
 1 | <html>
 2 |   <head>
 3 |     <script language="javascript" src="lib.js"></script>
 4 |     <script language="javascript" src="rts.js"></script>
 5 |     <script language="javascript" src="lib1.js"></script>
 6 |     <script language="javascript" src="out.js"></script>
 7 |     <style>
 8 |       div.track { width: 800px; height: 30px; border: 1px solid black; position: relative }
 9 |       div.racer { background-color: rgb(255,0,0); width: 20px; height: 20px; position: absolute; top: 5px }
10 |     </style>
11 |   </head>
12 |   <body>
13 |     <div class=track><div class=racer id=racer1></div></div>
14 |     <div class=track><div class=racer id=racer2></div></div>
15 |     <div class=track><div class=racer id=racer3></div></div>
16 |     <div class=track><div class=racer id=racer4></div></div>
17 |     <div class=track><div class=racer id=racer5></div></div>
18 |     <div class=track><div class=racer id=racer6></div></div>
19 |     <div class=track><div class=racer id=racer7></div></div>
20 |     <div class=track><div class=racer id=racer8></div></div>
21 |     <div class=track><div class=racer id=racer9></div></div>
22 |     <div class=track><div class=racer id=racer10></div></div>
23 |   </body>
24 |   <script language="javascript">
25 |     
26 | h$main(h$mainZCMainzimain);
27 | 
28 |   </script>  
29 | </html>
30 | 
31 | 


--------------------------------------------------------------------------------
/try-purescript/try-purescript.cabal:
--------------------------------------------------------------------------------
 1 | name:                try-purescript
 2 | version:             0.1.0.0
 3 | synopsis:            Try PureScript!
 4 | description:         GHCJS example project: Try PureScript in the browser
 5 | license:             MIT
 6 | license-file:        LICENSE
 7 | author:              Luite Stegeman
 8 | maintainer:          stegeman@gmail.com
 9 | category:            Web
10 | build-type:          Simple
11 | cabal-version:       >=1.10
12 | extra-source-files: codemirror/lib/codemirror.css
13 |                     codemirror/lib/codemirror.js
14 |                     codemirror/theme/elegant.css
15 |                     codemirror/addon/edit/matchbrackets.js
16 |                     codemirror/mode/haskell/haskell.js
17 |                     codemirror/LICENSE
18 |                     data/index.html
19 |                     data/tryps.css
20 |                     data/run_button.png
21 |                     data/busy.gif
22 |                     prepare.sh
23 |                     README.markdown
24 | 
25 | executable try-purescript
26 |   js-sources: jsbits/tryps.js
27 |   ghcjs-options: -O
28 |   cpp-options: -DGHCJS_BROWSER -DGHCJS_BUSY_YIELD=30
29 |   main-is:             Main.hs
30 |   build-depends:       base >=4.7 && <5,
31 |                        ghcjs-base,
32 |                        ghcjs-ffiqq,
33 |                        mtl,
34 |                        purescript >= 0.6 && < 0.7
35 |   default-language:    Haskell2010
36 | 


--------------------------------------------------------------------------------
/try-purescript/prepare.sh:
--------------------------------------------------------------------------------
 1 | #!/bin/sh
 2 | 
 3 | # run this script after building the jsexe to copy data files and minify the sources
 4 | # assumes that the tools described in the Deployment wiki page are installed.
 5 | #   https://github.com/ghcjs/ghcjs/wiki/Deployment
 6 | #
 7 | # this task really ought to be done with Cabal, but it doesn't support this yet
 8 | 
 9 | set -e
10 | 
11 | DISTDIR="dist"
12 | EXEDIR="$DISTDIR/build/try-purescript/try-purescript.jsexe"
13 | 
14 | cp "data/index.html"     "$EXEDIR/index.html"
15 | cp "data/tryps.css"      "$EXEDIR/tryps.css"
16 | cp "data/run_button.png" "$EXEDIR/run_button.png"
17 | cp "data/busy.gif"       "$EXEDIR/busy.gif"
18 | 
19 | cp "codemirror/lib/codemirror.js" "$EXEDIR/codemirror.js"
20 | cat "codemirror/addon/edit/matchbrackets.js" >> "$EXEDIR/codemirror.js"
21 | cat "codemirror/mode/haskell/haskell.js" >> "$EXEDIR/codemirror.js"
22 | 
23 | cp "codemirror/lib/codemirror.css" "$EXEDIR/codemirror.css"
24 | cat "codemirror/theme/elegant.css" >> "$EXEDIR/codemirror.css"
25 | 
26 | (
27 |     cd "$EXEDIR"
28 |     # advanced optimizations are currently buggy for this program, enable them again when fixed
29 |     echo "minifying all.js"
30 |     ccjs "all.js" > "all.min.js"
31 |     echo "compressing all.min.js"
32 |     zopfli -i1000 "all.min.js"
33 |     echo "minifying codemirror.js"
34 |     ccjs "codemirror.js" > "codemirror.min.js"
35 |     echo "compressing codemirror.min.js"
36 |     zopfli -i1000 "codemirror.min.js"
37 | )
38 | 
39 | 


--------------------------------------------------------------------------------
/try-purescript/README.markdown:
--------------------------------------------------------------------------------
 1 | # Try PureScript!
 2 | 
 3 | Try PureScript! is an example that demonstrates the [ghcjs-ffiqq](https://github.com/ghcjs/ghcjs-ffiqq)
 4 | library and shows how long-running background computations can be done in asynchronous threads,
 5 | keeping the user interface responsive without the added complexity of web workers.
 6 | 
 7 | [PureScript](http://www.purescript.org/) is statically typed language that compiles
 8 | to JavaScript. Try PureScript! runs the PureScript compiler in the browser,
 9 | it includes a simplified prelude.
10 | 
11 | ### Installation
12 | 
13 | Since Cabal support for web dependencies is not yet complete, you need to run a separate
14 | script to copy them into the jsexe directory:
15 | 
16 |     cabal install --ghcjs --only-dependencies
17 |     cabal configure --ghcjs
18 |     cabal build
19 |     prepare.sh
20 | 
21 | `prepare.sh` requires the tools described in the
22 | [Deployment wiki](https://github.com/ghcjs/ghcjs/wiki/Deployment) to be installed. It minifies
23 | the scripts, but `ADVANCED_OPTIMIZATIONS` (full renaming and dead code elimination) is currently
24 | disabled due to some problems with it. It should be enabled again when these have been fixed.
25 | 
26 | to test locally with `warp-static`:
27 | 
28 |     cd dist/build/try-purescript/try-purescript.jsexe
29 |     warp
30 | 
31 | Edit `dist/build/try-purescript/try-purescript.jsexe/index.html` to load `all.js`
32 | instead of `all.min.js` for development. Then to rebuild, run:
33 | 
34 |     cabal build
35 | 
36 | 


--------------------------------------------------------------------------------
/mloc-js/mloc-js.cabal:
--------------------------------------------------------------------------------
 1 | name: mloc-js
 2 | version: 0.0.1
 3 | cabal-version: >=1.8
 4 | build-type: Simple
 5 | license: BSD3
 6 | license-file: ""
 7 | data-dir: "data"
 8 | 
 9 | library
10 |     build-depends: base -any, blaze-html -any, blaze-markup -any,
11 |                    containers >=0.5.0.0 && <0.6, filepath -any, ghcjs-dom -any,
12 |                    hamlet -any, hscolour >=1.20.3 && <1.21,
13 |                    jsc >=0.1.0.0 && <0.2, lens >=3.8.5 && <3.11, mtl -any,
14 |                    random >=1.0.1.1 && <1.1, sodium -any, template-haskell -any,
15 |                    text -any, webkit-sodium -any, gloss -any, array -any,
16 |                    jmacro -any
17 |     exposed-modules: Demo.DOM Demo.JavaScriptFFI Demo.LazyLoading
18 |                      Demo.Threading
19 |     exposed: True
20 |     buildable: True
21 |     hs-source-dirs: src
22 |     other-modules: Demo.Life WebKitUtils
23 | 
24 | executable mloc-js
25 |     build-depends: base -any, blaze-html -any, blaze-markup -any,
26 |                    containers >=0.5.0.0 && <0.6, filepath -any, ghcjs-dom -any,
27 |                    hamlet -any, hscolour >=1.20.3 && <1.21,
28 |                    jsc >=0.1.0.0 && <0.2, lens >=3.8.5 && <3.11, mtl -any,
29 |                    random >=1.0.1.1 && <1.1, sodium -any, template-haskell -any,
30 |                    text -any, webkit-sodium -any, gloss -any, array -any,
31 |                    jmacro -any
32 |     main-is: Main.hs
33 |     buildable: True
34 |     hs-source-dirs: src
35 |     other-modules: Demo.Life WebKitUtils
36 | 
37 | 


--------------------------------------------------------------------------------
/fay-hello/js/LICENSE:
--------------------------------------------------------------------------------
 1 | Copyright (c) 2012, Hamish Mackenzie
 2 | 
 3 | All rights reserved.
 4 | 
 5 | Redistribution and use in source and binary forms, with or without
 6 | modification, are permitted provided that the following conditions are met:
 7 | 
 8 |     * Redistributions of source code must retain the above copyright
 9 |       notice, this list of conditions and the following disclaimer.
10 | 
11 |     * Redistributions in binary form must reproduce the above
12 |       copyright notice, this list of conditions and the following
13 |       disclaimer in the documentation and/or other materials provided
14 |       with the distribution.
15 | 
16 |     * Neither the name of Hamish Mackenzie nor the names of other
17 |       contributors may be used to endorse or promote products derived
18 |       from this software without specific prior written permission.
19 | 
20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31 | 


--------------------------------------------------------------------------------
/webkit-hello/src/Main.hs:
--------------------------------------------------------------------------------
 1 | module Main (
 2 |     main
 3 | ) where
 4 | 
 5 | import Graphics.UI.Gtk.WebKit.WebView
 6 |        (webViewNew, webViewGetDomDocument)
 7 | import Graphics.UI.Gtk.WebKit.DOM.Document
 8 |        (documentCreateElement, documentGetElementById, documentGetBody)
 9 | import Graphics.UI.Gtk.WebKit.DOM.HTMLElement
10 |        (htmlElementGetInnerHTML, htmlElementInsertAdjacentElement,
11 |         htmlElementSetInnerHTML)
12 | import Graphics.UI.Gtk.WebKit.Types (castToHTMLElement)
13 | import Control.Applicative ((<$>))
14 | import Control.Monad.Trans ( liftIO )
15 | import Graphics.UI.Gtk.General.Enums (WindowPosition(..))
16 | import Graphics.UI.Gtk.WebKit.DOM.Element (elementOnclick)
17 | import Graphics.UI.Gtk.WebKit.DOM.EventM (mouseXY, target)
18 | import Graphics.UI.Gtk.WebKit.GHCJS (runWebGUI)
19 | 
20 | -- Comments show how what these FFI calls should work when the
21 | -- code compiled is compiled with GHCJS
22 | main = runWebGUI $ \ webView -> do
23 |   doc <- webViewGetDomDocument webView -- webView.document
24 |   Just body <- documentGetBody doc     -- doc.body
25 |   htmlElementSetInnerHTML body         -- body.setInnerHTML
26 |     "<input type=\"button\"/ value=\"Hello\" id=\"test\">"
27 |   Just button <- fmap castToHTMLElement <$>
28 |     documentGetElementById doc "test"  -- doc.getElementById
29 |   elementOnclick button $ do           -- button.onclick =
30 |     target <- target                   -- window.event.target
31 |     xy <- mouseXY                      -- window.event.X and window.event.Y
32 |     liftIO $ do
33 |       Just div <- fmap castToHTMLElement <$>
34 |         documentCreateElement doc "div" -- doc.createElement
35 |       -- doc.setInnerHTML
36 |       htmlElementSetInnerHTML div ("You clicked at " ++ show xy)
37 |       -- target.insertAdjacentElement
38 |       htmlElementInsertAdjacentElement target "afterEnd" (Just div)
39 |       return ()
40 |   return ()
41 | 
42 | 
43 | 
44 | 
45 | 
46 | 
47 | 
48 | 
49 | 
50 | 
51 | 


--------------------------------------------------------------------------------
/threads/threads.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE QuasiQuotes, OverloadedStrings, ScopedTypeVariables #-}
 2 | 
 3 | {-
 4 |    start 10000 threads that each randomly update the color of a single cell in a table
 5 | -}
 6 | 
 7 | module Main where
 8 | 
 9 | import Control.Applicative
10 | import Control.Concurrent
11 | import Control.Monad
12 | import System.Random
13 | 
14 | import GHCJS.Foreign.QQ
15 | import GHCJS.Types
16 | 
17 | addStyle :: [JSString] -> IO ()
18 | addStyle styles = do
19 |   (sh :: JSRef ()) <-
20 |         [jsu| var st = document.createElement('style');
21 |               st.appendChild(document.createTextNode(''));
22 |               document.head.appendChild(st);
23 |               $r = st.sheet;
24 |             |]
25 |   forM_ styles $ \s -> [jsu_| `sh.insertRule(`s, 0); |]
26 | 
27 | addChild :: JSRef () -> JSString -> IO (JSRef ())
28 | addChild parent tagName =
29 |   [jsu| var elem = document.createElement(`tagName);
30 |          `parent.appendChild(elem);
31 |          $r = elem;
32 |       |]
33 | 
34 | setCol :: JSRef () -> Int -> IO ()
35 | setCol elem col = [jsu_| `elem.className = 'col-' + `col; |]
36 | 
37 | main :: IO ()
38 | main = do
39 |   let dim = 100
40 |   addStyle [ "body { background-color: #666; }"
41 |            , "table { border-collapse: collapse; }"
42 |            , "td { width: 7px; height: 7px; padding: 0; margin: 0; border: none; }"
43 |            , "td.col-0 { background-color: #000; }", "td.col-1 { background-color: #444; }"
44 |            , "td.col-2 { background-color: #888; }", "td.col-3 { background-color: #bbb; }"
45 |            , "td.col-4 { background-color: #fff; }"
46 |            ]
47 |   table <- addChild [jsu'| document.body |] "table"
48 |   rows  <- replicateM dim (addChild table "tr")
49 |   cells <- concat <$> forM rows (\r -> replicateM dim (addChild r "td"))
50 |   forM_ cells (void . forkIO . cellThread)
51 | 
52 | cellThread :: JSRef () -> IO a
53 | cellThread elem = forever $ do
54 |   setCol elem =<< randomRIO (0,4)
55 |   threadDelay . (1000000+) =<< randomRIO (0,10000000)
56 | 


--------------------------------------------------------------------------------
/webkit-sodium/src/Main.hs:
--------------------------------------------------------------------------------
 1 | module Main (
 2 |     main
 3 | ) where
 4 | 
 5 | import Engine
 6 | import Freecell
 7 | 
 8 | import GHCJS.DOM.Document
 9 |        (documentCreateElement, documentGetElementById, documentGetBody)
10 | import GHCJS.DOM.HTMLElement
11 |        (htmlElementInsertAdjacentElement, htmlElementSetInnerHTML,
12 |         htmlElementInsertAdjacentHTML)
13 | import GHCJS.DOM.Types (castToHTMLDivElement)
14 | import GHCJS.DOM.CSSStyleDeclaration
15 |        (cssStyleDeclarationSetProperty)
16 | import Control.Applicative ((<$>))
17 | import Control.Arrow
18 | import Control.Monad.Trans ( liftIO )
19 | import GHCJS.DOM.Element
20 | import GHCJS.DOM.Node
21 | import Control.Monad
22 | import System.Random
23 | import FRP.Sodium
24 | import GHCJS.DOM (runWebGUI, webViewGetDomDocument)
25 | import Control.Concurrent (threadDelay, forkIO)
26 | 
27 | -- Comments show how what these FFI calls should work when the
28 | -- code compiled is compiled with GHCJS
29 | main = do
30 |   runWebGUI $ \ webView -> do
31 |     Just doc <- webViewGetDomDocument webView -- webView.document
32 |     Just body <- documentGetBody doc     -- doc.body
33 | 
34 |     -- If we are in the browser let's shrink the terminal window to make room
35 |     mbTerminal    <- fmap castToHTMLDivElement   <$> documentGetElementById doc "terminal"
36 |     case mbTerminal of
37 |       Just terminal -> do
38 |         Just style <- elementGetStyle terminal
39 |         cssStyleDeclarationSetProperty style "height" "100" ""
40 |       _             -> return ()
41 | 
42 |     Just div <- fmap castToHTMLDivElement <$> documentCreateElement doc "div"
43 |     elementSetAttribute div "style" "position:relative;left:0px;top:0px;background-color:#e0d0ff;width:700px;height:500px"
44 |     elementSetAttribute div "id" "freecell"
45 |     nodeAppendChild body (Just div)
46 |     unlisten <- engine webView "freecell" =<< mkFreecell
47 | 
48 |     -- Prevent finalizers running too soon
49 |     forkIO $ forever (threadDelay 1000000000) >> unlisten
50 | 
51 |     return ()
52 | 
53 | 
54 | 
55 | 
56 | 
57 | 
58 | 
59 | 
60 | 
61 | 
62 | 
63 | 
64 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
 1 | GHCJS Examples
 2 | ==============
 3 | 
 4 | These examples demonstrate some of the features of GHCJS.  Click on the links below to run
 5 | the examples in your browser.
 6 | 
 7 | [GHCJS Hello](http://ghcjs.github.com/bin/ghcjs-hello.trampoline.jsexe/)
 8 | * Lazy Loading
 9 | * Stdout and Stdin
10 | * Threading and MVars
11 | * Calling JavaScript from Haskell
12 | * Calling back into Haskell from JavaScript
13 | * Embedding JMacro code
14 | * Using Hamlet
15 | * Canvas
16 | 
17 | [Freecell](http://ghcjs.github.com/bin/freecell.trampoline.jsexe/)
18 | * FRP in JavaScript
19 | 
20 | [Multiple Pages](http://ghcjs.github.com/share/multiple-pages-0.0.1/)
21 | * Adding GHCJS to an existing website
22 | * Lazy Loading
23 | 
24 | Compiled to Native with GHC and WebKitGTK
25 | -----------------------------------------
26 | 
27 | [![Build Status](https://travis-ci.org/ghcjs/ghcjs-examples.png?branch=master)](https://travis-ci.org/ghcjs/ghcjs-examples)
28 | 
29 | To build and run these examples using WebKitGTK+ then do the following
30 | 
31 |     sudo apt-get install libwebkitgtk-3.0-dev
32 |     mkdir vendor
33 |     cd vendor
34 |     darcs get --lazy http://patch-tag.com/r/hamish/gtk2hs
35 |     cabal install ./gtk2hs/tools
36 |     cd ..
37 |     cabal install cabal-meta cabal-src
38 |     cabal-meta install -fgtk3 --force-reinstalls
39 |     
40 | Due to an issue with gtk2hsC2hs you may have to run that last step twice.
41 | You may also need to add -fwebkit1-8 if you have an older version of webkit.
42 | 
43 | Once this is done you should run the examples with 
44 |     ghcjs-hello
45 |     freecell
46 |     multiple-pages [URL to share/multiple-pages-0.0.1/index.html]
47 |     
48 | Installing WebKitGTK+ is not well supported on OS X and Windows, so we
49 | strongly recommend using Linux (or a Linux VM).
50 | 
51 | Compiled to JavaScript with Integrated GHCJS
52 | --------------------------------------------
53 | Follow the instructions in Integrated section of [GHCJS](https://github.com/ghcjs/ghcjs)
54 | 
55 | Compiled to JavaScript with Stand Alone GHCJS
56 | ---------------------------------------------
57 | TODO Add instructions....
58 | 
59 | 


--------------------------------------------------------------------------------
/weblog/calculator/calculator.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE OverloadedStrings, ScopedTypeVariables      #-}
 2 | 
 3 | module Main where
 4 | 
 5 | import           Control.Applicative
 6 | import           Control.Monad
 7 | import           Data.Default
 8 | import           Data.Text (Text)
 9 | import qualified Data.Text as T
10 | import           Text.Read
11 | 
12 | import           JavaScript.JQuery
13 | 
14 | import           FRP.Sodium
15 | 
16 | main :: IO ()
17 | main = do
18 |   body <-       select "body"
19 |   [op1, op2] <- replicateM 2 $
20 |      fmap (fmap (readMaybe . T.unpack)) (reactiveTextInput "0" body)
21 |   let items = [ ("add"     , arithBehaviour op1 op2 (+))
22 |               , ("multiply", arithBehaviour op1 op2 (*))
23 |               ]
24 |   sel <- reactiveSelect items body
25 |   output <- select "<div />"
26 |   appendJQuery output body
27 |   sync $ do
28 |     result <- switch sel
29 |     listen (values result) $ \v -> void $
30 |       setText (maybe "invalid input" (T.pack.show) v) output
31 |   return ()
32 | 
33 | arithBehaviour :: Behaviour (Maybe Integer)
34 |                -> Behaviour (Maybe Integer)
35 |                -> (Integer -> Integer -> Integer)
36 |                -> Behaviour (Maybe Integer)
37 | arithBehaviour op1 op2 f = liftA2 f <$> op1 <*> op2
38 | 
39 | reactiveTextInput :: Text -> JQuery -> IO (Behaviour Text)
40 | reactiveTextInput value parent = do
41 |   (b, a) <- sync (newBehaviour value)
42 |   input <- select "<input type='text' />"
43 |   setVal value input
44 |   appendJQuery input parent
45 |   let handler _ = sync . a =<< getVal input
46 |   on handler "keyup change" def input
47 |   return b
48 | 
49 | reactiveSelect :: [(Text,a)] -> JQuery -> IO (Behaviour a)
50 | reactiveSelect items parent = do
51 |   (b, a) <- sync (newBehaviour . snd . head $ items)
52 |   sel <- select "<select />"
53 |   forM_ (zip [(0::Int)..] items) $ \(n,(name,_)) -> do
54 |     opt <- select "<option />"
55 |     setAttr "value" (T.pack . show $ n) opt
56 |     when (n == 0) $ void (setAttr "selected" "true" opt)
57 |     setText name opt
58 |     appendJQuery opt sel
59 |   appendJQuery sel parent
60 |   let handler _ = sync . a =<< snd.(items !!).read.T.unpack <$> getVal sel
61 |   on handler "change" def sel
62 |   return b
63 | 


--------------------------------------------------------------------------------
/mloc-js/src/Demo/LazyLoading.hs:
--------------------------------------------------------------------------------
 1 | -----------------------------------------------------------------------------
 2 | --
 3 | -- Module      :  Demo.LazyLoading
 4 | -- Copyright   :  (c) Hamish Mackenzie, Luite Stegeman
 5 | -- License     :  MIT
 6 | --
 7 | -- | For large applications it is usefule to strip out unused code and move
 8 | --   code that is not always needed into separate files.
 9 | --
10 | --   The GHCJS linker performs Forest Shaking.  The function call graph is
11 | --   a directed graph.  Given a set of root nodes (entry point functions
12 | --   that we want to trigger code loading), it sorts the functions into files
13 | --   such that we refer to as bundles.
14 | --
15 | --    * No function is in more than one bundle.
16 | --
17 | --    * Functions called by the same set of roots are put in the same bundle.
18 | --
19 | --    * No bundle is smaller than a threshold size (the smallest files are merged).
20 | --
21 | --   The goal is to minimize the amount of JavaScript that needs to be loaded
22 | --   while avoiding having too many small files fetched from the server.
23 | --
24 | -----------------------------------------------------------------------------
25 | 
26 | module Demo.LazyLoading (
27 |     lazyLoad_freecell
28 | ) where
29 | 
30 | import GHCJS.DOM.HTMLElement
31 |        (htmlElementSetInnerHTML)
32 | import Engine (engine)
33 | import Freecell (mkFreecell)
34 | import Control.Concurrent (threadDelay, forkIO)
35 | import Control.Monad (forever)
36 | 
37 | -- | This function loads a FRP demo written by Stephen Blackheath.
38 | --   The NOINLINE pragma tells GHC not to inline it (which would
39 | --   make it imposible for the linker to replace it).  The linker
40 | --   detects the lazyLoad_ prefix and replaces the function with
41 | --   a loader function that fetches the bundles.
42 | {-# NOINLINE lazyLoad_freecell #-}
43 | lazyLoad_freecell webView doc example = do
44 |     htmlElementSetInnerHTML example $
45 |       "<div style=\""++style++"\" "++
46 |       "id=\"freecell\" draggable=\"false\"></div>"
47 |     unlisten <- engine webView "freecell" =<< mkFreecell
48 |     -- Prevent finalizers running too soon
49 |     forkIO $ forever (threadDelay 1000000000) >> unlisten
50 |     return ()
51 |   where
52 |     style = "position:relative;left:0px;top:0px;"
53 |             ++ "background-color:#e0d0ff;width:700px;height:500px"
54 | 
55 | 
56 | 
57 | 


--------------------------------------------------------------------------------
/multiple-pages/data/index.html:
--------------------------------------------------------------------------------
 1 | <!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN" "http://www.w3.org/TR/REC-html40/loose.dtd">
 2 | <html>
 3 | <head>
 4 | <meta http-equiv="Content-Type" content="text/html; charset=UTF-8">
 5 | <script type="text/javascript" src="../../bin/multiple-pages.trampoline.jsexe/rts.js"></script>
 6 | <script type="text/javascript" src="../../bin/multiple-pages.trampoline.jsexe/main.js"></script>
 7 | <title>Multiple Pages</title>
 8 | </head>
 9 | <body>
10 | <h1>Multiple Pages</h1>
11 | 
12 | <p>This example shows how you could use GHCJS with an existing web site.
13 | To keep it simple this example uses static HTML pages.</p>
14 | 
15 | <ul>
16 |   <li><a href="primes.html">Prime numbers</a></li>
17 |   <li><a href="hamlet.html">Hamlet</a></li>
18 | </ul>
19 | 
20 | <p>The source for this example is
21 | <a href="https://github.com/ghcjs/ghcjs-examples/blob/master/multiple-pages/src/Main.hs">here</a>.
22 | 
23 | <h3>Think of your GHCJS application as a custom browser for your web site.</h3>
24 | 
25 | <p>In an ideal world your users would run a web browser with all the features
26 | you wanted and there would be no need for JavaScript.  Instead we use JavaScript
27 | to add the features that are missing.</p>
28 | 
29 | <p>With GHCJS you can do this by writing a simple browser app like this one
30 | using WebKitGtk.  Then GHCJS will compile it to JavaScript and you can
31 | include it in all your HTML.</p>
32 | 
33 | <p>One slight complication is that you don't want to wind up running your
34 | code twice when you open the HTML in the webkit browser.  The ghcjs-dom
35 | package has a runWebGUI function.  As well as creating a WebKitGtk browser
36 | window in native mode, it uses the UserAgent to identify when the
37 | JavaScript version is running inside the Native version.</p>
38 | 
39 | <p>Every time you load a page the Main.main function runs and looks
40 | for content on the page to augment.  It can use lazy loading to limit
41 | the amount of JavaScript loaded for pages with little dynamic content.<p>
42 | 
43 | <h3>To build & run in native code</h3>
44 | 
45 | <p>With the regular GHC or integrated GHCJS installed.</p>
46 | 
47 | <pre>
48 | cd multiple-pages
49 | cabal install
50 | multiple-pages http://localhost/.cabal/share/mulitple-pages-0.0.1/index.html
51 | </pre>
52 | 
53 | <h3>To build & run in any browser</h3>
54 | 
55 | <p>With integrated GHCJS installed.</p>
56 | 
57 | <pre>
58 | cd multiple-pages
59 | cabal install
60 | ghcjs-min ~/.cabal/bin/multiple-pages.jsexe data/main.js
61 | open http://localhost/.cabal/share/mulitple-pages-0.0.1/index.html
62 | </pre>
63 | 
64 | </body>
65 | </html>
66 | 


--------------------------------------------------------------------------------
/try-purescript/Main.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE ForeignFunctionInterface, ScopedTypeVariables, JavaScriptFFI, QuasiQuotes, Rank2Types #-}
 2 | 
 3 | {-
 4 |   A simple example demonstrating ghcjs-ffiqq and working with asynchronous threads
 5 |  -}
 6 | module Main where
 7 | 
 8 | import           Control.Applicative
 9 | import           Control.Concurrent
10 | import           Control.Exception
11 | import           Control.Monad
12 | import           Control.Monad.Reader
13 | 
14 | import qualified Language.PureScript as P
15 | 
16 | import           GHCJS.Foreign.QQ
17 | 
18 | setError :: String -> IO ()
19 | setError xs = [js_| tryps.setError(`xs); |]
20 | 
21 | compileWorker :: [P.Module] -> MVar String -> (forall a. IO a -> IO a) -> IO ()
22 | compileWorker prelExts mv unmask =
23 |   forever $ unmask doCompile `catch` \(e::AsyncException) -> return ()
24 |     where
25 |       doCompile = do
26 |         src  <- takeMVar mv
27 |         [js_| tryps.setBusy('Compiling...'); |]
28 |         case P.parseModulesFromFiles (const "<editor>") [((), src)] of
29 |           Left err -> setError (show err)
30 |           Right [] -> setError "no input"
31 |           Right ms ->
32 |              let ms'  = map (P.runModuleName . P.getModuleName . snd) ms
33 |                  opts = P.defaultCompileOptions
34 |                             { P.optionsVerboseErrors = True
35 |                             , P.optionsAdditional    = P.CompileOptions "PS" ms' ms'
36 |                             }
37 |              in case P.compile (prelExts ++ map snd ms) [] `runReaderT` opts of
38 |                   Left err            -> setError err
39 |                   Right (jsSrc, _, _) -> [js_| tryps.setResult(`jsSrc); |]
40 | 
41 | abortCompilation :: ThreadId -> IO ()
42 | abortCompilation worker = killThread worker
43 | 
44 | main :: IO ()
45 | main = do
46 |   [js_| trypsInit();
47 |         tryps.setBusy('Compiling Prelude...');
48 |       |]
49 |   prelSrc <- [js| tryps.getPrelude() |]
50 |   let parsePS src = either (error . show) (map snd) $
51 |                     P.parseModulesFromFiles (const "<built-in>") [((), src)]
52 |       prelMods = parsePS prelSrc
53 |       (prelJs, prelExtSrc, _prelEnv) =
54 |          either error id $ P.compile prelMods [] `runReaderT` P.defaultCompileOptions
55 |       prelExts = parsePS prelExtSrc
56 |   [js_| tryps.setCompiledPrelude(`prelJs); |]
57 |   mv <- newEmptyMVar
58 |   worker <- mask_ $ forkIOWithUnmask (compileWorker prelExts mv)
59 |   forever $ do
60 |     [jsi_| tryps.waitForChange($c); |]
61 |     abortCompilation worker
62 |     threadDelay 500000
63 |     putMVar mv =<< [js| tryps.getEditorContents() |]
64 | 
65 | 


--------------------------------------------------------------------------------
/mloc-js/src/Demo/DOM.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE CPP #-}
 2 | -----------------------------------------------------------------------------
 3 | --
 4 | -- Module      :  Demo.DOM
 5 | -- Copyright   :
 6 | -- License     :  BSD3
 7 | --
 8 | -- | Manipulating the DOM is an important part of any web application.
 9 | --   To find a good way to do this we took a step back and asked how
10 | --   it would be done if we were writing just a native haskell application.
11 | --   You could write an entire web browser in Haskell, but a quicker solution
12 | --   is to write bindings to an existing browser engine.
13 | --
14 | --   We chose WebKit as the WebKitGTK+ library was the easiest to write
15 | --   haskell bindings for (it's C functions not C++).
16 | --
17 | --   We adapted an existing IDL process tool so that we could make the Haskell
18 | --   bindings from the WebKit IDL files.
19 | --
20 | --   Then we did the same to output JavaScript replacements for the C functions
21 | --   that make up WebKitGTK+.
22 | --
23 | -----------------------------------------------------------------------------
24 | 
25 | module Demo.DOM (
26 |     helloDOM
27 | ) where
28 | 
29 | import GHCJS.DOM.Document (documentGetElementById)
30 | import GHCJS.DOM.HTMLElement
31 |        (htmlElementSetInnerText)
32 | import GHCJS.DOM.Types (castToHTMLElement)
33 | 
34 | helloDOM doc = do
35 |     maybeExample <- documentGetElementById doc "example"
36 |     case maybeExample of
37 |         Just example -> htmlElementSetInnerText
38 |                                 (castToHTMLElement example)
39 |                                 "Hello World"
40 |         Nothing      -> putStrLn "Element 'example' not found"
41 | 
42 | 
43 | #ifdef SAMPLE_CODE
44 | 
45 |         -- This function is from the WebKitGTK+ Haskell bindings (generated
46 |         -- from the WebKit IDL files.  It is included here to give an idea
47 |         -- of how these bindings work.  webkit_dom_document_get_element_by_id
48 |         -- is the underlying C function called.
49 |         -- When compiled to JavaScript the C function will be emulated
50 |         -- with a JavaScript one.
51 |         documentGetElementById ::(DocumentClass self)
52 |                                => self
53 |                                -> String
54 |                                -> IO (Maybe Element)
55 |         documentGetElementById self elementId
56 |           = maybeNull (makeNewGObject mkElement)
57 |               (withUTFString elementId $
58 |                  \ elementIdPtr ->
59 |                    {# call webkit_dom_document_get_element_by_id #}
60 |                         (toDocument self)
61 |                         elementIdPtr)
62 | 
63 | #endif
64 | 


--------------------------------------------------------------------------------
/try-purescript/jsbits/tryps.js:
--------------------------------------------------------------------------------
 1 | /** @constructor */
 2 | function TryPs(editor, res, res_text, run_btn, run_output, run_templ, prelude) {
 3 |     this.changed = true;
 4 |     this.waiting = [];
 5 |     this.result = document.getElementById(res);
 6 |     this.result_text = document.getElementById(res_text);
 7 |     this.run_output = document.getElementById(run_output);
 8 |     this.code = null;
 9 |     this.prelude = document.getElementById(prelude).text;
10 |     this.compiledPrelude = '';
11 |     this.run_template = document.getElementById(run_templ).text.replace(/<!--([^]*)-->/gm, "$1");
12 |     this.editor = CodeMirror['fromTextArea'](
13 |         document.getElementById(editor), { 'lineNumbers': true
14 |                                          , 'mode': 'haskell'
15 |                                          , 'theme': 'elegant'
16 |                                          });
17 | 
18 |     var that = this;
19 |     this.editor['on']('changes', function() {
20 |         that.changed = true;
21 |         var x;
22 |         while(x = that.waiting.pop()) x();
23 |     });
24 |     document.getElementById(run_btn).addEventListener('click', function() {
25 |         that.result.className = "run";
26 |         var doc = that.run_output.contentWindow.document;
27 |         function addScript(c) {
28 |             var s = doc.createElement('script');
29 |             s.appendChild(doc.createTextNode(c));
30 |             doc.getElementsByTagName('head')[0].appendChild(s);
31 |         }
32 |         doc.open();
33 |         doc.write(that.run_template);
34 |         addScript(that.compiledPrelude + that.code);
35 |         addScript("runPS();");
36 |     });
37 | }
38 | 
39 | TryPs.prototype.getPrelude = function() {
40 |     return this.prelude;
41 | }
42 | 
43 | TryPs.prototype.waitForChange = function(c) {
44 |     if(this.changed) c(); else this.waiting.push(c);
45 | }
46 | 
47 | TryPs.prototype.getEditorContents = function() {
48 |     this.changed = false;
49 |     return this.editor['getDoc']()['getValue']();
50 | }
51 | 
52 | TryPs.prototype.setError = function(err) {
53 |     this.result.className = "error";
54 |     this.result_text.textContent = err;
55 | }
56 | 
57 | TryPs.prototype.setCompiledPrelude = function(x) {
58 |     this.compiledPrelude = x;
59 | }
60 | 
61 | TryPs.prototype.setResult = function(res) {
62 |     this.result.className = "runnable";
63 |     this.result_text.textContent = res;
64 |     this.code = res;
65 | }
66 | 
67 | TryPs.prototype.setBusy = function(msg) {
68 |     this.result.className = "busy";
69 |     this.result_text.textContent = msg;
70 | }
71 | 
72 | var tryps;
73 | function trypsInit() {
74 |     tryps = new TryPs( 'editor', 'result_outer', 'result_text', 'run_button'
75 |                       , 'run_output', 'run_template', 'purescript_prelude');
76 | }
77 | 
78 | 


--------------------------------------------------------------------------------
/mloc-js/src/Demo/JavaScriptFFI.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE CPP, DeriveFoldable, TemplateHaskell, QuasiQuotes, ScopedTypeVariables, NoMonomorphismRestriction #-}
 2 | -----------------------------------------------------------------------------
 3 | --
 4 | -- Module      :  Demo.JavaScriptFFI
 5 | -- Copyright   :
 6 | -- License     :  BSD3
 7 | --
 8 | -- | To find a nice way to wor
 9 | --
10 | -----------------------------------------------------------------------------
11 | 
12 | module Demo.JavaScriptFFI (
13 |     canvasDemo
14 |   , callHaskell
15 | ) where
16 | 
17 | import GHCJS.DOM.Types
18 |        (WebView(..), Document(..), HTMLDivElement(..))
19 | import GHCJS.DOM.HTMLCanvasElement
20 |        (htmlCanvasElementSetHeight, htmlCanvasElementSetWidth)
21 | import GHCJS.DOM.Node (nodeAppendChild)
22 | import Control.Lens ((^.))
23 | import Language.Javascript.JSC
24 |        (eval, evalJM, valToNumber, fun, jsg, js, (#), (<#), runJSC_)
25 | import WebKitUtils
26 | import GHCJS.DOM (webViewGetDomDocument)
27 | import Control.Monad.Reader (ReaderT(..))
28 | import GHCJS.DOM.HTMLElement
29 |        (htmlElementSetInnerHTML)
30 | import Data.Text.Lazy (unpack)
31 | import Text.Blaze.Html.Renderer.Text (renderHtml)
32 | import Text.Hamlet (shamlet)
33 | import Control.Monad (void)
34 | import Control.Monad.Trans ( liftIO )
35 | import Demo.Threading (isPrime)
36 | #ifdef MIN_VERSION_jmacro
37 | import Language.Javascript.JMacro
38 | #endif
39 | 
40 | canvasDemo :: WebView -> Document -> HTMLDivElement -> IO ()
41 | canvasDemo webView doc example = do
42 |     htmlElementSetInnerHTML example . unpack $ renderHtml
43 |         [shamlet|$newline always
44 |             <canvas #"canvas" width="600" height="400">
45 |         |]
46 | 
47 |     runJSC_ webView $ do
48 |         document <- jsg "document"
49 |         let getElementById = js "getElementById"
50 |             getContext     = js "getContext"
51 |             fillStyle      = js "fillStyle"
52 |             fillRect       = js "fillRect"
53 | 
54 |         -- var canvas = document.getElementById("canvas")
55 |         canvas <- document ^. getElementById # ["canvas"]
56 |         -- var ctx = canvas.getContext("2d")
57 |         ctx <- canvas ^. getContext # ["2d"]
58 |         -- ctx.fillStyle = "#00FF00"
59 |         ctx ^. fillStyle <# "#008000"
60 |         -- ctx.fillRect( 0, 0, 150, 75 )
61 |         ctx ^. fillRect # ([0, 0, 100, 100] :: [Double])
62 | 
63 | callHaskell :: WebView -> IO ()
64 | callHaskell webView = do
65 |     runJSC_ webView $ do
66 |         jsg "checkPrime" <# fun $ \ f this [a] -> do
67 |             num <- valToNumber a
68 |             let i = round num
69 |             liftIO . putStrLn $ "The number " ++ show i ++
70 |                 if isPrime i
71 |                     then " is a prime"
72 |                     else " is not a prime"
73 |         $([evalJM|for(n = 0; n != 10; ++n) checkPrime(n);|])
74 | 
75 | 
76 | 
77 | 


--------------------------------------------------------------------------------
/fay-hello/js/Main.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE TemplateHaskell, QuasiQuotes, ViewPatterns #-}
 2 | module Main (
 3 |     compileFromTo
 4 |   , main
 5 | ) where
 6 | 
 7 | import Language.Fay
 8 | import Language.Fay.Types
 9 | import Paths_fay_hello_js
10 | import Control.Exception (throw)
11 | import Control.Monad.IO.Class (liftIO)
12 | import Language.Haskell.TH (litE, stringL, runIO)
13 | import System.Environment (getArgs)
14 | 
15 | 
16 | -- import Paths_fay as Fay
17 | -- fayPath = Fay.getDataFileName
18 | 
19 | main = getBinDir >>= putStrLn
20 | 
21 | -- Based on code in the fay package Language.Fay.Compiler ....
22 | 
23 | -- | Compile file program to…
24 | compileFromTo :: Bool -> String -> IO String
25 | compileFromTo autorun hscode = do
26 |   let raw = $((runIO $ readFile "/Users/hamish/Library/Haskell/ghc-7.4.1.20120701/lib/fay-0.1.0.0/share/js/runtime.js") >>= litE . stringL)
27 |   let stdlib = $((runIO $ readFile "/Users/hamish/Library/Haskell/ghc-7.4.1.20120701/lib/fay-0.1.0.0/share/hs/stdlib.hs") >>= litE . stringL)
28 |   let stdlibprelude = $((runIO $ readFile "/Users/hamish/Library/Haskell/ghc-7.4.1.20120701/lib/fay-0.1.0.0/share/src/Language/Fay/Stdlib.hs") >>= litE . stringL)
29 |   result <- compileProgram autorun raw compileModule (hscode ++ "\n" ++ stdlib ++ "\n" ++ strip stdlibprelude)
30 |   case result of
31 |     Right out -> return out
32 |     Left  err -> return $ show err
33 | 
34 |   where strip = unlines . dropWhile (/="-- START") . lines
35 | 
36 | -- | Compile the given module to a runnable program.
37 | compileProgram :: (Show from,Show to,CompilesTo from to)
38 |                => Bool -> String -> (from -> Compile to) -> String
39 |                -> IO (Either CompileError String)
40 | compileProgram autorun raw with hscode = do
41 |   result <- compileViaStr with hscode
42 |   case result of
43 |     Left err -> return (Left err)
44 |     Right jscode -> return (Right (unlines ["var Fay = function(){"
45 |                                            ,raw
46 |                                            ,jscode
47 |                                            ,"return {"
48 |                                            ,"  force:_,"
49 |                                            ,"  thunk:$,"
50 |                                            ,"  list:Fay$$list,"
51 |                                            ,"  encodeShow:Fay$$encodeShow,"
52 |                                            ,"  main:main,"
53 |                                            ,"  eval:Fay$$eval"
54 |                                            ,"  };"
55 |                                            ,"};"
56 |                                            ,if autorun
57 |                                                then ";\nvar fay = new Fay();fay.force(fay.main);"
58 |                                                else ""
59 |                                            ]))
60 | 
61 | -- | Convert a Haskell filename to a JS filename.
62 | toJsName :: String -> String
63 | toJsName x = case reverse x of
64 |                ('s':'h':'.': (reverse -> file)) -> file ++ ".js"
65 |                _ -> x
66 | 
67 | 


--------------------------------------------------------------------------------
/weblog/mouse/mouse.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE CPP, JavaScriptFFI, ForeignFunctionInterface,
 2 |              EmptyDataDecls, OverloadedStrings,
 3 |              ScopedTypeVariables
 4 |   #-}
 5 | module Main where
 6 | 
 7 | import           Control.Applicative
 8 | import           Data.Default
 9 | import           Data.Text (Text)
10 | import qualified Data.Text as T
11 | 
12 | import           GHCJS.Types
13 | import           GHCJS.Foreign
14 | import           GHCJS.Marshal
15 | import           JavaScript.JQuery
16 | 
17 | import           FRP.Sodium
18 | import           GHCJS.DOM (runWebGUI, currentDocument)
19 | import           GHCJS.DOM.DOMWindow (domWindowGetDocument)
20 | import           GHCJS.DOM.Types (HTMLElement, Element, unHTMLElement,
21 |                     IsElement(..))
22 | import           GHCJS.DOM.Document (documentCreateElementNS,
23 |                     documentGetElementsByTagName, documentGetBody)
24 | import           GHCJS.DOM.Node (nodeAppendChild)
25 | import           GHCJS.DOM.Element (elementSetAttribute)
26 | 
27 | -- | create an element in the SVG namespace
28 | createSvg :: String -> IO (Maybe Element)
29 | createSvg n = do
30 |     Just doc <- currentDocument
31 |     documentCreateElementNS doc ("http://www.w3.org/2000/svg"::String) n
32 | 
33 | setAttribute' :: (IsElement o, ToJSRef v) => JSString -> v -> o -> IO ()
34 | setAttribute' a v o = toJSRef v >>= \v' -> elementSetAttribute o a (castRef v' :: JSString)
35 | 
36 | main =
37 |   runWebGUI $ \ webView -> do
38 |     Just doc <- domWindowGetDocument webView
39 |     Just body <- documentGetBody doc
40 |     Just svg <- createSvg "svg"
41 |     nodeAppendChild body (Just svg)
42 |     setAttribute' "width" (400::Int) svg >> setAttribute' "height" (400::Int) svg
43 |     t <- fmap ((*5) . fst) <$> mousePosition body
44 |     let sun   = pure (200, 200)
45 |         earth = object (1/365) 150 sun   t
46 |         moon  = object (1/30)  25  earth t
47 |     drawObject svg "yellow" 20 sun
48 |     drawObject svg "blue"   8  earth
49 |     drawObject svg "grey"   3  moon
50 | 
51 | object :: Double
52 |        -> Double
53 |        -> Behaviour (Double, Double)
54 |        -> Behaviour Double
55 |        -> (Behaviour (Double, Double))
56 | object speed r center time =
57 |    (,) <$> liftA2 xpos center time <*> liftA2 ypos center time
58 |      where
59 |        xpos (x,_) t = x + r * cos (speed * t)
60 |        ypos (_,y) t = y + r * sin (speed * t)
61 | 
62 | drawObject :: Element -> Text -> Double -> Behaviour (Double, Double) -> IO ()
63 | drawObject parent color r x = do
64 |   putStrLn (T.unpack color)
65 |   Just circle <- createSvg "circle"
66 |   let p .= v = setAttribute' p v circle
67 |   "fill" .= color >> "r" .= r
68 |   nodeAppendChild parent (Just circle)
69 |   sync $ listen (values x) $
70 |     \(x,y) -> "cx" .= x >> "cy" .= y
71 |   return ()
72 | 
73 | mousePosition :: IsElement e => e -> IO (Behaviour (Double, Double))
74 | mousePosition elem = do
75 |   (b, push) <- sync $ newBehaviour (0,0)
76 |   let handler ev = do
77 |         x <- pageX ev
78 |         y <- pageY ev
79 |         sync $ push (x,y)
80 |   on handler "mousemove" def =<< selectElement elem
81 |   return b
82 | 
83 | 


--------------------------------------------------------------------------------
/mloc-js/src/WebKitUtils.hs:
--------------------------------------------------------------------------------
 1 | -----------------------------------------------------------------------------
 2 | --
 3 | -- Module      :  WebKitUtils
 4 | -- Copyright   :
 5 | -- License     :  BSD3
 6 | --
 7 | -- |
 8 | --
 9 | -----------------------------------------------------------------------------
10 | 
11 | module WebKitUtils (
12 |     getHTMLElementById
13 |   , getDivElementById
14 |   , getInputElementById
15 |   , getImageElementById
16 |   , createDivElement
17 |   , createCanvasElement
18 | ) where
19 | 
20 | import GHCJS.DOM.Types
21 |        (HTMLImageElement(..), castToHTMLImageElement, GType, isA,
22 |         gTypeHTMLImageElement, castToHTMLElement, gTypeHTMLElement,
23 |         HTMLElement(..), HTMLCanvasElement(..), castToHTMLCanvasElement,
24 |         gTypeHTMLCanvasElement, HTMLInputElement(..), HTMLDivElement(..),
25 |         Element(..), DocumentClass, castToHTMLInputElement,
26 |         gTypeHTMLInputElement, castToHTMLDivElement, gTypeHTMLDivElement)
27 | import GHCJS.DOM.Document
28 |        (documentCreateElement, documentGetElementById)
29 | 
30 | 
31 | getHTMLElementById :: DocumentClass doc => doc -> String -> IO HTMLElement
32 | getHTMLElementById = getElementById gTypeHTMLElement castToHTMLElement
33 | 
34 | getDivElementById :: DocumentClass doc => doc -> String -> IO HTMLDivElement
35 | getDivElementById = getElementById gTypeHTMLDivElement castToHTMLDivElement
36 | 
37 | getInputElementById :: DocumentClass doc => doc -> String -> IO HTMLInputElement
38 | getInputElementById = getElementById gTypeHTMLInputElement castToHTMLInputElement
39 | 
40 | getImageElementById :: DocumentClass doc => doc -> String -> IO HTMLImageElement
41 | getImageElementById = getElementById gTypeHTMLImageElement castToHTMLImageElement
42 | 
43 | getElementById :: DocumentClass doc
44 |                => GType          -- ^ GObject type we want
45 |                -> (Element -> a) -- ^ Suitable cast operator
46 |                -> doc            -- ^ Document
47 |                -> String         -- ^ ID of the element
48 |                -> IO a
49 | getElementById gtype cast doc elementId = do
50 |     maybeElement <- documentGetElementById doc elementId
51 |     case maybeElement of
52 |         Just e | e `isA` gtype -> return (cast e)
53 |         Just _  -> error $ "Element '" ++ elementId ++ "' found, but wrong type"
54 |         Nothing -> error $ "Element '" ++ elementId ++ "' not found"
55 | 
56 | createDivElement :: DocumentClass doc => doc -> IO HTMLDivElement
57 | createDivElement = createElement gTypeHTMLDivElement castToHTMLDivElement "div"
58 | 
59 | createCanvasElement :: DocumentClass doc => doc -> IO HTMLCanvasElement
60 | createCanvasElement = createElement gTypeHTMLCanvasElement castToHTMLCanvasElement "canvas"
61 | 
62 | createElement :: DocumentClass doc
63 |               => GType          -- ^ GObject type we want
64 |               -> (Element -> a) -- ^ Suitable cast operator
65 |               -> String         -- ^ element type
66 |               -> doc            -- ^ Document
67 |               -> IO a
68 | createElement gtype cast elementType doc = do
69 |     maybeElement <- documentCreateElement doc elementType
70 |     case maybeElement of
71 |         Just e | e `isA` gtype -> return (cast e)
72 |         Just _  -> error $ "Created an '" ++ elementType ++ "', but it was the wrong type"
73 |         Nothing -> error $ "Failed to create a '" ++ elementType ++ "'"
74 | 
75 | 
76 | 


--------------------------------------------------------------------------------
/mloc-js/src/Demo/Threading.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE TemplateHaskell, QuasiQuotes, ScopedTypeVariables, Rank2Types #-}
 2 | -----------------------------------------------------------------------------
 3 | --
 4 | -- Module      :  Demo.Threading
 5 | -- Copyright   :
 6 | -- License     :  BSD3
 7 | --
 8 | -- |
 9 | --
10 | -----------------------------------------------------------------------------
11 | 
12 | module Demo.Threading (
13 |     counting
14 |   , primes
15 |   , isPrime
16 | ) where
17 | 
18 | import WebKitUtils
19 |        (getDivElementById, getInputElementById, getImageElementById)
20 | import Control.Monad.Trans ( liftIO )
21 | import GHCJS.DOM (postGUISync)
22 | import GHCJS.DOM.Types
23 |        (Document(..), HTMLDivElement(..))
24 | import Control.Concurrent
25 |        (putMVar, tryTakeMVar, takeMVar, newEmptyMVar, threadDelay, forkIO)
26 | import Control.Monad (forever, forM_)
27 | import GHCJS.DOM.HTMLElement
28 |        (htmlElementSetInnerHTML, htmlElementSetInnerText)
29 | import Data.Text.Lazy (Text, unpack)
30 | import Text.Blaze.Html.Renderer.Text (renderHtml)
31 | import Text.Hamlet (Html, shamlet)
32 | import GHCJS.DOM.HTMLInputElement
33 |        (htmlInputElementGetValue)
34 | import GHCJS.DOM.Element
35 |        (elementSetAttribute, elementOnkeyup, elementOnkeypress,
36 |         elementOnkeydown)
37 | 
38 | -- | Count to 10 slowly
39 | counting :: IO ()
40 | counting = do
41 |     forkIO $ do
42 |         forM_ [1..10] $ \ n -> do
43 |             print n
44 |             threadDelay 1000000
45 |         putStrLn "POW!!!"
46 |     return ()
47 | 
48 | 
49 | primes :: Document -> HTMLDivElement -> IO ()
50 | primes doc example = do
51 |     htmlElementSetInnerHTML example . unpack $ renderHtml
52 |         [shamlet|$newline always
53 |             <p>
54 |                 Know any good prime numbers?
55 |                 <input #num size="8">
56 |                 <div #prime>
57 |         |]
58 |     numInput <- getInputElementById doc "num"
59 |     prime    <- getDivElementById   doc "prime"
60 | 
61 |     -- Single worker thread and a queue with just one value.
62 |     next <- newEmptyMVar
63 |     forkIO . forever $ do
64 |       n <- takeMVar next
65 |       postGUISync . htmlElementSetInnerHTML prime . unpack $ validatePrime n
66 | 
67 |     -- Something to set the next work item
68 |     let setNext = do
69 |                     n <- htmlInputElementGetValue numInput
70 |                     tryTakeMVar next -- Discard existing next item
71 |                     putMVar next n
72 | 
73 |     -- Lets wire up some events
74 |     elementOnkeydown  numInput (liftIO setNext)
75 |     elementOnkeyup  numInput (liftIO setNext)
76 |     elementOnkeypress numInput (liftIO setNext)
77 |     return ()
78 | 
79 | isPrime :: Integer -> Bool
80 | isPrime p = p > 1 && (all (\n -> p `mod` n /= 0)
81 |                      $ takeWhile (\n -> n*n <= p) [2..])
82 | 
83 | validatePrimeMessage :: Integer -> Html
84 | validatePrimeMessage p | isPrime p = [shamlet|$newline always
85 |                                         <b>Yes</b>, #{p} is a prime|]
86 |                        | otherwise = [shamlet|$newline always
87 |                                         <b>No</b>, #{p} is not a prime|]
88 | 
89 | validatePrime :: String -> Text
90 | validatePrime s = renderHtml $
91 |   case reads s of
92 |     [(n, "")] -> validatePrimeMessage n
93 |     _         -> [shamlet|$newline always
94 |                     <b>No</b>, that is not a number|]
95 | 
96 | 


--------------------------------------------------------------------------------
/fay-hello/src/Main.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE TemplateHaskell, QuasiQuotes #-}
 2 | module Main (
 3 |     main
 4 | ) where
 5 | 
 6 | import Prelude hiding (writeFile)
 7 | import Text.Julius (julius, renderJavascript)
 8 | import Text.Hamlet (defaultHamletSettings, shamlet, Html)
 9 | import Text.Blaze.Html.Renderer.Text (renderHtml)
10 | import Text.Hamlet.RT (renderHamletRT, parseHamletRT)
11 | import Data.Text.Lazy.IO (writeFile)
12 | import System.FilePath ((</>))
13 | import Paths_fay_hello_js (getBinDir)
14 | import Generator.Minify (minify, defaultMinify)
15 | import System.Environment (getArgs)
16 | import Control.Applicative ((<$>))
17 | 
18 | main = do
19 |     args <- getArgs
20 |     jsexe <- (</> "fay-hello-js.jsexe") <$> getBinDir
21 |     writeFile (jsexe </> "hello.js") $ renderJavascript $ [julius|
22 |             window.onload = function(){
23 |                 goog.debug.Console.autoInstall();
24 |                 $hs_loadPath = "./";
25 | 
26 |                 // Must be called first
27 |                 $hs_init();
28 | 
29 |                 var input = document.getElementById("fayIn");
30 |                 var autoRun = document.getElementById("autoRun");
31 |                 var compile = document.getElementById("compile");
32 |                 var output = document.getElementById("fayOut");
33 |                 compile.onclick = function() {
34 |                     $hs_runIO([
35 |                         $$$Main_compileFromTo,
36 |                         $hs_mkBool(autoRun.checked),
37 |                         $hs_toString(input.value)
38 |                         ],
39 |                         function(str) {
40 |                             $hs_fromString([str],
41 |                                 function(result) {
42 |                                     output.value = result;});});
43 |                 }
44 |             }
45 |         |] ()
46 | 
47 |     writeFile (jsexe </> "index.html") $ renderHtml [shamlet|
48 |       <html>
49 |         <head>
50 |             <script type="text/javascript" src="rts.js">
51 |             <script type="text/javascript" src="main.js">
52 |             <title>GHCJS Examples - Fay
53 |         #{body}|]
54 | 
55 |     writeFile (jsexe </> "index_raw.html") $ renderHtml [shamlet|
56 |       <html>
57 |         <head>
58 |             <script type="text/javascript" src="../closure-library/closure/goog/base.js">
59 |             <script type="text/javascript">
60 |                 goog.require('goog.math.Long');
61 |                 goog.require('goog.math.Integer');
62 |                 goog.require('goog.debug.Logger');
63 |                 goog.require('goog.debug.Console');
64 |             <script type="text/javascript" src="../rts/rts-options.js">
65 |             <script type="text/javascript" src="../rts/rts-common.js">
66 |             <script type="text/javascript" src="../rts/rts-trampoline.js">
67 |             <script type="text/javascript" src="hsloader.js">
68 |             <script type="text/javascript" src="hello.js">
69 |             <title>GHCJS Examples
70 |         #{body}|]
71 | 
72 |     minify jsexe [jsexe </> "hello.js"] defaultMinify args
73 |   where
74 |     body = [shamlet|
75 |         <body #slideBody>
76 |             <textarea #fayIn rows="20" cols="120">
77 |             <p>
78 |                 <input #autoRun type="checkbox">Include auto run code
79 |                 <button #compile>Compile Fay
80 |             <textarea #fayOut rows="20" cols="120">
81 |             <div #log>
82 |         |]
83 | 
84 | 


--------------------------------------------------------------------------------
/weblog/balls1/balls1.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE CPP, OverloadedStrings, TypeFamilies, JavaScriptFFI #-}
  2 | 
  3 | module Main where
  4 | 
  5 | import           Control.Applicative
  6 | import           Control.Concurrent
  7 | import           Control.Monad
  8 | import           Data.Default
  9 | import           Data.VectorSpace
 10 | import           System.Random
 11 | 
 12 | import           FRP.Sodium
 13 | 
 14 | import           JavaScript.JQuery hiding (Event)
 15 | import           GHCJS.Types
 16 | import           GHCJS.Foreign
 17 | 
 18 | #ifdef __GHCJS__
 19 | foreign import javascript unsafe "Date.now()"
 20 |   now :: IO Double
 21 | foreign import javascript unsafe "$3.css($1,$2+'px')"
 22 |   setCssPx :: JSString -> Double -> JQuery -> IO ()
 23 | #else
 24 | now            = return 0
 25 | setCssPx _ _ _ = undefined
 26 | #endif
 27 | 
 28 | data R2 = R2 { _x :: Double, _y :: Double }
 29 |   deriving (Show, Eq, Ord)
 30 | 
 31 | instance AdditiveGroup R2 where
 32 |   zeroV = R2 0 0
 33 |   R2 x1 y1 ^+^ R2 x2 y2 = R2 (x1+x2) (y1+y2)
 34 |   negateV (R2 x y) = R2 (negate x) (negate y)
 35 | 
 36 | instance VectorSpace R2 where
 37 |   type Scalar R2 = Double
 38 |   s *^ (R2 x y) = R2 (s*x) (s*y)
 39 | 
 40 | instance InnerSpace R2 where
 41 |   (R2 x1 y1) <.> (R2 x2 y2) = (x1*x2)+(y1*y2)
 42 | 
 43 | main :: IO ()
 44 | main = do
 45 |   body <- select "body"
 46 |   bodySize <- size body
 47 |   mouse <- mousePosition body
 48 |   startSize <- sync (sample bodySize)
 49 |   (stepper, pushStepper) <- sync newEvent
 50 |   let stepper' = snapshotWith (,) stepper ((,) <$> mouse <*> bodySize)
 51 |   replicateM_ 10 (startPos bodySize >>= \start -> ball body start stepper')
 52 |   let step t0 = do
 53 |         t1 <- now
 54 |         sync (pushStepper $ t1-t0)
 55 |         threadDelay 1
 56 |         step t1
 57 |   step =<< now
 58 | 
 59 | startPos :: Behaviour R2 -> IO R2
 60 | startPos size = do
 61 |   R2 mx my <- sync (sample size)
 62 |   R2 <$> randomRIO (0,mx) <*> randomRIO (0,my)
 63 | 
 64 | ball :: JQuery
 65 |      -> R2
 66 |      -> Event (Double, (R2, R2))
 67 |      -> IO (Behaviour R2)
 68 | ball parent startPos step = do
 69 |   b <- select "<img src='ball.png' width='25' height='25' />"
 70 |   setCss "position" "absolute" b
 71 |   appendJQuery b parent
 72 |   let updCss prop f x = void (setCssPx prop (f x) b)
 73 |   pos <- sync (hold startPos =<< collectE upd initial step)
 74 |   sync (listen (values pos) $ \x -> updCss "left" _x x >> updCss "top" _y x)
 75 |   return pos
 76 |     where
 77 |       initial = (startPos, R2 0 0)
 78 |       upd (dt,(m,s)) (x,v) =
 79 |         let r          = m ^-^ x
 80 |             a          = (5 * recip (300 + magnitudeSq r)) *^ normalized r
 81 |             t@(x', v') = clamp s 25 (x ^+^ (dt *^ v)) ((0.9995 ** dt) *^ (v ^+^ (dt *^ a)))
 82 |         in  (x',t)
 83 | 
 84 | clamp :: R2 -> Double -> R2 -> R2 -> (R2, R2)
 85 | clamp size objSize x v = (R2 xx xy, R2 vx vy)
 86 |   where
 87 |     (xx, vx) = clamp' _x
 88 |     (xy, vy) = clamp' _y
 89 |     clamp' f
 90 |       | x' < 0    = (-x', abs v')
 91 |       | x' > m    = (2 * m - x', negate (abs v'))
 92 |       | otherwise = (x', v')
 93 |       where
 94 |         x' = f x
 95 |         v' = f v
 96 |         m  = f size - objSize
 97 | 
 98 | -- size of the element, in pixels
 99 | size :: JQuery -> IO (Behaviour R2)
100 | size elem = do
101 |   (b, push) <- sync . newBehaviour =<< dims
102 |   let handler _ = sync . push =<< dims
103 |   on handler "resize" def elem
104 |   return b
105 |     where
106 |       dims = R2 <$> getWidth elem
107 |                 <*> getHeight elem
108 | 
109 | -- the mouse position, in pixels from the top-left corner
110 | mousePosition :: JQuery -> IO (Behaviour R2)
111 | mousePosition elem = do
112 |   (b, push) <- sync $ newBehaviour (R2 0 0)
113 |   let handler ev = do
114 |         x <- pageX ev
115 |         y <- pageY ev
116 |         sync $ push (R2 x y)
117 |   on handler "mousemove" def elem
118 |   return b
119 | 


--------------------------------------------------------------------------------
/try-purescript/data/tryps.css:
--------------------------------------------------------------------------------
  1 | html {
  2 |     padding: 0;
  3 |     margin: 0;
  4 |     overflow: hidden;
  5 |     position: fixed;
  6 |     top: 0;
  7 |     bottom: 0;
  8 |     width: 100%;
  9 | }
 10 | 
 11 | body {
 12 |     font-family: "Helvetica Neue", Helvetica, Arial, sans-serif;
 13 | }
 14 | 
 15 | #content {
 16 |     background-color: #eee;
 17 |     position: absolute;
 18 |     margin: 0;
 19 |     padding: 0;
 20 |     left: 0;
 21 |     top: 0;
 22 |     bottom: 25px;
 23 |     right: 0;
 24 | }
 25 | 
 26 | #source_outer {
 27 |     position: absolute;
 28 |     left: 0;
 29 |     top: 10px;
 30 |     bottom: 10px;
 31 |     width: 45%;
 32 |     margin: 0;
 33 | }
 34 | 
 35 | #source {
 36 |     position: relative;
 37 |     background-color: #fff;
 38 |     box-shadow: inset 0 0 8px rgba(0,0,0,0.3);
 39 |     padding: 0;
 40 |     margin-top: 0;
 41 |     margin-left: 10px;
 42 |     margin-right: 5px;
 43 |     margin-bottom: 0;
 44 |     height: 100%;
 45 | }
 46 | 
 47 | #source div.CodeMirror {
 48 |     box-shadow: inset 0 0 8px rgba(0,0,0,0.3);
 49 |     margin: 0;
 50 |     padding: 0;
 51 |     width: 100%;
 52 |     height: 100%;
 53 | }
 54 | 
 55 | #source div.CodeMirror-gutters {
 56 |     background-color: rgba(0,0,0,0.02);
 57 | }
 58 | 
 59 | #result_outer {
 60 |     overflow: hidden;
 61 |     position: absolute;
 62 |     width: 55%;
 63 |     margin: 0;
 64 |     padding: 0;
 65 |     top: 10px;
 66 |     bottom: 10px;
 67 |     right: 0;
 68 | }
 69 | 
 70 | #result {
 71 |     overflow: scroll;
 72 |     background-color: #fff;
 73 |     box-shadow: inset 0 0 8px rgba(0,0,0,0.3);
 74 |     padding-top: 0;
 75 |     padding-bottom: 0;
 76 |     padding-left: 5px;
 77 |     padding-right: 5px;
 78 |     margin-top: 0;
 79 |     margin-left: 5px;
 80 |     margin-right: 10px;
 81 |     margin-bottom: 0;
 82 |     height: 100%;
 83 | }
 84 | 
 85 | #result_outer.run #result {
 86 |     height: 60%;
 87 | }
 88 | 
 89 | #run_button_wrapper {
 90 |     position: absolute;
 91 |     top: 0;
 92 |     right: 10px;
 93 |     padding-top: 0;
 94 |     padding-right: 0;
 95 |     padding-left: 10px;
 96 |     padding-bottom: 10px;
 97 |     overflow: hidden;
 98 | }
 99 | 
100 | #run_button {
101 |     box-shadow: 0 0 8px rgba(0,0,0,0.3);
102 |     cursor: pointer;
103 |     font-size: 70%;
104 |     background-color: #eee;
105 |     margin: 0;
106 |     display: none;
107 |     min-width: 120px;
108 |     padding: 6px 6px 6px 6px;
109 |     border-bottom-left-radius: 4px;
110 | }
111 | 
112 | #run_button_content {
113 |     color: #444;
114 |     opacity: 0.8;
115 |     padding: 0 0 0 25px;
116 |     background-image: url(run_button.png);
117 |     background-repeat: no-repeat;
118 |     background-position: 5px 1px;
119 | }
120 | 
121 | #run_button:hover #run_button_content {
122 |     opacity: 1.0;
123 | }
124 | 
125 | #result_outer.run #run_button,
126 | #result_outer.runnable #run_button {
127 |     display: block;
128 | }
129 | 
130 | #result_run {
131 |     display: none;
132 |     position: absolute;
133 |     padding-top: 0;
134 |     padding-bottom: 0;
135 |     padding-left: 5px;
136 |     padding-right: 5px;
137 |     margin-top: 0;
138 |     margin-left: 5px;
139 |     margin-right: 10px;
140 |     margin-bottom: 0;
141 |     left: 0;
142 |     bottom: 0;
143 |     right: 0;
144 |     height: 40%
145 | }
146 | 
147 | #result_run_spacer {
148 |     background-color: #fff;
149 |     box-shadow: inset 0 0 8px rgba(0,0,0,0.3);
150 |     position: absolute;
151 |     top: 10px;
152 |     left: 0;
153 |     right: 0;
154 |     bottom: 0;
155 | }
156 | 
157 | #result_outer.run #result_run {
158 |     display: block;
159 | }
160 | 
161 | #run_output {
162 |     padding: 0;
163 |     margin: 0;
164 |     width: 100%;
165 |     height: 100%;
166 |     border: none;
167 | }
168 | 
169 | #result_outer.error #result {
170 |     background-color: #fee;
171 | }
172 | 
173 | #result_outer.busy #result {
174 |     background-repeat: no-repeat;
175 |     background-image: url(busy.gif);
176 |     background-position: 5px 40px;
177 | }
178 | 
179 | #footer {
180 |     background-color: #eee;
181 |     position: absolute;
182 |     left: 0;
183 |     bottom: 0;
184 |     right: 0;
185 |     height: 25px;
186 |     font-size: 75%;
187 |     color: #777;
188 |     display: table-cell;
189 |     vertical-align: middle;
190 |     text-align: center;
191 | }
192 | 
193 | #footer a {
194 |     color: #66a;
195 | }
196 | 


--------------------------------------------------------------------------------
/weblog/balls2/balls2.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE CPP, OverloadedStrings, TypeFamilies, JavaScriptFFI #-}
  2 | 
  3 | module Main where
  4 | 
  5 | import           Control.Applicative
  6 | import           Control.Monad
  7 | import           Data.Default
  8 | import           Data.IORef
  9 | import           Data.VectorSpace
 10 | import           System.Random
 11 | 
 12 | import           FRP.Sodium
 13 | 
 14 | import           JavaScript.JQuery hiding (Event, animate)
 15 | import           GHCJS.Types
 16 | import           GHCJS.Foreign
 17 | 
 18 | #ifdef __GHCJS__
 19 | foreign import javascript unsafe "Date.now()" now :: IO Double
 20 | foreign import javascript unsafe "$3.css($1,$2+'px')"
 21 |   setCssPx :: JSString -> Double -> JQuery -> IO ()
 22 | foreign import javascript unsafe
 23 |   "var req = window.requestAnimationFrame ||\
 24 |              window.mozRequestAnimationFrame ||\
 25 |              window.webkitRequestAnimationFrame ||\
 26 |              window.msRequestAnimationFrame;\
 27 |    var f = function() { $1(); req(f); };\
 28 |    req(f);"
 29 |   animate :: JSFun (IO ()) -> IO ()
 30 | #else
 31 | now            = return 0
 32 | setCssPx _ _ _ = undefined
 33 | animate _      = undefined
 34 | #endif
 35 | 
 36 | data R2 = R2 { _x :: Double, _y :: Double }
 37 |   deriving (Show, Eq, Ord)
 38 | 
 39 | instance AdditiveGroup R2 where
 40 |   zeroV = R2 0 0
 41 |   R2 x1 y1 ^+^ R2 x2 y2 = R2 (x1+x2) (y1+y2)
 42 |   negateV (R2 x y) = R2 (negate x) (negate y)
 43 | 
 44 | instance VectorSpace R2 where
 45 |   type Scalar R2 = Double
 46 |   s *^ (R2 x y) = R2 (s*x) (s*y)
 47 | 
 48 | instance InnerSpace R2 where
 49 |   (R2 x1 y1) <.> (R2 x2 y2) = (x1*x2)+(y1*y2)
 50 | 
 51 | main :: IO ()
 52 | main = do
 53 |   body <- select "body"
 54 |   bodySize <- size body
 55 |   mouse <- mousePosition body
 56 |   startSize <- sync (sample bodySize)
 57 |   (stepper, pushStepper) <- sync newEvent
 58 |   let stepper' = snapshotWith (,) stepper ((,) <$> mouse <*> bodySize)
 59 |   replicateM_ 10 (startPos bodySize >>= \start -> ball body start stepper')
 60 |   t <- newIORef =<< now
 61 |   let step = do
 62 |         t0 <- readIORef t
 63 |         t1 <- now
 64 |         sync (pushStepper $ t1-t0)
 65 |         writeIORef t t1
 66 |   animate =<< syncCallback NeverRetain False step
 67 | 
 68 | startPos :: Behaviour R2 -> IO R2
 69 | startPos size = do
 70 |   R2 mx my <- sync (sample size)
 71 |   R2 <$> randomRIO (0,mx) <*> randomRIO (0,my)
 72 | 
 73 | ball :: JQuery
 74 |      -> R2
 75 |      -> Event (Double, (R2, R2))
 76 |      -> IO (Behaviour R2)
 77 | ball parent startPos step = do
 78 |   b <- select "<img src='ball.png' width='25' height='25' />"
 79 |   setCss "position" "absolute" b
 80 |   appendJQuery b parent
 81 |   let updCss prop f x = void (setCssPx prop (f x) b)
 82 |   pos <- sync (hold startPos =<< collectE upd initial step)
 83 |   sync (listen (values pos) $ \x -> updCss "left" _x x >> updCss "top" _y x)
 84 |   return pos
 85 |     where
 86 |       initial = (startPos, R2 0 0)
 87 |       upd (dt,(m,s)) (x,v) =
 88 |         let r          = m ^-^ x
 89 |             a          = (5 * recip (300 + magnitudeSq r)) *^ normalized r
 90 |             t@(x', v') = clamp s 25 (x ^+^ (dt *^ v)) ((0.9995 ** dt) *^ (v ^+^ (dt *^ a)))
 91 |         in  (x',t)
 92 | 
 93 | clamp :: R2 -> Double -> R2 -> R2 -> (R2, R2)
 94 | clamp size objSize x v = (R2 xx xy, R2 vx vy)
 95 |   where
 96 |     (xx, vx) = clamp' _x
 97 |     (xy, vy) = clamp' _y
 98 |     clamp' f
 99 |       | x' < 0    = (-x', abs v')
100 |       | x' > m    = (2 * m - x', negate (abs v'))
101 |       | otherwise = (x', v')
102 |       where
103 |         x' = f x
104 |         v' = f v
105 |         m  = f size - objSize
106 | 
107 | -- size of the element, in pixels
108 | size :: JQuery -> IO (Behaviour R2)
109 | size elem = do
110 |   (b, push) <- sync . newBehaviour =<< dims
111 |   let handler _ = sync . push =<< dims
112 |   on handler "resize" def elem
113 |   return b
114 |     where
115 |       dims = R2 <$> getWidth elem
116 |                 <*> getHeight elem
117 | 
118 | -- the mouse position, in pixels from the top-left corner
119 | mousePosition :: JQuery -> IO (Behaviour R2)
120 | mousePosition elem = do
121 |   (b, push) <- sync $ newBehaviour (R2 0 0)
122 |   let handler ev = do
123 |         x <- pageX ev
124 |         y <- pageY ev
125 |         sync $ push (R2 x y)
126 |   on handler "mousemove" def elem
127 |   return b
128 | 


--------------------------------------------------------------------------------
/mloc-js/src/Main.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE ScopedTypeVariables #-}
  2 | {-# LANGUAGE QuasiQuotes #-}
  3 | {-# LANGUAGE TemplateHaskell #-}
  4 | {-# LANGUAGE NoMonomorphismRestriction #-}
  5 | -----------------------------------------------------------------------------
  6 | --
  7 | -- Module      :  Main
  8 | -- Copyright   :
  9 | -- License     :  BSD
 10 | --
 11 | -- |
 12 | --
 13 | -----------------------------------------------------------------------------
 14 | 
 15 | module Main (
 16 |     main
 17 | ) where
 18 | 
 19 | import Prelude hiding((!!))
 20 | import Control.Applicative ((<$>))
 21 | import GHCJS.DOM (runWebGUI)
 22 | -- import Graphics.UI.Gtk (postGUISync, postGUIAsync)
 23 | import GHCJS.DOM
 24 |        (webViewGetDomDocument)
 25 | import GHCJS.DOM.Document
 26 |        (documentGetElementById, documentCreateElement, documentGetBody)
 27 | import GHCJS.DOM.Types
 28 |        (Document(..), HTMLDivElement(..), WebView(..), castToHTMLElement,
 29 |         castToHTMLInputElement, castToHTMLDivElement)
 30 | import GHCJS.DOM.HTMLElement
 31 |        (htmlElementSetInnerText, htmlElementSetInnerHTML)
 32 | import Data.Text.Lazy (Text, unpack)
 33 | import Text.Blaze.Html.Renderer.Text (renderHtml)
 34 | import Text.Hamlet (Html, shamlet)
 35 | import GHCJS.DOM.Element
 36 |        (elementOnclick, elementFocus, elementOnkeypress, elementOnkeyup,
 37 |         elementOnkeydown, elementGetStyle)
 38 | import GHCJS.DOM.CSSStyleDeclaration
 39 |        (cssStyleDeclarationSetProperty)
 40 | import GHCJS.DOM.Node
 41 |        (nodeAppendChild, nodeInsertBefore)
 42 | import Control.Monad.Reader (ReaderT(..))
 43 | import Language.Javascript.JSC
 44 |        (call, JSC, JSNull(..), evalJM, val, array, eval, new, fun,
 45 |         valToText, valToNumber, deRefVal, (<#), (#), (!!), js, jsg)
 46 | import Control.Lens ((^.))
 47 | import Control.Monad.Trans (liftIO)
 48 | import Control.Concurrent
 49 |        (putMVar, tryTakeMVar, takeMVar, newEmptyMVar, threadDelay, forkIO)
 50 | import Control.Monad (when, forever)
 51 | import GHCJS.DOM.HTMLInputElement
 52 |        (htmlInputElementGetValue)
 53 | import System.IO (hPutStrLn, stdout, hFlush, stderr)
 54 | import Language.Javascript.JSC.Value (JSValueRef, JSValue(..))
 55 | import qualified Data.Text as T (pack)
 56 | import Language.Javascript.JMacro (jLam, ToJExpr(..), JStat(..))
 57 | import GHCJS.DOM.EventM (mouseShiftKey)
 58 | import Engine (engine)
 59 | import Freecell (mkFreecell)
 60 | import Language.Haskell.TH (pprint, runQ)
 61 | import Language.Haskell.HsColour.CSS (hscolour)
 62 | import WebKitUtils
 63 | import Demo.DOM
 64 | import Demo.Threading
 65 | import Demo.JavaScriptFFI
 66 | import Demo.Life
 67 | import Demo.LazyLoading
 68 | 
 69 | mainPage :: WebView -> Document -> HTMLDivElement -> IO ()
 70 | mainPage webView doc div = do
 71 |     -- Lets use some Hamlet to replace HTerm with some HTML
 72 |     htmlElementSetInnerHTML div . unpack $ renderHtml [shamlet|$newline always
 73 |         <link href="//netdna.bootstrapcdn.com/twitter-bootstrap/2.3.0/css/bootstrap-combined.min.css" rel="stylesheet">
 74 |         <h1 #heading>MLOC.JS GHCJS Examples
 75 |         <div .row>
 76 |             <div .span2 #menu>
 77 |                 <ul>
 78 |                     <li #dom><a style="cursor: pointer">DOM Interface</a>
 79 |                     <li>Threading
 80 |                         <ul>
 81 |                             <li #counting><a style="cursor: pointer">Count to 10</a>
 82 |                             <li #primes><a style="cursor: pointer">Check Primes</a>
 83 |                     <li>JavaScript FFI (JSC)
 84 |                         <ul>
 85 |                             <li #canvasDemo><a style="cursor: pointer">Using Canvas</a>
 86 |                             <li #callHaskell><a style="cursor: pointer">Call Haskell</a>
 87 |                             <li #life><a style="cursor: pointer">Life</a>
 88 |                     <li #lazyload><a style="cursor: pointer">Lazy Loading</a>
 89 |             <div .span10 #example>
 90 |     |]
 91 |     example <- getDivElementById doc "example"
 92 |     menuItem "dom"         $ helloDOM doc
 93 |     menuItem "counting"    $ counting
 94 |     menuItem "primes"      $ primes doc example
 95 |     menuItem "canvasDemo"  $ canvasDemo webView doc example
 96 |     menuItem "callHaskell" $ callHaskell webView
 97 |     menuItem "life"        $ life webView doc example
 98 |     menuItem "lazyload"    $ lazyLoad_freecell webView doc example
 99 |     return ()
100 |   where
101 |     menuItem name f = do
102 |         item <- getHTMLElementById doc name
103 |         elementOnclick item . liftIO $ f
104 | 
105 | main :: IO ()
106 | main = do
107 |   -- Running a GUI creates a WebKitGtk window in native code,
108 |   -- but just returns the browser window when compiled to JavaScript
109 |   runWebGUI $ \ webView -> do
110 |     -- WebKitGtk provides the normal W3C DOM functions
111 |     Just doc <- webViewGetDomDocument webView
112 |     Just body <- documentGetBody doc
113 | 
114 |     -- Create a div to put our page content in
115 |     Just div <- fmap castToHTMLDivElement <$> documentCreateElement doc "div"
116 | 
117 |     -- Now we need to add this div to the document body
118 |     -- If we are in the browser then let's shrink the terminal window to make room
119 |     mbTerminal <- fmap castToHTMLDivElement <$> documentGetElementById doc "terminal"
120 |     case mbTerminal of
121 |       Just terminal -> do
122 |         Just style <- elementGetStyle terminal
123 |         cssStyleDeclarationSetProperty style "height" "200px" ""
124 |         cssStyleDeclarationSetProperty style "position" "absolute" ""
125 |         cssStyleDeclarationSetProperty style "bottom" "0" ""
126 |         nodeInsertBefore body (Just div) (Just terminal)
127 |       _ -> do
128 |         nodeAppendChild body (Just div)
129 | 
130 |     -- Load the main page
131 |     mainPage webView doc div
132 | 


--------------------------------------------------------------------------------
/try-purescript/codemirror/addon/edit/matchbrackets.js:
--------------------------------------------------------------------------------
  1 | // CodeMirror, copyright (c) by Marijn Haverbeke and others
  2 | // Distributed under an MIT license: http://codemirror.net/LICENSE
  3 | 
  4 | (function(mod) {
  5 |   if (typeof exports == "object" && typeof module == "object") // CommonJS
  6 |     mod(require("../../lib/codemirror"));
  7 |   else if (typeof define == "function" && define.amd) // AMD
  8 |     define(["../../lib/codemirror"], mod);
  9 |   else // Plain browser env
 10 |     mod(CodeMirror);
 11 | })(function(CodeMirror) {
 12 |   var ie_lt8 = /MSIE \d/.test(navigator.userAgent) &&
 13 |     (document.documentMode == null || document.documentMode < 8);
 14 | 
 15 |   var Pos = CodeMirror.Pos;
 16 | 
 17 |   var matching = {"(": ")>", ")": "(<", "[": "]>", "]": "[<", "{": "}>", "}": "{<"};
 18 | 
 19 |   function findMatchingBracket(cm, where, strict, config) {
 20 |     var line = cm.getLineHandle(where.line), pos = where.ch - 1;
 21 |     var match = (pos >= 0 && matching[line.text.charAt(pos)]) || matching[line.text.charAt(++pos)];
 22 |     if (!match) return null;
 23 |     var dir = match.charAt(1) == ">" ? 1 : -1;
 24 |     if (strict && (dir > 0) != (pos == where.ch)) return null;
 25 |     var style = cm.getTokenTypeAt(Pos(where.line, pos + 1));
 26 | 
 27 |     var found = scanForBracket(cm, Pos(where.line, pos + (dir > 0 ? 1 : 0)), dir, style || null, config);
 28 |     if (found == null) return null;
 29 |     return {from: Pos(where.line, pos), to: found && found.pos,
 30 |             match: found && found.ch == match.charAt(0), forward: dir > 0};
 31 |   }
 32 | 
 33 |   // bracketRegex is used to specify which type of bracket to scan
 34 |   // should be a regexp, e.g. /[[\]]/
 35 |   //
 36 |   // Note: If "where" is on an open bracket, then this bracket is ignored.
 37 |   //
 38 |   // Returns false when no bracket was found, null when it reached
 39 |   // maxScanLines and gave up
 40 |   function scanForBracket(cm, where, dir, style, config) {
 41 |     var maxScanLen = (config && config.maxScanLineLength) || 10000;
 42 |     var maxScanLines = (config && config.maxScanLines) || 1000;
 43 | 
 44 |     var stack = [];
 45 |     var re = config && config.bracketRegex ? config.bracketRegex : /[(){}[\]]/;
 46 |     var lineEnd = dir > 0 ? Math.min(where.line + maxScanLines, cm.lastLine() + 1)
 47 |                           : Math.max(cm.firstLine() - 1, where.line - maxScanLines);
 48 |     for (var lineNo = where.line; lineNo != lineEnd; lineNo += dir) {
 49 |       var line = cm.getLine(lineNo);
 50 |       if (!line) continue;
 51 |       var pos = dir > 0 ? 0 : line.length - 1, end = dir > 0 ? line.length : -1;
 52 |       if (line.length > maxScanLen) continue;
 53 |       if (lineNo == where.line) pos = where.ch - (dir < 0 ? 1 : 0);
 54 |       for (; pos != end; pos += dir) {
 55 |         var ch = line.charAt(pos);
 56 |         if (re.test(ch) && (style === undefined || cm.getTokenTypeAt(Pos(lineNo, pos + 1)) == style)) {
 57 |           var match = matching[ch];
 58 |           if ((match.charAt(1) == ">") == (dir > 0)) stack.push(ch);
 59 |           else if (!stack.length) return {pos: Pos(lineNo, pos), ch: ch};
 60 |           else stack.pop();
 61 |         }
 62 |       }
 63 |     }
 64 |     return lineNo - dir == (dir > 0 ? cm.lastLine() : cm.firstLine()) ? false : null;
 65 |   }
 66 | 
 67 |   function matchBrackets(cm, autoclear, config) {
 68 |     // Disable brace matching in long lines, since it'll cause hugely slow updates
 69 |     var maxHighlightLen = cm.state.matchBrackets.maxHighlightLineLength || 1000;
 70 |     var marks = [], ranges = cm.listSelections();
 71 |     for (var i = 0; i < ranges.length; i++) {
 72 |       var match = ranges[i].empty() && findMatchingBracket(cm, ranges[i].head, false, config);
 73 |       if (match && cm.getLine(match.from.line).length <= maxHighlightLen) {
 74 |         var style = match.match ? "CodeMirror-matchingbracket" : "CodeMirror-nonmatchingbracket";
 75 |         marks.push(cm.markText(match.from, Pos(match.from.line, match.from.ch + 1), {className: style}));
 76 |         if (match.to && cm.getLine(match.to.line).length <= maxHighlightLen)
 77 |           marks.push(cm.markText(match.to, Pos(match.to.line, match.to.ch + 1), {className: style}));
 78 |       }
 79 |     }
 80 | 
 81 |     if (marks.length) {
 82 |       // Kludge to work around the IE bug from issue #1193, where text
 83 |       // input stops going to the textare whever this fires.
 84 |       if (ie_lt8 && cm.state.focused) cm.display.input.focus();
 85 | 
 86 |       var clear = function() {
 87 |         cm.operation(function() {
 88 |           for (var i = 0; i < marks.length; i++) marks[i].clear();
 89 |         });
 90 |       };
 91 |       if (autoclear) setTimeout(clear, 800);
 92 |       else return clear;
 93 |     }
 94 |   }
 95 | 
 96 |   var currentlyHighlighted = null;
 97 |   function doMatchBrackets(cm) {
 98 |     cm.operation(function() {
 99 |       if (currentlyHighlighted) {currentlyHighlighted(); currentlyHighlighted = null;}
100 |       currentlyHighlighted = matchBrackets(cm, false, cm.state.matchBrackets);
101 |     });
102 |   }
103 | 
104 |   CodeMirror.defineOption("matchBrackets", false, function(cm, val, old) {
105 |     if (old && old != CodeMirror.Init)
106 |       cm.off("cursorActivity", doMatchBrackets);
107 |     if (val) {
108 |       cm.state.matchBrackets = typeof val == "object" ? val : {};
109 |       cm.on("cursorActivity", doMatchBrackets);
110 |     }
111 |   });
112 | 
113 |   CodeMirror.defineExtension("matchBrackets", function() {matchBrackets(this, true);});
114 |   CodeMirror.defineExtension("findMatchingBracket", function(pos, strict, config){
115 |     return findMatchingBracket(this, pos, strict, config);
116 |   });
117 |   CodeMirror.defineExtension("scanForBracket", function(pos, dir, style, config){
118 |     return scanForBracket(this, pos, dir, style, config);
119 |   });
120 | });
121 | 


--------------------------------------------------------------------------------
/multiple-pages/src/Main.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings, ScopedTypeVariables #-}
  2 | module Main (
  3 |     main
  4 |   , lazyLoad_wirePrime
  5 |   , lazyLoad_wireHamlet
  6 | ) where
  7 | 
  8 | import Prelude hiding (catch)
  9 | import Graphics.UI.Gtk.WebKit.GHCJS (currentWindow, runWebGUI)
 10 | import Control.Applicative ((<$>))
 11 | import Control.Concurrent
 12 |        (putMVar, tryTakeMVar, takeMVar, forkIO, newEmptyMVar)
 13 | import Control.Monad (forever)
 14 | import Control.Monad.Trans (liftIO)
 15 | import Control.Exception (catch)
 16 | import Graphics.UI.Gtk.WebKit.DOM.Document
 17 |        (documentCreateElement, documentGetElementById, documentGetBody)
 18 | import Graphics.UI.Gtk.WebKit.Types
 19 |        (HTMLDivElement(..), HTMLTextAreaElement(..), castToHTMLDivElement,
 20 |         castToHTMLTextAreaElement, HTMLElement(..), HTMLInputElement(..),
 21 |         castToHTMLElement, castToHTMLInputElement)
 22 | import Graphics.UI.Gtk.WebKit.WebView (webViewGetDomDocument)
 23 | import Graphics.UI.Gtk.WebKit.DOM.Element
 24 |        (elementOnkeypress, elementOnkeyup, elementOnkeydown,
 25 |         elementGetStyle, elementFocus)
 26 | import Graphics.UI.Gtk.WebKit.DOM.CSSStyleDeclaration
 27 |        (cssStyleDeclarationSetProperty)
 28 | import Graphics.UI.Gtk.WebKit.DOM.HTMLElement
 29 |        (htmlElementSetInnerHTML)
 30 | import Graphics.UI.Gtk.WebKit.DOM.HTMLInputElement
 31 |        (htmlInputElementGetValue)
 32 | import Data.Text.Lazy (Text, unpack)
 33 | import Text.Blaze.Html.Renderer.Text (renderHtml)
 34 | import Text.Hamlet (defaultHamletSettings, shamlet)
 35 | import Text.Blaze.Html (Html)
 36 | import Text.Hamlet.RT (renderHamletRT, parseHamletRT, HamletException(..))
 37 | import Graphics.UI.Gtk.WebKit.DOM.HTMLTextAreaElement
 38 |        (htmlTextAreaElementGetValue)
 39 | import System.IO (stdout, hFlush)
 40 | 
 41 | -- Think of this as a global "onLoad" for all the pages on your website
 42 | main = runWebGUI $ \ webView -> do
 43 |   mbBrowserWindow <- currentWindow
 44 |   case mbBrowserWindow of
 45 |     Nothing -> putStrLn "Hello from Native Haskell"
 46 |     _       -> putStrLn "Hello from JavaScript land"
 47 |   hFlush stdout
 48 | 
 49 |   Just doc <- webViewGetDomDocument webView
 50 | 
 51 |   -- Try to find prime number entry
 52 |   mbPrimeIn  <- fmap castToHTMLInputElement <$> documentGetElementById doc "prime-in"
 53 |   mbPrimeOut <- fmap castToHTMLElement      <$> documentGetElementById doc "prime-out"
 54 |   case (mbPrimeIn, mbPrimeOut) of
 55 |     (Just primeIn, Just primeOut) -> lazyLoad_wirePrime primeIn primeOut
 56 |     _                             -> return ()
 57 | 
 58 |   -- Try to find hamlet input output
 59 |   mbHamletIn  <- fmap castToHTMLTextAreaElement <$> documentGetElementById doc "hamlet-in"
 60 |   mbHamletOut <- fmap castToHTMLDivElement      <$> documentGetElementById doc "hamlet-out"
 61 |   case (mbHamletIn, mbHamletOut) of
 62 |     (Just hamletIn, Just hamletOut) -> lazyLoad_wireHamlet hamletIn hamletOut
 63 |     _                               -> return ()
 64 | 
 65 | {-# NOINLINE lazyLoad_wirePrime #-}
 66 | lazyLoad_wirePrime :: HTMLInputElement -> HTMLElement -> IO ()
 67 | lazyLoad_wirePrime primeIn primeOut = do
 68 |   -- Set the input focus
 69 |   elementFocus primeIn
 70 | 
 71 |   -- We don't want to work on more than on prime number test at a time.
 72 |   -- So we will have a single worker thread and a queue with just one value.
 73 |   next <- newEmptyMVar
 74 |   forkIO . forever $ do
 75 |     n <- takeMVar next
 76 |     htmlElementSetInnerHTML primeOut . unpack $ validatePrime n
 77 | 
 78 |   -- Something to set the next work item
 79 |   let setNext = do
 80 |                   n <- htmlInputElementGetValue primeIn
 81 |                   htmlElementSetInnerHTML primeOut . unpack $ validatePrime n
 82 |                   tryTakeMVar next -- Discard existing next item
 83 |                   putMVar next n
 84 | 
 85 |   -- Lets wire up some events
 86 |   elementOnkeydown  primeIn (liftIO setNext)
 87 |   elementOnkeyup    primeIn (liftIO setNext)
 88 |   elementOnkeypress primeIn (liftIO setNext)
 89 |   return ()
 90 | 
 91 | -- Integer uses goog.math.Integer compiled to Javascript
 92 | isPrime :: Integer -> Bool
 93 | isPrime p = p > 1 && (all (\n -> p `mod` n /= 0)
 94 |                      $ takeWhile (\n -> n*n <= p) [2..])
 95 | 
 96 | validatePrimeMessage :: Integer -> Html
 97 | validatePrimeMessage p | isPrime p = [shamlet|$newline always
 98 |                                         <b>Yes</b>, #{p} is a prime|]
 99 |                        | otherwise = [shamlet|$newline always
100 |                                         <b>No</b>, #{p} is not a prime|]
101 | 
102 | validatePrime :: String -> Text
103 | validatePrime s = renderHtml $
104 |   case reads s of
105 |     [(n, "")] -> validatePrimeMessage n
106 |     _         -> [shamlet|$newline always
107 |                     <b>No</b>, that is not a number|]
108 | 
109 | {-# NOINLINE lazyLoad_wireHamlet #-}
110 | lazyLoad_wireHamlet :: HTMLTextAreaElement -> HTMLDivElement -> IO ()
111 | lazyLoad_wireHamlet hamletIn hamletOut = do
112 |   -- Set the input focus
113 |   elementFocus hamletIn
114 | 
115 |   -- We don't want to work on more than on prime number test at a time.
116 |   -- So we will have a single worker thread and a queue with just one value.
117 |   next <- newEmptyMVar
118 |   forkIO . forever $ do
119 |     n <- takeMVar next
120 |     out <- tryHamlet n
121 |     htmlElementSetInnerHTML hamletOut $ unpack out
122 | 
123 |   -- Something to set the next work item
124 |   let setNext = do
125 |                   n <- htmlTextAreaElementGetValue hamletIn
126 |                   tryTakeMVar next -- Discard existing next item
127 |                   putMVar next n
128 | 
129 |   -- Lets wire up some events
130 |   elementOnkeydown  hamletIn (liftIO setNext)
131 |   elementOnkeyup    hamletIn (liftIO setNext)
132 |   elementOnkeypress hamletIn (liftIO setNext)
133 |   return ()
134 | 
135 | tryHamlet :: String -> IO Text
136 | tryHamlet h = (do
137 |     rt   <- parseHamletRT defaultHamletSettings h
138 |     html <- renderHamletRT rt [] (\_ _ -> "")
139 |     return $ renderHtml html)
140 |   `catch`
141 |     \ (e :: HamletException) -> return $ renderHtml [shamlet|#{show e}|]
142 | 


--------------------------------------------------------------------------------
/try-purescript/codemirror/lib/codemirror.css:
--------------------------------------------------------------------------------
  1 | /* BASICS */
  2 | 
  3 | .CodeMirror {
  4 |   /* Set height, width, borders, and global font properties here */
  5 |   font-family: monospace;
  6 |   height: 300px;
  7 | }
  8 | .CodeMirror-scroll {
  9 |   /* Set scrolling behaviour here */
 10 |   overflow: auto;
 11 | }
 12 | 
 13 | /* PADDING */
 14 | 
 15 | .CodeMirror-lines {
 16 |   padding: 4px 0; /* Vertical padding around content */
 17 | }
 18 | .CodeMirror pre {
 19 |   padding: 0 4px; /* Horizontal padding of content */
 20 | }
 21 | 
 22 | .CodeMirror-scrollbar-filler, .CodeMirror-gutter-filler {
 23 |   background-color: white; /* The little square between H and V scrollbars */
 24 | }
 25 | 
 26 | /* GUTTER */
 27 | 
 28 | .CodeMirror-gutters {
 29 |   border-right: 1px solid #ddd;
 30 |   background-color: #f7f7f7;
 31 |   white-space: nowrap;
 32 | }
 33 | .CodeMirror-linenumbers {}
 34 | .CodeMirror-linenumber {
 35 |   padding: 0 3px 0 5px;
 36 |   min-width: 20px;
 37 |   text-align: right;
 38 |   color: #999;
 39 |   -moz-box-sizing: content-box;
 40 |   box-sizing: content-box;
 41 | }
 42 | 
 43 | .CodeMirror-guttermarker { color: black; }
 44 | .CodeMirror-guttermarker-subtle { color: #999; }
 45 | 
 46 | /* CURSOR */
 47 | 
 48 | .CodeMirror div.CodeMirror-cursor {
 49 |   border-left: 1px solid black;
 50 | }
 51 | /* Shown when moving in bi-directional text */
 52 | .CodeMirror div.CodeMirror-secondarycursor {
 53 |   border-left: 1px solid silver;
 54 | }
 55 | .CodeMirror.cm-keymap-fat-cursor div.CodeMirror-cursor {
 56 |   width: auto;
 57 |   border: 0;
 58 |   background: #7e7;
 59 | }
 60 | .cm-animate-fat-cursor {
 61 |   width: auto;
 62 |   border: 0;
 63 |   -webkit-animation: blink 1.06s steps(1) infinite;
 64 |   -moz-animation: blink 1.06s steps(1) infinite;
 65 |   animation: blink 1.06s steps(1) infinite;
 66 | }
 67 | @-moz-keyframes blink {
 68 |   0% { background: #7e7; }
 69 |   50% { background: none; }
 70 |   100% { background: #7e7; }
 71 | }
 72 | @-webkit-keyframes blink {
 73 |   0% { background: #7e7; }
 74 |   50% { background: none; }
 75 |   100% { background: #7e7; }
 76 | }
 77 | @keyframes blink {
 78 |   0% { background: #7e7; }
 79 |   50% { background: none; }
 80 |   100% { background: #7e7; }
 81 | }
 82 | 
 83 | /* Can style cursor different in overwrite (non-insert) mode */
 84 | div.CodeMirror-overwrite div.CodeMirror-cursor {}
 85 | 
 86 | .cm-tab { display: inline-block; }
 87 | 
 88 | .CodeMirror-ruler {
 89 |   border-left: 1px solid #ccc;
 90 |   position: absolute;
 91 | }
 92 | 
 93 | /* DEFAULT THEME */
 94 | 
 95 | .cm-s-default .cm-keyword {color: #708;}
 96 | .cm-s-default .cm-atom {color: #219;}
 97 | .cm-s-default .cm-number {color: #164;}
 98 | .cm-s-default .cm-def {color: #00f;}
 99 | .cm-s-default .cm-variable,
100 | .cm-s-default .cm-punctuation,
101 | .cm-s-default .cm-property,
102 | .cm-s-default .cm-operator {}
103 | .cm-s-default .cm-variable-2 {color: #05a;}
104 | .cm-s-default .cm-variable-3 {color: #085;}
105 | .cm-s-default .cm-comment {color: #a50;}
106 | .cm-s-default .cm-string {color: #a11;}
107 | .cm-s-default .cm-string-2 {color: #f50;}
108 | .cm-s-default .cm-meta {color: #555;}
109 | .cm-s-default .cm-qualifier {color: #555;}
110 | .cm-s-default .cm-builtin {color: #30a;}
111 | .cm-s-default .cm-bracket {color: #997;}
112 | .cm-s-default .cm-tag {color: #170;}
113 | .cm-s-default .cm-attribute {color: #00c;}
114 | .cm-s-default .cm-header {color: blue;}
115 | .cm-s-default .cm-quote {color: #090;}
116 | .cm-s-default .cm-hr {color: #999;}
117 | .cm-s-default .cm-link {color: #00c;}
118 | 
119 | .cm-negative {color: #d44;}
120 | .cm-positive {color: #292;}
121 | .cm-header, .cm-strong {font-weight: bold;}
122 | .cm-em {font-style: italic;}
123 | .cm-link {text-decoration: underline;}
124 | 
125 | .cm-s-default .cm-error {color: #f00;}
126 | .cm-invalidchar {color: #f00;}
127 | 
128 | /* Default styles for common addons */
129 | 
130 | div.CodeMirror span.CodeMirror-matchingbracket {color: #0f0;}
131 | div.CodeMirror span.CodeMirror-nonmatchingbracket {color: #f22;}
132 | .CodeMirror-matchingtag { background: rgba(255, 150, 0, .3); }
133 | .CodeMirror-activeline-background {background: #e8f2ff;}
134 | 
135 | /* STOP */
136 | 
137 | /* The rest of this file contains styles related to the mechanics of
138 |    the editor. You probably shouldn't touch them. */
139 | 
140 | .CodeMirror {
141 |   line-height: 1;
142 |   position: relative;
143 |   overflow: hidden;
144 |   background: white;
145 |   color: black;
146 | }
147 | 
148 | .CodeMirror-scroll {
149 |   /* 30px is the magic margin used to hide the element's real scrollbars */
150 |   /* See overflow: hidden in .CodeMirror */
151 |   margin-bottom: -30px; margin-right: -30px;
152 |   padding-bottom: 30px;
153 |   height: 100%;
154 |   outline: none; /* Prevent dragging from highlighting the element */
155 |   position: relative;
156 |   -moz-box-sizing: content-box;
157 |   box-sizing: content-box;
158 | }
159 | .CodeMirror-sizer {
160 |   position: relative;
161 |   border-right: 30px solid transparent;
162 |   -moz-box-sizing: content-box;
163 |   box-sizing: content-box;
164 | }
165 | 
166 | /* The fake, visible scrollbars. Used to force redraw during scrolling
167 |    before actuall scrolling happens, thus preventing shaking and
168 |    flickering artifacts. */
169 | .CodeMirror-vscrollbar, .CodeMirror-hscrollbar, .CodeMirror-scrollbar-filler, .CodeMirror-gutter-filler {
170 |   position: absolute;
171 |   z-index: 6;
172 |   display: none;
173 | }
174 | .CodeMirror-vscrollbar {
175 |   right: 0; top: 0;
176 |   overflow-x: hidden;
177 |   overflow-y: scroll;
178 | }
179 | .CodeMirror-hscrollbar {
180 |   bottom: 0; left: 0;
181 |   overflow-y: hidden;
182 |   overflow-x: scroll;
183 | }
184 | .CodeMirror-scrollbar-filler {
185 |   right: 0; bottom: 0;
186 | }
187 | .CodeMirror-gutter-filler {
188 |   left: 0; bottom: 0;
189 | }
190 | 
191 | .CodeMirror-gutters {
192 |   position: absolute; left: 0; top: 0;
193 |   padding-bottom: 30px;
194 |   z-index: 3;
195 | }
196 | .CodeMirror-gutter {
197 |   white-space: normal;
198 |   height: 100%;
199 |   -moz-box-sizing: content-box;
200 |   box-sizing: content-box;
201 |   padding-bottom: 30px;
202 |   margin-bottom: -32px;
203 |   display: inline-block;
204 |   /* Hack to make IE7 behave */
205 |   *zoom:1;
206 |   *display:inline;
207 | }
208 | .CodeMirror-gutter-elt {
209 |   position: absolute;
210 |   cursor: default;
211 |   z-index: 4;
212 | }
213 | 
214 | .CodeMirror-lines {
215 |   cursor: text;
216 | }
217 | .CodeMirror pre {
218 |   /* Reset some styles that the rest of the page might have set */
219 |   -moz-border-radius: 0; -webkit-border-radius: 0; border-radius: 0;
220 |   border-width: 0;
221 |   background: transparent;
222 |   font-family: inherit;
223 |   font-size: inherit;
224 |   margin: 0;
225 |   white-space: pre;
226 |   word-wrap: normal;
227 |   line-height: inherit;
228 |   color: inherit;
229 |   z-index: 2;
230 |   position: relative;
231 |   overflow: visible;
232 | }
233 | .CodeMirror-wrap pre {
234 |   word-wrap: break-word;
235 |   white-space: pre-wrap;
236 |   word-break: normal;
237 | }
238 | 
239 | .CodeMirror-linebackground {
240 |   position: absolute;
241 |   left: 0; right: 0; top: 0; bottom: 0;
242 |   z-index: 0;
243 | }
244 | 
245 | .CodeMirror-linewidget {
246 |   position: relative;
247 |   z-index: 2;
248 |   overflow: auto;
249 | }
250 | 
251 | .CodeMirror-widget {}
252 | 
253 | .CodeMirror-wrap .CodeMirror-scroll {
254 |   overflow-x: hidden;
255 | }
256 | 
257 | .CodeMirror-measure {
258 |   position: absolute;
259 |   width: 100%;
260 |   height: 0;
261 |   overflow: hidden;
262 |   visibility: hidden;
263 | }
264 | .CodeMirror-measure pre { position: static; }
265 | 
266 | .CodeMirror div.CodeMirror-cursor {
267 |   position: absolute;
268 |   border-right: none;
269 |   width: 0;
270 | }
271 | 
272 | div.CodeMirror-cursors {
273 |   visibility: hidden;
274 |   position: relative;
275 |   z-index: 1;
276 | }
277 | .CodeMirror-focused div.CodeMirror-cursors {
278 |   visibility: visible;
279 | }
280 | 
281 | .CodeMirror-selected { background: #d9d9d9; }
282 | .CodeMirror-focused .CodeMirror-selected { background: #d7d4f0; }
283 | .CodeMirror-crosshair { cursor: crosshair; }
284 | 
285 | .cm-searching {
286 |   background: #ffa;
287 |   background: rgba(255, 255, 0, .4);
288 | }
289 | 
290 | /* IE7 hack to prevent it from returning funny offsetTops on the spans */
291 | .CodeMirror span { *vertical-align: text-bottom; }
292 | 
293 | /* Used to force a border model for a node */
294 | .cm-force-border { padding-right: .1px; }
295 | 
296 | @media print {
297 |   /* Hide the cursor when printing */
298 |   .CodeMirror div.CodeMirror-cursors {
299 |     visibility: hidden;
300 |   }
301 | }
302 | 


--------------------------------------------------------------------------------
/mloc-js/src/Demo/Life.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE DeriveFoldable, TemplateHaskell, QuasiQuotes, ScopedTypeVariables, NoMonomorphismRestriction, Rank2Types #-}
  2 | -----------------------------------------------------------------------------
  3 | --
  4 | -- Module      :  Demo.Life
  5 | -- Copyright   :
  6 | -- License     :  BSD3
  7 | --
  8 | -- |
  9 | --
 10 | -----------------------------------------------------------------------------
 11 | 
 12 | module Demo.Life (
 13 |     life
 14 | ) where
 15 | 
 16 | import GHCJS.DOM.Types
 17 |        (HTMLDivElement(..), Document(..), WebView(..))
 18 | import GHCJS.DOM.HTMLElement
 19 |        (htmlElementSetInnerHTML)
 20 | import Data.Text.Lazy (unpack)
 21 | import Text.Blaze.Html.Renderer.Text (renderHtml)
 22 | import Text.Hamlet (shamlet)
 23 | import GHCJS.DOM (webViewGetDomDocument)
 24 | import Control.Monad.Reader (ReaderT(..))
 25 | import Language.Javascript.JSC
 26 |        (MakeValueRef(..), MakeStringRef(..), JSF(..), runJSC,
 27 |         jsg, js, js1, js4, (<#))
 28 | import Control.Lens (IndexPreservingGetter, Getter, to, (^.))
 29 | import qualified Data.Foldable as F (Foldable(..), Foldable)
 30 | import Graphics.Gloss
 31 |        (Picture(..), Display(..), Color(..), black, red,
 32 |         color, translate, rectangleSolid)
 33 | import Graphics.Gloss.Interface.Pure.Simulate (ViewPort)
 34 | import Data.Array (Array(..), (!), indices, bounds, listArray)
 35 | import Data.List (transpose, isPrefixOf)
 36 | import Data.Monoid (Monoid(..))
 37 | import Control.Applicative (Applicative(..), (<$>))
 38 | import Control.Concurrent (forkIO, threadDelay)
 39 | import Control.Monad.Trans ( liftIO )
 40 | import GHC.Float (float2Double)
 41 | 
 42 | life :: WebView -> Document -> HTMLDivElement -> IO ()
 43 | life webView doc example = do
 44 |     let canvasStyle = "position:absolute; top:60; left:300; visible: hidden"
 45 |     htmlElementSetInnerHTML example . unpack $ renderHtml
 46 |         [shamlet|$newline always
 47 |             <div #"lifeDiv">
 48 |                 <canvas #"canvas0" width="400" height="400" style="#{canvasStyle}">
 49 |                 <canvas #"canvas1" width="400" height="400" style="#{canvasStyle}">
 50 |         |]
 51 | 
 52 |     let getElementById :: (MakeValueRef s, MakeStringRef s) => s -> JSF
 53 |         getElementById = js1 "getElementById"
 54 |         getContext     = js1 "getContext"
 55 |         fillStyle      = js "fillStyle"
 56 |         fillRect :: Double -> Double -> Double -> Double -> JSF
 57 |         fillRect       = js4 "fillRect"
 58 |         style          = js "style"
 59 |         visibility     = js "visibility"
 60 | 
 61 |     runJSC webView $ do
 62 |         document <- jsg "document"
 63 | 
 64 |         canvas0 <- document ^. getElementById "canvas0"
 65 |         canvas1 <- document ^. getElementById "canvas1"
 66 | 
 67 |         let simulate n (canvas0, canvas1) speed model = do
 68 |                 runJSC webView $ do
 69 |                     ctx <- canvas0 ^. getContext "2d"
 70 |                     ctx ^. fillStyle <# "#FFFFFF" -- if n `mod` 2 == 0 then "#FFFFFF" else "#AA0000"
 71 |                     ctx ^. fillRect 0 0 600 400
 72 |                     drawPicture ctx (300,200) (render model)
 73 |                     canvas1 ^. style . visibility <# "hidden"
 74 |                     canvas0 ^. style . visibility <# "visible"
 75 |                 threadDelay (1000000 `div` speed)
 76 |                 simulate (n+1) (canvas1, canvas0) speed (step () 1.0 model)
 77 |             drawPicture ctx orig Blank = return ()
 78 |             drawPicture ctx orig (Pictures pics) = mapM_ (drawPicture ctx orig) pics
 79 |             drawPicture ctx (ox,oy) (Translate x y pic) = drawPicture ctx (ox+x, oy+y) pic
 80 |             drawPicture ctx (ox,oy) (Polygon [(a,b), _, (c,d), _]) = do
 81 |                 ctx ^. fillRect (realToFrac $ ox+a) (realToFrac $ oy+b)
 82 |                                 (realToFrac $ c-a)  (realToFrac $ d-b)
 83 |                 return ()
 84 |             drawPicture ctx orig (Color c pic) = do
 85 |                 ctx ^. fillStyle <# "#0000C0"
 86 |                 drawPicture ctx orig pic
 87 |             drawPicture ctx orig p = liftIO $ print p
 88 |         liftIO . forkIO $ simulate 0 (canvas0, canvas1) 10 (parseGrid $ unlines
 89 |                 [
 90 |                 "..........................................",
 91 |                 "..........................................",
 92 |                 "..........................................",
 93 |                 "..........................................",
 94 |                 "..........................................",
 95 |                 "..........................................",
 96 |                 "..........................................",
 97 |                 "..........................................",
 98 |                 "..........................................",
 99 |                 "...........................O..............",
100 |                 ".........................O.O..............",
101 |                 "...............OO......OO............OO...",
102 |                 "..............O...O....OO............OO...",
103 |                 "...OO........O.....O...OO.................",
104 |                 "...OO........O...O.OO....O.O..............",
105 |                 ".............O.....O.......O..............",
106 |                 "..............O...O.......................",
107 |                 "...............OO.........................",
108 |                 "..........................................",
109 |                 "..........................................",
110 |                 "..........................................",
111 |                 "..........................................",
112 |                 "..........................................",
113 |                 "..........................................",
114 |                 "..........................................",
115 |                 ".........................................."]
116 |             )
117 |         return ()
118 | 
119 | 
120 | 
121 | -- What follows is code from a Hoodlums session
122 | -- https://github.com/petermarks/hoodlums-sessions/blob/master/Life.hs
123 | data Grid a = Grid (Array (Int,Int) a) (Int, Int)
124 |   deriving F.Foldable
125 | 
126 | class Comonad w where
127 |   extract :: w a -> a
128 |   (=>>) :: w a -> (w a -> b) -> w b
129 | 
130 | instance Comonad Grid where
131 |   extract (Grid a p) = a ! p
132 |   (Grid a p) =>> f   = Grid ( listArray (bounds a) . map (f . Grid a) $ indices a) p
133 | 
134 | --main :: IO ()
135 | --main = do
136 | --  gridString <- readFile "grid.life"
137 | --  let grid = parseGrid gridString
138 | --  runGame grid
139 | 
140 | parseGrid :: String -> Grid Bool
141 | parseGrid s = Grid ( listArray ((1,1), (width, height)) es) (1,1)
142 |   where
143 |     ls     = dropWhile ("!" `isPrefixOf`) $ lines s
144 |     width  = length $ head ls
145 |     height = length ls
146 |     es     =  map (== 'O') $ concat $ transpose ls
147 | 
148 | --runGame :: Grid Bool -> IO ()
149 | --runGame grid = simulate (InWindow "Life" (windowSize grid) (10,10))
150 | --                black 10 grid render step
151 | 
152 | size :: Grid a -> (Int, Int)
153 | size (Grid a _) = snd (bounds a)
154 | 
155 | render :: Grid Bool -> Picture
156 | render g = color red $ F.fold $ g =>> renderCell
157 | 
158 | gridIndex :: Grid a -> (Int, Int)
159 | gridIndex (Grid _ p) = p
160 | 
161 | gridIndices :: Grid a -> Grid (Int, Int)
162 | gridIndices g = g =>> gridIndex
163 | 
164 | renderCell :: Grid Bool -> Picture
165 | renderCell g | alive = translate (fromIntegral $ x * 10 - w * 5 - 15)
166 |                                  (fromIntegral $ y * (-10) + h * 5 + 15) $
167 |                                  rectangleSolid 8 8
168 |              | otherwise = mempty
169 |   where
170 |     alive = extract g
171 |     (x, y) = gridIndex g
172 |     (w, h) = size g
173 | 
174 | windowSize :: Grid a -> (Int, Int)
175 | -- windowSize g = (x * 10, y * 10)
176 | --   where (x, y) = size g
177 | windowSize _ = (500, 500)
178 | 
179 | rule :: Bool -> Int-> Bool
180 | rule True  i = i == 2 || i == 3
181 | rule False i = i == 3
182 | 
183 | moveGrid :: (Int, Int) -> Grid a -> Grid a
184 | moveGrid (xx,yy) (Grid a (x,y)) = Grid a (x',y')
185 |   where
186 |     (w,h) = snd $ bounds a
187 |     x' = (x + xx - 1) `mod` w + 1
188 |     y' = (y + yy - 1) `mod` h + 1
189 | 
190 | neighbours :: Grid Bool -> Int
191 | neighbours g = length . filter id $ bools
192 |   where
193 |     bools = map (\o -> extract $ moveGrid o g) offsets
194 |     offsets = [(x,y) | x <- [(-1)..1], y <- [(-1)..1], (x,y) /= (0,0)]
195 | 
196 | step :: x -> Float -> Grid Bool -> Grid Bool
197 | step _ _ g = g =>> (rule <$> extract <*> neighbours)
198 | 
199 | 
200 | 


--------------------------------------------------------------------------------
/try-purescript/codemirror/mode/haskell/haskell.js:
--------------------------------------------------------------------------------
  1 | // CodeMirror, copyright (c) by Marijn Haverbeke and others
  2 | // Distributed under an MIT license: http://codemirror.net/LICENSE
  3 | 
  4 | (function(mod) {
  5 |   if (typeof exports == "object" && typeof module == "object") // CommonJS
  6 |     mod(require("../../lib/codemirror"));
  7 |   else if (typeof define == "function" && define.amd) // AMD
  8 |     define(["../../lib/codemirror"], mod);
  9 |   else // Plain browser env
 10 |     mod(CodeMirror);
 11 | })(function(CodeMirror) {
 12 | "use strict";
 13 | 
 14 | CodeMirror.defineMode("haskell", function(_config, modeConfig) {
 15 | 
 16 |   function switchState(source, setState, f) {
 17 |     setState(f);
 18 |     return f(source, setState);
 19 |   }
 20 | 
 21 |   // These should all be Unicode extended, as per the Haskell 2010 report
 22 |   var smallRE = /[a-z_]/;
 23 |   var largeRE = /[A-Z]/;
 24 |   var digitRE = /\d/;
 25 |   var hexitRE = /[0-9A-Fa-f]/;
 26 |   var octitRE = /[0-7]/;
 27 |   var idRE = /[a-z_A-Z0-9']/;
 28 |   var symbolRE = /[-!#$%&*+.\/<=>?@\\^|~:]/;
 29 |   var specialRE = /[(),;[\]`{}]/;
 30 |   var whiteCharRE = /[ \t\v\f]/; // newlines are handled in tokenizer
 31 | 
 32 |   function normal(source, setState) {
 33 |     if (source.eatWhile(whiteCharRE)) {
 34 |       return null;
 35 |     }
 36 | 
 37 |     var ch = source.next();
 38 |     if (specialRE.test(ch)) {
 39 |       if (ch == '{' && source.eat('-')) {
 40 |         var t = "comment";
 41 |         if (source.eat('#')) {
 42 |           t = "meta";
 43 |         }
 44 |         return switchState(source, setState, ncomment(t, 1));
 45 |       }
 46 |       return null;
 47 |     }
 48 | 
 49 |     if (ch == '\'') {
 50 |       if (source.eat('\\')) {
 51 |         source.next();  // should handle other escapes here
 52 |       }
 53 |       else {
 54 |         source.next();
 55 |       }
 56 |       if (source.eat('\'')) {
 57 |         return "string";
 58 |       }
 59 |       return "error";
 60 |     }
 61 | 
 62 |     if (ch == '"') {
 63 |       return switchState(source, setState, stringLiteral);
 64 |     }
 65 | 
 66 |     if (largeRE.test(ch)) {
 67 |       source.eatWhile(idRE);
 68 |       if (source.eat('.')) {
 69 |         return "qualifier";
 70 |       }
 71 |       return "variable-2";
 72 |     }
 73 | 
 74 |     if (smallRE.test(ch)) {
 75 |       source.eatWhile(idRE);
 76 |       return "variable";
 77 |     }
 78 | 
 79 |     if (digitRE.test(ch)) {
 80 |       if (ch == '0') {
 81 |         if (source.eat(/[xX]/)) {
 82 |           source.eatWhile(hexitRE); // should require at least 1
 83 |           return "integer";
 84 |         }
 85 |         if (source.eat(/[oO]/)) {
 86 |           source.eatWhile(octitRE); // should require at least 1
 87 |           return "number";
 88 |         }
 89 |       }
 90 |       source.eatWhile(digitRE);
 91 |       var t = "number";
 92 |       if (source.match(/^\.\d+/)) {
 93 |         t = "number";
 94 |       }
 95 |       if (source.eat(/[eE]/)) {
 96 |         t = "number";
 97 |         source.eat(/[-+]/);
 98 |         source.eatWhile(digitRE); // should require at least 1
 99 |       }
100 |       return t;
101 |     }
102 | 
103 |     if (ch == "." && source.eat("."))
104 |       return "keyword";
105 | 
106 |     if (symbolRE.test(ch)) {
107 |       if (ch == '-' && source.eat(/-/)) {
108 |         source.eatWhile(/-/);
109 |         if (!source.eat(symbolRE)) {
110 |           source.skipToEnd();
111 |           return "comment";
112 |         }
113 |       }
114 |       var t = "variable";
115 |       if (ch == ':') {
116 |         t = "variable-2";
117 |       }
118 |       source.eatWhile(symbolRE);
119 |       return t;
120 |     }
121 | 
122 |     return "error";
123 |   }
124 | 
125 |   function ncomment(type, nest) {
126 |     if (nest == 0) {
127 |       return normal;
128 |     }
129 |     return function(source, setState) {
130 |       var currNest = nest;
131 |       while (!source.eol()) {
132 |         var ch = source.next();
133 |         if (ch == '{' && source.eat('-')) {
134 |           ++currNest;
135 |         }
136 |         else if (ch == '-' && source.eat('}')) {
137 |           --currNest;
138 |           if (currNest == 0) {
139 |             setState(normal);
140 |             return type;
141 |           }
142 |         }
143 |       }
144 |       setState(ncomment(type, currNest));
145 |       return type;
146 |     };
147 |   }
148 | 
149 |   function stringLiteral(source, setState) {
150 |     while (!source.eol()) {
151 |       var ch = source.next();
152 |       if (ch == '"') {
153 |         setState(normal);
154 |         return "string";
155 |       }
156 |       if (ch == '\\') {
157 |         if (source.eol() || source.eat(whiteCharRE)) {
158 |           setState(stringGap);
159 |           return "string";
160 |         }
161 |         if (source.eat('&')) {
162 |         }
163 |         else {
164 |           source.next(); // should handle other escapes here
165 |         }
166 |       }
167 |     }
168 |     setState(normal);
169 |     return "error";
170 |   }
171 | 
172 |   function stringGap(source, setState) {
173 |     if (source.eat('\\')) {
174 |       return switchState(source, setState, stringLiteral);
175 |     }
176 |     source.next();
177 |     setState(normal);
178 |     return "error";
179 |   }
180 | 
181 | 
182 |   var wellKnownWords = (function() {
183 |     var wkw = {};
184 |     function setType(t) {
185 |       return function () {
186 |         for (var i = 0; i < arguments.length; i++)
187 |           wkw[arguments[i]] = t;
188 |       };
189 |     }
190 | 
191 |     setType("keyword")(
192 |       "case", "class", "data", "default", "deriving", "do", "else", "foreign",
193 |       "if", "import", "in", "infix", "infixl", "infixr", "instance", "let",
194 |       "module", "newtype", "of", "then", "type", "where", "_");
195 | 
196 |     setType("keyword")(
197 |       "\.\.", ":", "::", "=", "\\", "\"", "<-", "->", "@", "~", "=>");
198 | 
199 |     setType("builtin")(
200 |       "!!", "$!", "$", "&&", "+", "++", "-", ".", "/", "/=", "<", "<=", "=<<",
201 |       "==", ">", ">=", ">>", ">>=", "^", "^^", "||", "*", "**");
202 | 
203 |     setType("builtin")(
204 |       "Bool", "Bounded", "Char", "Double", "EQ", "Either", "Enum", "Eq",
205 |       "False", "FilePath", "Float", "Floating", "Fractional", "Functor", "GT",
206 |       "IO", "IOError", "Int", "Integer", "Integral", "Just", "LT", "Left",
207 |       "Maybe", "Monad", "Nothing", "Num", "Ord", "Ordering", "Rational", "Read",
208 |       "ReadS", "Real", "RealFloat", "RealFrac", "Right", "Show", "ShowS",
209 |       "String", "True");
210 | 
211 |     setType("builtin")(
212 |       "abs", "acos", "acosh", "all", "and", "any", "appendFile", "asTypeOf",
213 |       "asin", "asinh", "atan", "atan2", "atanh", "break", "catch", "ceiling",
214 |       "compare", "concat", "concatMap", "const", "cos", "cosh", "curry",
215 |       "cycle", "decodeFloat", "div", "divMod", "drop", "dropWhile", "either",
216 |       "elem", "encodeFloat", "enumFrom", "enumFromThen", "enumFromThenTo",
217 |       "enumFromTo", "error", "even", "exp", "exponent", "fail", "filter",
218 |       "flip", "floatDigits", "floatRadix", "floatRange", "floor", "fmap",
219 |       "foldl", "foldl1", "foldr", "foldr1", "fromEnum", "fromInteger",
220 |       "fromIntegral", "fromRational", "fst", "gcd", "getChar", "getContents",
221 |       "getLine", "head", "id", "init", "interact", "ioError", "isDenormalized",
222 |       "isIEEE", "isInfinite", "isNaN", "isNegativeZero", "iterate", "last",
223 |       "lcm", "length", "lex", "lines", "log", "logBase", "lookup", "map",
224 |       "mapM", "mapM_", "max", "maxBound", "maximum", "maybe", "min", "minBound",
225 |       "minimum", "mod", "negate", "not", "notElem", "null", "odd", "or",
226 |       "otherwise", "pi", "pred", "print", "product", "properFraction",
227 |       "putChar", "putStr", "putStrLn", "quot", "quotRem", "read", "readFile",
228 |       "readIO", "readList", "readLn", "readParen", "reads", "readsPrec",
229 |       "realToFrac", "recip", "rem", "repeat", "replicate", "return", "reverse",
230 |       "round", "scaleFloat", "scanl", "scanl1", "scanr", "scanr1", "seq",
231 |       "sequence", "sequence_", "show", "showChar", "showList", "showParen",
232 |       "showString", "shows", "showsPrec", "significand", "signum", "sin",
233 |       "sinh", "snd", "span", "splitAt", "sqrt", "subtract", "succ", "sum",
234 |       "tail", "take", "takeWhile", "tan", "tanh", "toEnum", "toInteger",
235 |       "toRational", "truncate", "uncurry", "undefined", "unlines", "until",
236 |       "unwords", "unzip", "unzip3", "userError", "words", "writeFile", "zip",
237 |       "zip3", "zipWith", "zipWith3");
238 | 
239 |     var override = modeConfig.overrideKeywords;
240 |     if (override) for (var word in override) if (override.hasOwnProperty(word))
241 |       wkw[word] = override[word];
242 | 
243 |     return wkw;
244 |   })();
245 | 
246 | 
247 | 
248 |   return {
249 |     startState: function ()  { return { f: normal }; },
250 |     copyState:  function (s) { return { f: s.f }; },
251 | 
252 |     token: function(stream, state) {
253 |       var t = state.f(stream, function(s) { state.f = s; });
254 |       var w = stream.current();
255 |       return wellKnownWords.hasOwnProperty(w) ? wellKnownWords[w] : t;
256 |     },
257 | 
258 |     blockCommentStart: "{-",
259 |     blockCommentEnd: "-}",
260 |     lineComment: "--"
261 |   };
262 | 
263 | });
264 | 
265 | CodeMirror.defineMIME("text/x-haskell", "haskell");
266 | 
267 | });
268 | 


--------------------------------------------------------------------------------
/webkit-sodium/src/Engine.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE CPP #-}
  2 | module Engine where
  3 | 
  4 | import Prelude hiding ((!!))
  5 | import GHCJS.DOM.Document
  6 |        (documentCreateElement, documentGetElementById, documentGetBody,
  7 |         documentGetDocumentElement)
  8 | import GHCJS.DOM.HTMLElement
  9 |        (htmlElementInsertAdjacentElement, htmlElementSetInnerHTML,
 10 |         htmlElementInsertAdjacentHTML)
 11 | import GHCJS.DOM (WebView, webViewGetDomDocument)
 12 | import GHCJS.DOM.Types
 13 |        (castToHTMLElement, castToElement, Document,
 14 |         HTMLElement, IsElement, IsMouseEvent, gTypeElement)
 15 | import Control.Applicative ((<$>))
 16 | import Control.Arrow
 17 | import Control.Monad.Trans ( liftIO )
 18 | import GHCJS.DOM.Element
 19 | import GHCJS.DOM.EventM
 20 | import GHCJS.DOM.MouseEvent hiding (MouseEvent)
 21 | import GHCJS.DOM.Node
 22 | import Control.Monad
 23 | import Control.Monad.State.Strict
 24 | import Data.IORef
 25 | import Data.Maybe
 26 | 
 27 | import FRP.Sodium
 28 | import Game
 29 | import Control.Monad.Reader (ReaderT(..))
 30 | #ifdef MIN_VERSION_jsaddle
 31 | import Language.Javascript.JSaddle
 32 |         (js2, js1, js0, js, jsg, (!!), (#), (<#), fun,
 33 |          deRefVal, JSValue(..), runJSaddle)
 34 | import Control.Lens ((^.))
 35 | #endif
 36 | 
 37 | -- Convert (game) world to/from screen co-ordinates.
 38 | -- World co-ordinates are x = -1400..1400, y = -1000 to 1000
 39 | -- Screen co-ordinates are x = 0..700, y = 0..500
 40 | -- Y is inverted
 41 | scale = 1/4
 42 | worldLeft = -1400
 43 | worldTop  = 1000
 44 | toWorld :: (Int, Int) -> (Double, Double)
 45 | toWorld (x,y) = (fromIntegral x / scale + worldLeft, worldTop - fromIntegral y / scale)
 46 | fromWorldRect :: Rect -> ((Int,Int),(Int,Int))
 47 | fromWorldRect ((xOrig,yOrig),(wid,hei)) = (
 48 |         (
 49 |             round $ (left - worldLeft) * scale,
 50 |             round $ (worldTop - top) * scale
 51 |         ),
 52 |         (
 53 |             round $ wid * scale * 2,
 54 |             round $ hei * scale * 2
 55 |         )
 56 |     )
 57 |   where
 58 |     left = xOrig - wid
 59 |     top  = yOrig + hei
 60 | 
 61 | -- | Get the mouse position relative to the top-left corner of the specified
 62 | -- HTML element.
 63 | getXYRelativeTo :: (IsElement elt, IsMouseEvent e, IsElement t) =>
 64 |                    Document -> elt -> EventM e t (Int, Int)
 65 | getXYRelativeTo doc container = do
 66 |     (px, py) <- mousePageXY doc container
 67 |     (cx, cy) <- liftIO $ elementPageXY doc container
 68 |     return (px - cx, py - cy)
 69 | 
 70 | mousePageXY :: (IsElement elt, IsMouseEvent e, IsElement t) =>
 71 |                Document -> elt -> EventM e t (Int, Int)
 72 | mousePageXY doc container = do
 73 |     (x, y) <- mouseClientXY
 74 |     liftIO $ do
 75 | 	Just body <- documentGetBody doc     -- doc.body
 76 |         bodyScrollLeft <- elementGetScrollLeft body
 77 |         bodyScrollTop  <- elementGetScrollTop body
 78 |         Just docElt <- documentGetDocumentElement doc
 79 |         docEltScrollLeft <- elementGetScrollLeft docElt
 80 |         docEltScrollTop <- elementGetScrollTop docElt
 81 |         return (x + bodyScrollLeft + docEltScrollLeft, y + bodyScrollTop + docEltScrollTop)
 82 | 
 83 | -- | Get the top/left position of this element relative to the page.
 84 | elementPageXY :: IsElement elt => Document -> elt -> IO (Int, Int)
 85 | elementPageXY doc elt = do
 86 |     Just body <- documentGetBody doc
 87 |     traverse body (castToElement elt) (0,0)
 88 |   where
 89 |     traverse body elt (x, y) = do
 90 |         eq <- nodeIsEqualNode elt (Just body)
 91 |         if eq
 92 |             then return (x, y)
 93 |             else do
 94 |                 ox <- elementGetOffsetLeft elt
 95 |                 oy <- elementGetOffsetTop elt
 96 |                 Just parent <- elementGetOffsetParent elt
 97 |                 traverse body parent (x + round ox, y + round oy)
 98 | 
 99 | -- The game logic expects alternating down-up-down-up, but the browser can produce
100 | -- bad sequences like down-up-down-down-up. So we sanitize the input.
101 | mkSanitize :: Eq state =>
102 |               state          -- ^ Initial state
103 |            -> IO (state -> IO () -> IO ())
104 | mkSanitize initialState = do
105 |     stateRef <- newIORef initialState
106 |     return $ \newState action -> do
107 |         oldState <- readIORef stateRef
108 |         when (oldState /= newState) $ do
109 |             writeIORef stateRef newState
110 |             action
111 | 
112 | data ButtonState = Up | Down deriving Eq
113 | 
114 | -- | Instantiate the game, handling mouse events and drawing the output.
115 | -- Returns an \'unlisten\' action to de-register listeners.
116 | engine :: WebView -> String -> (Event MouseEvent -> Reactive (BehaviorTree [Sprite])) -> IO (IO ())
117 | engine webView containerId game = do
118 |     putStrLn "Haskell Freecell"
119 | 
120 |     Just doc <- webViewGetDomDocument webView
121 |     Just container <- fmap castToHTMLElement <$> documentGetElementById doc containerId
122 |     -- Construct a mouse event that lives in FRP land, and a push action
123 |     -- that allows us to push values into it from IO land.
124 |     (eMouse, pushMouse) <- sync newEvent
125 | 
126 |     sanitize <- mkSanitize Up
127 | 
128 |     -- Listen to mouse events from WebKit
129 |     elementOnmousedown container $ do
130 |         xy <- getXYRelativeTo doc container
131 |         liftIO . sanitize Down . sync . pushMouse . MouseDown . toWorld $ xy
132 |     elementOnmousemove container $ do
133 |         xy <- getXYRelativeTo doc container
134 |         liftIO . sync . pushMouse . MouseMove . toWorld $ xy
135 |     elementOnmouseup container $ do
136 |         xy <- getXYRelativeTo doc container
137 |         liftIO . sanitize Up . sync . pushMouse . MouseUp . toWorld $ xy
138 | 
139 |     (cx, cy) <- elementPageXY doc container
140 | #ifdef MIN_VERSION_jsaddle
141 |     runJSaddle webView $ do
142 |         document <- jsg "document"
143 |         let getElementById = js1 "getElementById"
144 |             preventDefault = js0 "preventDefault"
145 |             touches        = js "touches"
146 |             changedTouches = js "changedTouches"
147 |             jsLength       = js "length"
148 |             pageX          = js "pageX"
149 |             pageY          = js "pageY"
150 |             addEventListener = js2 "addEventListener"
151 | 
152 |         c <- document ^. getElementById containerId
153 |         c ^. addEventListener "touchstart" (fun $ \f this [e] -> do
154 |           e ^. preventDefault
155 |           n <- e ^. touches . jsLength >>= deRefVal
156 |           when (n == ValNumber 1) $ do
157 |               t <- (e ^. touches) !! 0
158 |               vx <- t ^. pageX >>= deRefVal
159 |               vy <- t ^. pageY >>= deRefVal
160 |               case (vx, vy) of
161 |                 (ValNumber x, ValNumber y) ->
162 |                   liftIO . sanitize Down . sync . pushMouse . MouseDown . toWorld $ ((floor x)-cx, (floor y)-cy)
163 |                 _ -> return ())
164 |         c ^. addEventListener "touchmove" (fun $ \f this [e] -> do
165 |           e ^. preventDefault
166 |           n <- e ^. touches . jsLength >>= deRefVal
167 |           when (n == ValNumber 1) $ do
168 |               t <- (e ^. touches) !! 0
169 |               vx <- t ^. pageX >>= deRefVal
170 |               vy <- t ^. pageY >>= deRefVal
171 |               case (vx, vy) of
172 |                 (ValNumber x, ValNumber y) ->
173 |                   liftIO . sync . pushMouse . MouseMove . toWorld $ ((floor x)-cx, (floor y)-cy)
174 |                 _ -> return ())
175 |         c ^. addEventListener "touchend" (fun $ \f this [e] -> do
176 |           e ^. preventDefault
177 |           n <- e ^. changedTouches . jsLength >>= deRefVal
178 |           when (n == ValNumber 1) $ do
179 |               t <- (e ^. changedTouches) !! 0
180 |               vx <- t ^. pageX >>= deRefVal
181 |               vy <- t ^. pageY >>= deRefVal
182 |               case (vx, vy) of
183 |                 (ValNumber x, ValNumber y) ->
184 |                   liftIO . sanitize Up . sync . pushMouse . MouseUp . toWorld $ ((floor x)-cx, (floor y)-cy)
185 |                 _ -> return ())
186 | #endif
187 | 
188 |     -- Instantiate the FRP logic: We give it our mouse event, and it gives us back the
189 |     -- sprite behaviours that tell us what to draw on the screen.
190 |     sprites <- sync (game eMouse)
191 | 
192 |     -- Add listeners to the sprite behaviours so the FRP output gets drawn on the
193 |     -- web page.
194 |     showAll doc container sprites
195 | 
196 | showAll :: IsElement elt =>
197 |              Document -> elt -> BehaviorTree [Sprite] -> IO (IO ())
198 | showAll doc container sprites =
199 |     -- Pass the zIndex through as state. The order of the FRP's output determines
200 |     -- what overlaps what. Later elements overlap earlier ones. In CSS this is
201 |     -- drawn correctly by setting the zIndex.
202 |     evalStateT (showEach sprites) (-1000000)
203 |   where
204 |     showEach :: BehaviorTree [Sprite] -> StateT Int IO (IO ())
205 |     showEach (left :++ right) = do
206 |         -- Traverse the tree structure
207 |         unlisten1 <- showEach left
208 |         unlisten2 <- showEach right
209 |         -- Collect event unlisteners.
210 |         return (unlisten1 >> unlisten2)
211 |     showEach (BehaviorNode beh) = do
212 |         -- Each behaviour outputs a list of sprites. For each behaviour we
213 |         -- pre-allocate 1000 zIndex numbers to allow for expansion of the
214 |         -- sprite list per behaviour.
215 |         zIxRoot <- get
216 |         modify (1000+)
217 |         liftIO $ do
218 |             -- Remember the behaviour's last value
219 |             lastRef <- newIORef []
220 |             -- Listen to changes in the value of the behaviour (a list of sprites)
221 |             unlisten <- sync $ listen (values beh) $ \these -> do
222 |                 last <- readIORef lastRef
223 |                 let toAdd = drop (length last) these
224 |                     toRemove = drop (length these) (map fst last)
225 |                     toModify = zip these last
226 |                     keptImgs = map (\(_, (elt, _)) -> elt) toModify
227 |                     noOfKeptImgs = length keptImgs
228 |                 -- If there are fewer elements than last time, we delete the excess ones.
229 |                 mapM_ (nodeRemoveChild container . Just) toRemove
230 |                 -- If the first n sprites exist in both the old and new list, we
231 |                 -- re-use them, and just modify their position and appearance as necessary
232 |                 sequence_ $ zipWith (\zIx (newSprite, (elt, oldSprite)) -> do
233 |                         let (oldRect, oldFn) = oldSprite
234 |                             (newRect, newFn) = newSprite
235 |                         when (oldRect /= newRect) $ position  elt newRect zIx
236 |                         when (oldFn /= newFn)     $ associate elt newFn
237 |                     ) [zIxRoot..] toModify
238 |                 -- If there are more elements than last time, we create the new ones
239 |                 addedImgs <- sequence $ zipWith (\zIx sprite@(rect, fn) -> do
240 |                         Just elt <- fmap castToHTMLElement <$> documentCreateElement doc "img"
241 |                         position elt rect zIx
242 |                         associate elt fn
243 |                         elementSetAttribute elt "ondragstart" "return false"
244 |                         nodeAppendChild container (Just elt)
245 |                         return elt
246 |                     ) [zIxRoot + noOfKeptImgs..] toAdd
247 |                 writeIORef lastRef (zip (keptImgs ++ addedImgs) these)
248 |             return unlisten
249 |     -- Set the necessary attributes to position the image according to the specified
250 |     -- rectangle
251 |     position elt rect zIx = do
252 |         elementSetAttribute elt "style" (style origin zIx)
253 |         elementSetAttribute elt "width" (show wid)
254 |         elementSetAttribute elt "height" (show hei)
255 |       where
256 |         (origin, (wid, hei)) = fromWorldRect rect
257 |         style (x, y) zIx = "position:absolute;top:"++show y
258 |                                     ++"px;left:"++show x
259 |                                   ++"px;zIndex:"++show zIx
260 |                                   ++disableTextSelection
261 |         -- See http://stackoverflow.com/questions/826782/css-rule-to-disable-text-selection-highlighting
262 |         disableTextSelection =
263 |             "-webkit-touch-callout:none;"++
264 |             "-webkit-user-select: none;"++
265 |             "-khtml-user-select: none;"++
266 |             "-moz-user-select: none;"++
267 |             "-ms-user-select: none;"++
268 |             "user-select: none"
269 |     -- Associate the image element with a URL, i.e. set its appearance.
270 |     associate elt fn =
271 |         elementSetAttribute elt "src" ("http://ghcjs.github.com/"++fn)
272 | 
273 | 


--------------------------------------------------------------------------------
/ghcjs-hello/src/Main.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE CPP, TemplateHaskell, QuasiQuotes, ScopedTypeVariables, NoMonomorphismRestriction, Rank2Types, DeriveDataTypeable #-}
  2 | module Main (
  3 |     main, lazyLoad_freecell
  4 | ) where
  5 | 
  6 | import Prelude hiding ((!!))
  7 | import Control.Monad.Trans ( liftIO )
  8 | import System.IO (stderr, hPutStrLn, stdout, hFlush)
  9 | import GHCJS.DOM (runWebGUI, postGUISync, postGUIAsync, webViewGetDomDocument)
 10 | import GHCJS.DOM.Document
 11 |        (documentCreateElement, documentGetElementById, documentGetBody)
 12 | import GHCJS.DOM.HTMLElement
 13 |        (htmlElementSetInnerText, htmlElementSetInnerHTML)
 14 | import Data.Text.Lazy (Text, unpack)
 15 | import Text.Blaze.Html.Renderer.Text (renderHtml)
 16 | import Text.Hamlet (shamlet)
 17 | import Text.Blaze.Html (Html)
 18 | import GHCJS.DOM.Types
 19 |        (Node(..), castToHTMLElement, castToHTMLDivElement,
 20 |         castToHTMLInputElement)
 21 | import Control.Applicative ((<$>))
 22 | import GHCJS.DOM.Element
 23 |        (elementGetStyle, elementSetAttribute, elementOnclick,
 24 |         elementOnkeypress, elementOnkeyup, elementOnkeydown, elementFocus)
 25 | import GHCJS.DOM.HTMLInputElement
 26 |        (htmlInputElementGetValue)
 27 | import Control.Concurrent
 28 |        (tryTakeMVar, takeMVar, threadDelay, putMVar, forkIO, newEmptyMVar, forkIOWithUnmask)
 29 | import Control.Monad (when, forever)
 30 | import GHCJS.DOM.EventM
 31 |        (mouseShiftKey, mouseCtrlKey)
 32 | import GHCJS.DOM.Node
 33 |        (nodeInsertBefore, nodeAppendChild)
 34 | import GHCJS.DOM.CSSStyleDeclaration
 35 |        (cssStyleDeclarationSetProperty)
 36 | import Language.Javascript.JSaddle
 37 |        (strToText, valToStr, JSNull(..), deRefVal, valToObject, js, JSF(..), js1, js4, jsg,
 38 |         valToNumber, (!), (!!), (#), (<#), global, eval, fun, val, array, new, runJSaddle_,
 39 |         valToText, MakeValueRef(..), JSValue(..), call, JSM(..), JSValueRef)
 40 | import Control.Monad.Reader (ReaderT(..))
 41 | import qualified Data.Text as T (unpack, pack)
 42 | import FRP.Sodium
 43 | import Engine
 44 | import Freecell -- What could this be for ? :-)
 45 | #ifdef MIN_VERSION_jmacro
 46 | import Language.Javascript.JMacro
 47 |        (jmacroE, jLam, jmacro, renderJs, ToJExpr(..), JStat(..))
 48 | import Language.Haskell.TH
 49 |        (stringL, litE)
 50 | #endif
 51 | import System.IO.Unsafe (unsafePerformIO)
 52 | import Control.Lens ((^.))
 53 | import Control.Exception (throwTo, catch, SomeException, Exception)
 54 | import Data.Typeable (Typeable)
 55 | import Control.DeepSeq (deepseq)
 56 | 
 57 | data NewValueException = NewValueException deriving (Show, Typeable)
 58 | 
 59 | instance Exception NewValueException
 60 | 
 61 | main = do
 62 |   -- Running a GUI creates a WebKitGtk window in native code,
 63 |   -- but just returns the browser window when compiled to JavaScript
 64 |   runWebGUI $ \ webView -> do
 65 |     -- WebKitGtk provides the normal W3C DOM functions
 66 |     Just doc <- webViewGetDomDocument webView
 67 |     Just body <- documentGetBody doc
 68 | 
 69 |     -- Lets use some Hamlet to replace HTerm with some HTML
 70 |     Just div <- fmap castToHTMLDivElement <$> documentCreateElement doc "div"
 71 |     htmlElementSetInnerHTML div . unpack $ renderHtml [shamlet|$newline always
 72 |         <h1 #heading>
 73 |             Hello and Welcome GHCJS
 74 |         <p>
 75 |             Know any good prime numbers?
 76 |             <input #num size="8">
 77 |             <div #prime>
 78 |         <p>
 79 |             Here is a quick test of Canvas using jsc
 80 |             <canvas #"canvas" width="10" height="10">
 81 |         <ul>
 82 |           <li>
 83 |             Check out the <a href="https://github.com/ghcjs/ghcjs-examples/blob/master/ghcjs-hello/src/Main.hs">Haskell source code</a>
 84 |             \ for this example.  (read it carefully to find the hidden FRP example)
 85 |           <li>
 86 |             Try out the <a href="hterm.html">unminified version</a>
 87 |     |]
 88 |     -- Now we need to add this div to the document body
 89 |     -- If we are in the browser then let's shrink the terminal window to make room
 90 |     mbTerminal <- fmap castToHTMLDivElement <$> documentGetElementById doc "terminal"
 91 |     case mbTerminal of
 92 |       Just terminal -> do
 93 |         Just style <- elementGetStyle terminal
 94 |         cssStyleDeclarationSetProperty style "height" "200px" ""
 95 |         cssStyleDeclarationSetProperty style "position" "absolute" ""
 96 |         cssStyleDeclarationSetProperty style "bottom" "0" ""
 97 |         nodeInsertBefore body (Just div) (Just terminal)
 98 |       _             -> do
 99 |         nodeAppendChild body (Just div)
100 | 
101 |     -- We can get the elements by ID
102 |     Just numInput <- fmap castToHTMLInputElement <$> documentGetElementById doc "num"
103 |     Just prime    <- fmap castToHTMLDivElement   <$> documentGetElementById doc "prime"
104 |     Just heading  <- fmap castToHTMLElement      <$> documentGetElementById doc "heading"
105 | 
106 |     -- You can also use your favorite JavaScript libraries
107 | 
108 |     -- Run JavaScript using postGUISync to make sure it runs on the Gtk thread.
109 |     -- This should avoid threading issues when using WebKitGTK+.
110 |     let runjs = postGUIAsync . runJSaddle_ webView
111 | 
112 |     -- Declare the javascript property getters we will be using
113 |     let getElementById = js1 "getElementById"
114 |         getContext     = js1 "getContext"
115 |         fillStyle      = js "fillStyle"
116 |         fillRect :: Double -> Double -> Double -> Double -> JSF
117 |         fillRect       = js4 "fillRect"
118 |         get2dContext = do
119 |             document <- jsg "document"
120 |             -- var canvas = document.getElementById("canvas")
121 |             -- return canvas.getContext("2d")
122 |             canvas <- document ^. getElementById "canvas"
123 |             canvas ^. getContext "2d"
124 | 
125 |     liftIO . forkIO . forever $ do
126 |         runjs $ do
127 |             ctx <- get2dContext
128 |             -- ctx.fillStyle = "#00FF00"
129 |             -- ctx.fillRect( 0, 0, 150, 75 )
130 |             ctx ^. fillStyle <# "#00FF00"
131 |             ctx ^. fillRect 0 0 10 10
132 |         liftIO $ threadDelay 500000
133 |         runjs $ do
134 |             ctx <- get2dContext
135 |             ctx ^. fillStyle <# "#FF0000"
136 |             ctx ^. fillRect 0 0 10 10
137 |         liftIO $ threadDelay 500000
138 | 
139 |     -- We don't want to work on more than on prime number test at a time.
140 |     -- So we will have a single worker thread and a queue with just one value.
141 |     next <- newEmptyMVar
142 |     ready <- newEmptyMVar
143 |     worker <- forkIOWithUnmask $ \unmask -> forever $ unmask $ (do
144 |               n <- takeMVar next
145 |               postGUIAsync $ do
146 |                   htmlElementSetInnerHTML prime $ "Thinking about " ++ n
147 |               let message = validatePrime n
148 |               deepseq message $ postGUIAsync $ do
149 |                   htmlElementSetInnerHTML prime . unpack $ message)
150 |          `catch` \ (e :: NewValueException) -> return ()
151 | 
152 |     -- Something to set the next work item
153 |     let setNext = do
154 |                     n <- htmlInputElementGetValue numInput
155 |                     throwTo worker NewValueException
156 |                     putMVar next n
157 | 
158 |     -- Lets wire up some events
159 |     elementOnkeyup    numInput (liftIO setNext)
160 |     elementOnkeypress numInput (liftIO setNext)
161 | 
162 |     putStrLn "This is stdout."
163 |     hPutStrLn stderr "This is stderr."
164 |     putStrLn "You can get input from stdin."
165 |     putStrLn "(we also support threads and MVar, so you can wait 20 seconds if you don't have a keyboard)"
166 |     putStr   "What is your name ? "
167 |     hFlush stdout
168 | 
169 |     -- We can use MVars and threads
170 |     nameMVar <- newEmptyMVar
171 | 
172 |     -- Wait for input on one thread
173 |     forkIO $ do
174 |       line <- getLine
175 |       putMVar nameMVar line
176 | 
177 |     -- Wait for 20s on another
178 |     forkIO $ do
179 |       threadDelay 20000000
180 |       putMVar nameMVar "World"
181 | 
182 |     -- Get the first result
183 |     forkIO $ do
184 |       name <- takeMVar nameMVar
185 |       postGUISync $ do
186 |         htmlElementSetInnerText heading $ "Hello " ++ name ++ " and Welcome GHCJS"
187 | 
188 |         -- Set the input focus to the prime number test
189 |         elementFocus numInput
190 | 
191 |         -- Now stdout is free let's try some more JavaScript stuff...
192 |         runjs $ do
193 |             -- Some helper functions to print JS values
194 |             let log       v = deRefVal      v >>= (liftIO . print)
195 |                 logNumber v = valToNumber   v >>= (liftIO . print)
196 |                 logText   v = valToText     v >>= (liftIO . print)
197 |                 logList   v = mapM deRefVal v >>= (liftIO . print)
198 | 
199 |             -- Add Java Script logText function that calls the haskell logText
200 |             jsLogText <- jsg "logText" <# fun (\_f _this [s] -> logText s)
201 | 
202 |             -- logText("Hello World")
203 |             jsLogText # ["Hello World"]
204 | 
205 |             -- console.log(Math.sin(1))
206 |             math <- jsg "Math"
207 |             let sin = js1 "sin"
208 |             math ^. sin (1::Double) >>= logNumber
209 | 
210 |             -- (new Date()).toString()
211 |             -- (new Date(2013,1,1)).toString()
212 |             date <- jsg "Date"
213 |             new date () >>= logText
214 |             new date [2013,1,1::Double] >>= logText
215 | 
216 |             -- eval("logText('Hello'); 1+2")
217 |             eval "logText('Hello'); 1+2" >>= log
218 | 
219 |             -- logText(["Test", navigator.appVersion].length)
220 |             navigator  <- jsg "navigator"
221 |             let appVersion = js "appVersion"
222 |                 jsLength   = js "length"
223 |             jsLogText # array ("Test", navigator ^. appVersion) ^. jsLength
224 | 
225 |             -- callbackToHaskell = function () { console.log(arguments); }
226 |             callBack <- jsg "callbackToHaskell" <# fun (\f this -> logList)
227 | 
228 |             -- callbackToHaskell(null, undefined, true, 3.14, "Hello")
229 |             callBack # [ValNull, ValUndefined, ValBool True, ValNumber 3.14, ValString $ T.pack "List of JSValues"]
230 |             -- or
231 |             callBack # [val JSNull, val (), val True, val (3.14 :: Double), val "List of JSC JSValueRefs"]
232 |             -- or
233 |             callBack # (JSNull, (), True, (3.14 :: Double), "5-tuple")
234 |             -- or
235 |             eval "callbackToHaskell(null, undefined, true, 3.14, \"Eval\")"
236 | #ifdef MIN_VERSION_jmacro
237 |             -- or
238 |             eval $(litE . stringL . show $ renderJs [jmacro|callbackToHaskell(null, undefined, true, 3.14, "Evaled JMacro")|])
239 |             -- or
240 |             jmfunc <- eval $(litE . stringL . show $ renderJs [jmacroE| \ a b c d e -> callbackToHaskell(a, b, c, d, e) |])
241 |             let callJM :: (JSNull, (), Bool, Double, String) -> JSM JSValueRef = call jmfunc jmfunc
242 |             callJM (JSNull, (), True, 3.14, "Via JMacro Evaled Function")
243 | #endif
244 | 
245 |             -- var a = []; for(var i = 0; i != 10; ++i) a[i] = i; console.log(a[5]);
246 |             array ([0..10]::[Double]) !! 5 >>= log
247 | 
248 |             return ()
249 | 
250 |     -- What is this?
251 |     elementOnclick heading $ do
252 |       shiftIsPressed <- mouseShiftKey
253 |       when shiftIsPressed . liftIO $ lazyLoad_freecell webView doc body
254 | 
255 |     return ()
256 | 
257 | -- Integer uses goog.math.Integer compiled to Javascript
258 | isPrime :: Integer -> Bool
259 | isPrime p = p > 1 && (all (\n -> p `mod` n /= 0)
260 |                      $ takeWhile (\n -> n*n <= p) [2..])
261 | 
262 | validatePrimeMessage :: Integer -> Html
263 | validatePrimeMessage p | isPrime p = [shamlet|$newline always
264 |                                         <b>Yes</b>, #{p} is a prime|]
265 |                        | otherwise = [shamlet|$newline always
266 |                                         <b>No</b>, #{p} is not a prime|]
267 | 
268 | validatePrime :: String -> Text
269 | validatePrime s = renderHtml $
270 |   case reads s of
271 |     [(n, "")] -> validatePrimeMessage n
272 |     _         -> [shamlet|$newline always
273 |                     <b>No</b>, that is not a number|]
274 | 
275 | -- Sometimes you might have something that needs more JavaScript than everything else
276 | -- you can tell the GHCJS linker to put its dependancies in a sparate file using
277 | -- a lazyLoad_ prefix
278 | {-# NOINLINE lazyLoad_freecell #-}
279 | lazyLoad_freecell webView doc body = do
280 |     htmlElementSetInnerHTML body $
281 |       "<div style=\"position:relative;left:0px;top:0px;background-color:#e0d0ff;width:700px;height:500px\" "++
282 |       "id=\"freecell\" draggable=\"false\"></div>"
283 |     unlisten <- engine webView "freecell" =<< mkFreecell
284 |     -- Prevent finalizers running too soon
285 |     forkIO $ forever (threadDelay 1000000000) >> unlisten
286 |     return ()
287 | 


--------------------------------------------------------------------------------
/webkit-sodium/src/Freecell.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE DoRec #-}
  2 | -- | A minimal implementation of Freecell, a soltaire card game, to demonstrate
  3 | -- the Sodium reactive programming system.
  4 | --
  5 | -- BE WARNED! This game can be addictive.
  6 | --
  7 | -- Package dependencies:
  8 | --     random
  9 | --     stb-image
 10 | --     OpenGL
 11 | --     GLUT
 12 | module Freecell (mkFreecell) where
 13 | 
 14 | import FRP.Sodium
 15 | import Control.Applicative
 16 | import Control.Monad
 17 | import Data.Traversable (sequenceA)
 18 | import Data.List
 19 | import Data.Maybe
 20 | import System.Random
 21 | import System.FilePath
 22 | import Data.Array.IArray as A
 23 | import Data.Array.ST
 24 | import Game
 25 | 
 26 | 
 27 | data Suit  = Spades | Clubs | Diamonds | Hearts
 28 |              deriving (Eq, Ord, Show, Enum, Bounded)
 29 | data Value = Ace | Two | Three | Four | Five | Six | Seven | Eight | Nine | Ten | Jack | Queen | King
 30 |              deriving (Eq, Ord, Show, Enum, Bounded)
 31 | data Card  = Card Value Suit
 32 |              deriving (Eq, Ord, Show)
 33 | 
 34 | instance Enum Card where
 35 |     fromEnum (Card v s) = fromEnum v + fromEnum s * 13
 36 |     toEnum i = Card (toEnum v) (toEnum s)
 37 |       where
 38 |         (s, v) = divMod i 13
 39 | 
 40 | instance Bounded Card where
 41 |     minBound = Card minBound minBound
 42 |     maxBound = Card maxBound maxBound 
 43 | 
 44 | noOfStacks :: Int
 45 | noOfStacks = 8
 46 | 
 47 | noOfCells :: Int
 48 | noOfCells = 4
 49 | 
 50 | cardSize :: Vector
 51 | cardSize = (100,150)
 52 | 
 53 | overlapY :: Double
 54 | overlapY = 70
 55 | 
 56 | data Location = Stack Int | Cell Int | Grave deriving (Eq, Show)
 57 | 
 58 | data Bunch = Bunch {
 59 |         buInitOrig     :: Point,
 60 |         buInitMousePos :: Point,
 61 |         buCards        :: [Card],
 62 |         buOrigin       :: Location
 63 |     }
 64 |     deriving Show
 65 | 
 66 | data Destination = Destination {
 67 |         deLocation :: Location,
 68 |         deDropZone :: Rect,
 69 |         deMayDrop  :: [Card] -> Bool
 70 |     }
 71 | 
 72 | validSequence :: [Card] -> Bool
 73 | validSequence xs = and $ zipWith follows xs (drop 1 xs)
 74 | 
 75 | follows :: Card -> Card -> Bool
 76 | follows one@(Card v1 _) two@(Card v2 _) = isRed one /= isRed two && (v1 /= Ace && pred v1 == v2)
 77 |   where
 78 |     isRed :: Card -> Bool
 79 |     isRed (Card _ suit) = suit == Hearts || suit == Diamonds
 80 | 
 81 | cardSpacing :: Double
 82 | cardSpacing = (2000-cardWidth) / fromIntegral (noOfStacks-1)
 83 |   where
 84 |     (cardWidth, _) = cardSize
 85 | 
 86 | cardSpacingNarrow :: Double
 87 | cardSpacingNarrow = cardSpacing * 0.9
 88 | 
 89 | topRow :: Double
 90 | topRow = 1000 - 50 - cardHeight
 91 |   where
 92 |     (cardWidth, cardHeight) = cardSize
 93 | 
 94 | draw :: Point -> Card -> Sprite
 95 | draw pt (Card v s) = ((pt, cardSize), "cards" ++ [pathSeparator] ++ suitName s ++ valueName v ++ ".png")
 96 |   where
 97 |     suitName Spades = "s"
 98 |     suitName Clubs = "c"
 99 |     suitName Diamonds = "d"
100 |     suitName Hearts = "h"
101 |     valueName Ace = "1"
102 |     valueName Two = "2"
103 |     valueName Three = "3"
104 |     valueName Four = "4"
105 |     valueName Five = "5"
106 |     valueName Six = "6"
107 |     valueName Seven = "7"
108 |     valueName Eight = "8"
109 |     valueName Nine = "9"
110 |     valueName Ten = "10"
111 |     valueName Jack = "j"
112 |     valueName Queen = "q"
113 |     valueName King = "k"
114 | 
115 | emptySpace :: Point -> Sprite
116 | emptySpace pt = ((pt, cardSize), "cards" ++ [pathSeparator] ++ "empty-space.png") 
117 | 
118 | -- | The vertical stacks of cards, where cards can only be added if they're
119 | -- descending numbers and alternating red-black.
120 | stack :: Event MouseEvent -> [Card] -> Location -> Behavior Int -> Event [Card]
121 |       -> Reactive (Behavior [Sprite], Behavior Destination, Event Bunch)
122 | stack eMouse initCards loc@(Stack ix) freeSpaces eDrop = do
123 |     let (cardWidth, cardHeight) = cardSize
124 |         orig@(origX, origY) = (
125 |                 (-1000) + cardWidth*0.5 + fromIntegral ix * cardSpacing,
126 |                 300
127 |             )
128 |         positions = iterate (\(x, y) -> (x, y-overlapY)) orig
129 |     rec
130 |         cards <- hold initCards (eRemoveCards `merge` eAddCards)
131 |         let eAddCards = snapshotWith (\newCards cards -> cards ++ newCards) eDrop cards
132 |             eMouseSelection = filterJust $ snapshotWith (\mev cards ->
133 |                     case mev of
134 |                         MouseDown pt@(x, y) | x >= origX - cardWidth && x <= origX + cardWidth ->
135 |                             let n = length cards
136 |                                 bottomY = (origY - cardHeight) - overlapY * fromIntegral (n-1) 
137 |                                 ix = (length cards - 1) `min` floor (((origY + cardHeight) - y) / overlapY)
138 |                                 (left, taken) = splitAt ix cards
139 |                             in  if ix >= 0 && y >= bottomY
140 |                                     then Just (left, Bunch (positions !! ix) pt taken loc)
141 |                                     else Nothing
142 |                         _ -> Nothing
143 |                 ) eMouse cards
144 |             eRemoveCards = fst <$> eMouseSelection   -- Cards left over when we drag
145 |             eDrag        = snd <$> eMouseSelection   -- Cards removed when we drag
146 |     let sprites = map (uncurry draw) . zip positions <$> cards
147 |         dest = (\cards freeSpaces -> Destination {
148 |                     deLocation = loc,
149 |                     deDropZone = (orig `minus` (0, fromIntegral (length cards) * overlapY), cardSize),
150 |                     deMayDrop = \newCards ->
151 |                         validSequence newCards &&
152 |                         -- You get one card for free, but there must be free cells for any
153 |                         -- more than that.
154 |                         (length newCards - 1) <= freeSpaces &&
155 |                         case cards of
156 |                             [] -> True
157 |                             _  -> last cards `follows` head newCards
158 |                 }
159 |             ) <$> cards <*> freeSpaces
160 |     return (sprites, dest, eDrag)
161 | 
162 | -- | The "free cells" where cards can be temporarily put.
163 | cell :: Event MouseEvent -> Location -> Event [Card]
164 |      -> Reactive (Behavior [Sprite], Behavior Destination, Event Bunch, Behavior Int)
165 | cell eMouse loc@(Cell ix) eDrop = do
166 |     let (cardWidth, cardHeight) = cardSize
167 |         orig = ((-1000) + cardWidth*0.5 + fromIntegral ix * cardSpacingNarrow, topRow)
168 |         rect = (orig, cardSize)
169 |     rec
170 |         mCard <- hold Nothing $ eRemove `merge` (Just . head <$> eDrop)
171 |         let eMouseSelection = filterJust $ snapshotWith (\mev mCard ->
172 |                     case (mev, mCard) of
173 |                         (MouseDown pt, Just card) | pt `inside` rect ->
174 |                             Just (Nothing, Bunch (fst rect) pt [card] loc)
175 |                         _ -> Nothing
176 |                 ) eMouse mCard
177 |             eRemove = fst <$> eMouseSelection
178 |             eDrag = snd <$> eMouseSelection
179 |     let sprites = ((:[]) . maybe (emptySpace orig) (draw orig)) <$> mCard
180 |         dest = (\mCard -> Destination {
181 |                 deLocation = loc,
182 |                 deDropZone = rect,
183 |                 deMayDrop = \newCards -> length newCards == 1 && isNothing mCard
184 |             }) <$> mCard
185 |         emptySpaces = (\c -> if isNothing c then 1 else 0) <$> mCard
186 |     return (sprites, dest, eDrag, emptySpaces)
187 | 
188 | -- | The place where the cards end up at the top right, aces first.
189 | grave :: Event MouseEvent -> Event [Card]
190 |       -> Reactive (Behavior [Sprite], Behavior Destination, Event Bunch)
191 | grave eMouse eDrop = do
192 |     let xOf ix = 1000 - cardWidth*0.5 - cardSpacingNarrow * fromIntegral (3-ix)
193 |         positions = map (\ix -> (xOf ix, topRow)) [0..3]
194 |         areas = zip positions (repeat cardSize)
195 |         (cardWidth, cardHeight) = cardSize
196 |         wholeRect = (((xOf 0 + xOf 3) * 0.5, topRow), ((cardSpacingNarrow * 3 + cardWidth*2) * 0.5, cardHeight))    
197 |     rec
198 |         let eDropModify = snapshotWith (\newCards slots ->
199 |                     let newCard@(Card _ suit) = head newCards
200 |                         ix = fromEnum suit
201 |                     in  take ix slots ++ [Just newCard] ++ drop (ix+1) slots 
202 |                 ) eDrop slots
203 |         slots <- hold [Nothing, Nothing, Nothing, Nothing] (eDropModify `merge` eRemove)
204 |         let eMouseSelection = filterJust $ snapshotWith (\mev slots ->
205 |                     case mev of
206 |                         MouseDown pt ->
207 |                             let isIn = map (pt `inside`) areas
208 |                             in  case trueIxOf isIn of
209 |                                     Just ix ->
210 |                                         case slots !! ix of
211 |                                             Just card@(Card value suit) ->
212 |                                                 let prevCard = if value == Ace then Nothing
213 |                                                                                else Just (Card (pred value) suit)
214 |                                                     slots' = take ix slots ++ [prevCard] ++ drop (ix+1) slots
215 |                                                 in  Just (slots', Bunch (positions !! ix) pt [card] Grave)
216 |                                             Nothing -> Nothing
217 |                                     Nothing -> Nothing
218 |                         _ -> Nothing
219 |                 ) eMouse slots
220 |             eRemove = fst <$> eMouseSelection
221 |             eDrag = snd <$> eMouseSelection
222 |     let sprites = zipWith (\pos mSlot ->
223 |                 maybe (emptySpace pos) (draw pos) mSlot
224 |             ) positions <$> slots
225 |         dest = (\slots -> Destination {
226 |                 deLocation = Grave,
227 |                 deDropZone = wholeRect,
228 |                 deMayDrop = \newCards -> case newCards of
229 |                     [card@(Card value suit)] ->
230 |                         let ix = fromEnum suit
231 |                         in  case slots !! ix of
232 |                                 Just (Card topValue _) -> value == succ topValue
233 |                                 Nothing                -> value == Ace 
234 |                     _                    -> False
235 |             }) <$> slots
236 |     return (sprites, dest, eDrag)
237 |   where
238 |     -- Index of first true item in the list
239 |     trueIxOf items = doit items 0
240 |       where
241 |         doit [] _ = Nothing
242 |         doit (x:xs) ix = if x then Just ix
243 |                               else doit xs (ix+1)
244 | 
245 | -- | Draw the cards while they're being dragged.
246 | dragger :: Event MouseEvent -> Event Bunch -> Reactive (Behavior [Sprite], Event (Point, Bunch))
247 | dragger eMouse eStartDrag = do
248 |     dragPos <- hold (0,0) $ flip fmap eMouse $ \mev ->
249 |         case mev of
250 |             MouseUp   pt -> pt
251 |             MouseMove pt -> pt
252 |             MouseDown pt -> pt
253 |     rec
254 |         dragging <- hold Nothing $ (const Nothing <$> eDrop) `merge` (Just <$> eStartDrag)
255 |         let eDrop = filterJust $ snapshotWith (\mev mDragging ->
256 |                     case (mev, mDragging) of
257 |                         -- If the mouse is released, and we are dragging...
258 |                         (MouseUp pt, Just dragging) -> Just (cardPos pt dragging, dragging)
259 |                         _                           -> Nothing
260 |                 ) eMouse dragging
261 |     let sprites = drawDraggedCards <$> dragPos <*> dragging
262 |           where
263 |             drawDraggedCards pt (Just bunch) =
264 |                 let cpos = cardPos pt bunch
265 |                     positions = iterate (\(x, y) -> (x, y-overlapY)) cpos
266 |                 in  zipWith draw positions (buCards bunch) 
267 |             drawDraggedCards _ Nothing = []
268 |     return (sprites, eDrop)
269 |   where
270 |     cardPos pt bunch = (pt `minus` buInitMousePos bunch) `plus` buInitOrig bunch
271 | 
272 | -- | Determine where dropped cards are routed to.
273 | dropper :: Event (Point, Bunch) -> Behavior [Destination] -> Event (Location, [Card])
274 | dropper eDrop dests =
275 |     snapshotWith (\(pt, bunch) dests ->
276 |                 -- If none of the destinations will accept the dropped cards, then send them
277 |                 -- back where they originated from.
278 |                 let findDest [] = (buOrigin bunch, buCards bunch)
279 |                     findDest (dest:rem) =
280 |                         if pt `inside` deDropZone dest && deMayDrop dest (buCards bunch)
281 |                             then (deLocation dest, buCards bunch)
282 |                             else findDest rem
283 |                 in  findDest dests
284 |             ) eDrop dests
285 | 
286 | distributeTo :: Event (Location, [Card]) -> [Location] -> [Event [Card]]
287 | distributeTo eWhere locations = flip map locations $ \thisLoc ->
288 |     filterJust $ (\(loc, cards) ->
289 |             if loc == thisLoc
290 |                 then Just cards
291 |                 else Nothing
292 |         ) <$> eWhere
293 | 
294 | freecell :: [[Card]] -> Event MouseEvent -> Reactive (BehaviorTree [Sprite])
295 | freecell stackCards eMouse = do
296 |     let stLocs = map Stack [0..noOfStacks-1]
297 |         ceLocs = map Cell [0..noOfCells-1]
298 |     rec
299 |         let eWhere = dropper eDrop (sequenceA (stDests ++ ceDests ++ [grDest]))
300 |             stDrops = eWhere `distributeTo` stLocs
301 |             ceDrops = eWhere `distributeTo` ceLocs
302 |             grDrops = eWhere `distributeTo` [Grave]
303 |         (stSprites, stDests, stDrags) <- unzip3 <$> forM (zip3 stLocs stackCards stDrops) (\(loc, cards, drop) ->
304 |             stack eMouse cards loc emptySpaces drop)
305 |         (ceSprites, ceDests, ceDrags, ceEmptySpaces) <- unzip4 <$> forM (zip ceLocs ceDrops) (\(loc, drop) ->
306 |             cell eMouse loc drop)
307 |         (grSprites, grDest, grDrag) <- grave eMouse (head grDrops)
308 |         -- The total number of empty spaces available in cells - 0 to 4. We need to
309 |         -- know this when we drop a stack of cards, because (the rules of the game say)
310 |         -- this is equivalent to temporarily putting all but one of them in cells.
311 |         let emptySpaces = foldr1 (\x y -> (+) <$> x <*> y) ceEmptySpaces
312 |         (drSprites, eDrop) <- dragger eMouse (foldr1 merge (stDrags ++ ceDrags ++ [grDrag]))
313 |     return $ toTree stSprites :++ toTree ceSprites :++ BehaviorNode grSprites :++ BehaviorNode drSprites
314 |   where
315 |     toTree = foldr1 (:++) . map BehaviorNode
316 | 
317 | shuffle :: StdGen -> [Card] -> ([Card], StdGen)
318 | shuffle rng cards =
319 |     let n = length cards
320 |         (rng', ixes) = mapAccumL (\rng () ->
321 |                 let (ix, rng') = randomR (0, n-1) rng
322 |                 in  (rng', ix)) rng (replicate n ())
323 |         ary = runSTArray $ do
324 |             ary <- newListArray (0, n-1) cards
325 |             forM_ (zip [0..n-1] ixes) $ \(ix1, ix2) -> do
326 |                 when (ix1 /= ix2) $ do
327 |                     one <- readArray ary ix1
328 |                     two <- readArray ary ix2
329 |                     writeArray ary ix1 two
330 |                     writeArray ary ix2 one
331 |             return ary
332 |     in  (A.elems ary, rng')
333 | 
334 | toStacks :: Int -> [Card] -> [[Card]]
335 | toStacks noOfStacks cards = foldl (\stacks layer ->
336 |         zipWith (++) (map (:[]) layer ++ repeat []) stacks
337 |     ) (replicate noOfStacks []) (layerize cards)
338 |   where
339 |     layerize :: [Card] -> [[Card]]
340 |     layerize cards = case splitAt noOfStacks cards of
341 |         ([], _) -> []
342 |         (layer, rem) -> layer : layerize rem
343 | 
344 | mkFreecell :: IO (Event MouseEvent -> Reactive (BehaviorTree [Sprite]))
345 | mkFreecell = do
346 |     rng <- newStdGen
347 |     let (cards, rng') = shuffle rng [minBound..maxBound]
348 |     return $ freecell (toStacks noOfStacks cards)
349 | 
350 | 


--------------------------------------------------------------------------------