3 |
4 | #define NIL (0)
5 |
6 | static const char text[] = "hello world!";
7 |
8 | main()
9 | {
10 | // Open the display
11 | Display *dpy = XOpenDisplay(NIL);
12 |
13 | int blackColor = BlackPixel(dpy, DefaultScreen(dpy));
14 | int whiteColor = WhitePixel(dpy, DefaultScreen(dpy));
15 |
16 | // Create the window
17 | Window w = XCreateSimpleWindow(dpy, DefaultRootWindow(dpy), 0,
18 | 0, 200, 100, 0, blackColor, blackColor);
19 |
20 | // Register MapNotify events
21 | XSelectInput(dpy, w, StructureNotifyMask);
22 |
23 | // Make the window appear on the screen
24 | XMapWindow(dpy, w);
25 |
26 | // Create a new graphics context
27 | GC gc = XCreateGC(dpy, w, 0, NIL);
28 |
29 | XSetForeground(dpy, gc, whiteColor);
30 |
31 | // Loop until we get a MapNotify event
32 | for(;;) {
33 | XEvent e;
34 | XNextEvent(dpy, &e);
35 | if (e.type == MapNotify)
36 | break;
37 | }
38 |
39 | XFontStruct *fs = XLoadQueryFont(dpy, "cursor");
40 |
41 | XDrawString(dpy, w, gc, 40, 50, text, sizeof(text));
42 |
43 | // Flush the commands to the X server
44 | XFlush(dpy);
45 |
46 | sleep(8);
47 | }
48 |
--------------------------------------------------------------------------------
/thesis-snippets/OO/ParaPointBounded.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE ExistentialQuantification,DatatypeContexts #-}
2 | module ParaPointBounded where
3 | import Data.IORef
4 | {-
5 | data Num a => ParaPointClass a = ParaPointClass {
6 | varX :: IORef a
7 | ,getX :: IO a
8 | ,moveX :: a -> IO ()
9 | ,getOffset :: IO a
10 | }
11 | -}
12 | {-
13 | data ParaPointClass = forall a. Num a => ParaPointClass {
14 | varX :: IORef a
15 | ,getX :: IO a
16 | ,moveX :: a -> IO ()
17 | ,getOffset :: IO a
18 | }
19 | -}
20 | o # f = f o
21 |
22 | data ParaPointClass a = ParaPointClass {
23 | varX :: IORef a
24 | ,getX :: IO a
25 | ,moveX :: a -> IO ()
26 | ,getOffset :: IO a
27 | }
28 |
29 | para_point x_init = do
30 | x <- newIORef x_init
31 | return ParaPointClass {
32 | varX = x
33 | ,getX = readIORef x
34 | ,moveX = \d -> modifyIORef x ((+) d)
35 | ,getOffset = readIORef x >>= \x -> return (x - x_init)
36 | }
37 |
38 | test = do
39 | p1 <- para_point (3 :: Int)
40 | p2 <- para_point (3.0 :: Double)
41 | o <- getOffset p2
42 | moveX p1 $ 2.0
43 | putStrLn (show o)
44 | return ()
45 |
46 | myPolyOOP = do
47 | p <- para_point (1::Int)
48 | p' <- para_point (1::Double)
49 | p # moveX $ 2
50 | p' # moveX $ 2.5
51 | p # getX >>= print
52 | p' # getX >>= print
53 |
54 |
--------------------------------------------------------------------------------
/wxasteroids/contravariant-0.1.2/Data/Functor/Contravariant/Compose.hs:
--------------------------------------------------------------------------------
1 | -- |
2 | -- Module : Data.Functor.Contravariant.Compose
3 | -- Copyright : (c) Edward Kmett 2010
4 | -- License : BSD3
5 | --
6 | -- Maintainer : ekmett@gmail.com
7 | -- Stability : experimental
8 | -- Portability : portable
9 | --
10 | -- Composition of contravariant functors.
11 |
12 | module Data.Functor.Contravariant.Compose
13 | ( Compose(..)
14 | , ComposeFC(..)
15 | , ComposeCF(..)
16 | ) where
17 |
18 | import Data.Functor.Contravariant
19 |
20 | -- | Composition of two contravariant functors
21 | newtype Compose f g a = Compose { getCompose :: f (g a) }
22 |
23 | instance (Contravariant f, Contravariant g) => Functor (Compose f g) where
24 | fmap f (Compose x) = Compose (contramap (contramap f) x)
25 |
26 | -- | Composition of covariant and contravariant functors
27 | newtype ComposeFC f g a = ComposeFC { getComposeFC :: f (g a) }
28 |
29 | instance (Functor f, Contravariant g) => Contravariant (ComposeFC f g) where
30 | contramap f (ComposeFC x) = ComposeFC (fmap (contramap f) x)
31 |
32 | -- | Composition of contravariant and covariant functors
33 | newtype ComposeCF f g a = ComposeCF { getComposeCF :: f (g a) }
34 |
35 | instance (Contravariant f, Functor g) => Contravariant (ComposeCF f g) where
36 | contramap f (ComposeCF x) = ComposeCF (contramap (fmap f) x)
37 |
38 |
--------------------------------------------------------------------------------
/wxasteroids/src/Graphics/UI/WXCore/GraphicsRenderer.hs:
--------------------------------------------------------------------------------
1 | module Graphics.UI.WXCore.GraphicsRenderer (
2 | module Graphics.UI.WXCore.GraphicsRendererClass
3 | ,graphicsRenderer
4 | ,graphicsRendererGetDefaultRenderer
5 | ) where
6 |
7 | import LightOO
8 | import Graphics.UI.WXCore.Types
9 | import Graphics.UI.WXCore.GraphicsRendererClass
10 | import Graphics.UI.WXCore.GraphicsContext
11 | import Data.IORef
12 | import System.IO.Unsafe
13 |
14 | graphicsRenderer =
15 | (graphicsRenderer' `extends` object) noOverride set_Object_Tail
16 | where
17 | graphicsRenderer' tail super self =
18 | return GraphicsRendererClass {
19 | {-
20 | wxGraphicsContext * wxMacCoreGraphicsRenderer::CreateContext( wxWindow* window )
21 | {
22 | return new wxMacCoreGraphicsContext(this, window );
23 | }
24 | -}
25 | _graphicsRendererCreateContextFromWindow = \w -> do
26 | return undefined
27 | --let gr :: GraphicsRenderer
28 | -- gr = upcast self
29 | --new $ canvasGraphicsContext w gr
30 | , _graphicsRendererTail = tail
31 | }
32 |
33 | defaultRendererRef :: IORef (Maybe GraphicsRenderer)
34 | defaultRendererRef = unsafePerformIO (newIORef Nothing)
35 |
36 | graphicsRendererGetDefaultRenderer :: IO GraphicsRenderer
37 | graphicsRendererGetDefaultRenderer =
38 | singleton defaultRendererRef graphicsRenderer
--------------------------------------------------------------------------------
/thesis-snippets/JS/HOF.hs:
--------------------------------------------------------------------------------
1 | module HOF where
2 |
3 | data JSObject a
4 |
5 | data JSBool_
6 | type JSBool = JSObject JSBool_
7 |
8 | data JSNumber_
9 | type JSNumber = JSObject JSNumber_
10 |
11 | data JSString_
12 | type JSString = JSObject PackedString
13 |
14 | data JSFunction_ a
15 | type JSFunction a = JSObject (JSFunction_ a)
16 |
17 | foreign import js "twice(%*)"
18 | _twice :: JSFunction (IO ()) -> IO ()
19 |
20 | foreign import js "wrapper"
21 | _twice_hof :: IO () -> JSFunction (IO ())
22 |
23 | twice :: IO () -> IO ()
24 | twice = _twice . _twice_hof
25 |
26 |
27 | hof1 :: (JSBool -> IO JSString) -> IO JSString
28 | hof1 = _hof1 . _hof1_f
29 |
30 | foreign import js "hof1(%*)"
31 | _hof1 :: JSFunction (JSBool -> IO JSString) -> IO JSString
32 |
33 | foreign import js "wrapper"
34 | _hof1_f :: (JSBool -> IO JSString) -> JSFunction (JSBool -> IO JSString)
35 |
36 | foreign import js "console.log(%1)"
37 | log :: a -> IO ()
38 |
39 | foreign import js "'foo'"
40 | _foo_str :: JSString
41 |
42 | foreign import js "createCounter()"
43 | createCounter :: IO (JSFunction (IO Int))
44 |
45 | foreign import js "dynamic"
46 | mkFun :: JSFunction (IO Int) -> IO Int
47 |
48 | main = do
49 | twice (putStr "Hello World!")
50 |
51 | r <- hof1 (\b -> log b >> return _foo_str)
52 | log r
53 |
54 | jsF <- createCounter
55 | let f = mkFun jsF
56 |
57 | mapM_ (\m -> m >>= print) [f,f,f]
58 |
--------------------------------------------------------------------------------
/lightoo/src/LightOOUHC.h:
--------------------------------------------------------------------------------
1 | #define DefineClass(X,XC,XTAIL,AP,NP) \
2 | type X ## _ AP t = XC AP t ; \
3 | type X AP = X ## _ AP () ; \
4 | \
5 | instance ModTail (XC AP) where { \
6 | getTail = _ ## XTAIL ; \
7 | setTail o v = o { _ ## XTAIL = v } } ; \
8 | \
9 | get_ ## X ## _Tail :: X ## _ AP t -> Record t ; \
10 | get_ ## X ## _Tail = getTail ; \
11 | set_ ## X ## _Tail :: X ## _ AP t -> Record tt -> X ## _ AP tt ; \
12 | set_ ## X ## _Tail o v = setTail o v ; \
13 | modify_ ## X ## _Tail = mkMod set_ ## X ## _Tail get_ ## X ## _Tail ;
14 |
15 | #define DefineSubClass(X,Y,XC,XTAIL,AP,YP,XP,NP,CONSTR) \
16 | type X ## _ AP t = Y ## _ YP (XC XP t) ; \
17 | type X AP = X ## _ AP () ; \
18 | \
19 | instance (CONSTR) => Narrow (X AP) (Y YP) where { \
20 | narrow = modify_ ## Y ## _Tail hideRecord } ; \
21 | \
22 | instance (CONSTR) => Widen (Y YP) (X AP) where { \
23 | widen o = genericWiden o get_ ## Y ## _Tail set_ ## Y ## _Tail } ; \
24 | \
25 | instance ModTail (XC XP) where { \
26 | getTail = _ ## XTAIL ; \
27 | setTail o v = o { _ ## XTAIL = v } } ; \
28 | \
29 | get_ ## X ## _Tail :: X ## _ AP t -> Record t ; \
30 | get_ ## X ## _Tail = getTail . unRecord . get_ ## Y ## _Tail ; \
31 | set_ ## X ## _Tail :: X ## _ AP t -> Record tt -> X ## _ AP tt ; \
32 | set_ ## X ## _Tail o v = modify_ ## Y ## _Tail (\o -> record $ setTail (unRecord o) v) o ; \
33 | modify_ ## X ## _Tail = mkMod set_ ## X ## _Tail get_ ## X ## _Tail ;
34 |
--------------------------------------------------------------------------------
/uhc-js/uhc-js/src/Language/UHC/JS/HTML5/HTMLCanvasElement.hs:
--------------------------------------------------------------------------------
1 | {-
2 | interface HTMLCanvasElement : HTMLElement {
3 | attribute unsigned long width;
4 | attribute unsigned long height;
5 |
6 | DOMString toDataURL(optional DOMString type, any... args);
7 | void toBlob(FileCallback? _callback, optional DOMString type, any... args);
8 |
9 | object? getContext(DOMString contextId, any... args);
10 | };
11 | -}
12 | module Language.UHC.JS.HTML5.HTMLCanvasElement where
13 |
14 | import Language.UHC.JS.Types
15 | import Language.UHC.JS.Marshal
16 | import Language.UHC.JS.HTML5.Types
17 | import Language.UHC.JS.Prelude
18 |
19 | foreign import js "%1.width"
20 | getWidth :: HTMLCanvasElement -> IO Integer
21 |
22 | width :: HTMLCanvasElement -> Int -> IO ()
23 | width e w = setAttr_ "width" w e
24 |
25 | foreign import js "%1.height"
26 | getHeight :: HTMLCanvasElement -> IO Integer
27 |
28 | height :: HTMLCanvasElement -> Int -> IO ()
29 | height e w = setAttr_ "height" w e
30 |
31 | foreign import js "%1.toDataURL(%*)"
32 | toDataURL :: HTMLCanvasElement -> JSArray JSString -> IO JSString
33 |
34 | foreign import js "%1.getContext(%*)"
35 | getContext :: HTMLCanvasElement -> JSString -> IO JSObject
36 |
37 | get2DContext :: HTMLCanvasElement -> IO (Maybe CanvasRenderingContext2D)
38 | get2DContext e = do
39 | let d :: JSString
40 | d = toJS "2d"
41 | o <- getContext e d
42 | return $ cast o
43 |
--------------------------------------------------------------------------------
/thesis-snippets/OO/InheritanceWithOverride.hs:
--------------------------------------------------------------------------------
1 | module InheritanceWithOverride where
2 | import Data.IORef
3 | import Control.Monad.Fix (mfix)
4 | import Prelude hiding ( print )
5 |
6 | o # f = f o
7 |
8 | data PrintablePointClass a = PrintablePointClass {
9 | varX :: IORef Int
10 | ,getX :: IO Int
11 | ,moveX :: Int -> IO ()
12 | ,print :: IO ()
13 | ,printablePointTail :: a
14 | }
15 |
16 | printable_point x_init consOp self = do
17 | x <- newIORef x_init
18 | cons <- consOp
19 | return PrintablePointClass {
20 | varX = x
21 | ,getX = readIORef x
22 | ,moveX = \d -> modifyIORef x ((+) d)
23 | ,print = (self # getX) >>= putStr . show
24 | ,printablePointTail = cons self
25 | }
26 |
27 | data ColoredPointClass a = ColoredPointClass {
28 | getColor :: IO String
29 | ,coloredPointTail :: a
30 | }
31 |
32 | colored_point' x color consOp self = do
33 | super <- printable_point x colored_point' self
34 | return super {
35 | print = do putStr "so far - "; super # print
36 | putStr "color - "; putStr (show color)
37 | }
38 |
39 | where
40 |
41 | colored_point' = do
42 | cons <- consOp
43 | return $ \self -> ColoredPointClass {
44 | getColor = return color
45 | ,coloredPointTail = cons self
46 | }
47 |
48 | getColor' = getColor . printablePointTail
49 |
50 | nil = (return :: a -> IO a) $ \_ -> ()
51 |
52 | myOverridingOOP = do
53 | p <- mfix (colored_point' 3 "red" nil)
54 | p # print
55 |
56 |
--------------------------------------------------------------------------------
/lightoo/src/LightOO.h:
--------------------------------------------------------------------------------
1 | #define DefineClass(X,XC,XTAIL,AP,NP) \
2 | type X ## _ AP t = XC AP t ; \
3 | type X AP = X ## _ AP () ; \
4 | \
5 | deriving instance Typeable ## NP XC ; \
6 | \
7 | instance ModTail (XC AP) where { \
8 | getTail = _ ## XTAIL ; \
9 | setTail o v = o { _ ## XTAIL = v } } ; \
10 | \
11 | get_ ## X ## _Tail :: X ## _ AP t -> Record t ; \
12 | get_ ## X ## _Tail = getTail ; \
13 | set_ ## X ## _Tail :: X ## _ AP t -> Record tt -> X ## _ AP tt ; \
14 | set_ ## X ## _Tail o v = setTail o v ; \
15 | modify_ ## X ## _Tail = mkMod set_ ## X ## _Tail get_ ## X ## _Tail ;
16 |
17 | #define DefineSubClass(X,Y,XC,XTAIL,AP,YP,XP,NP,CONSTR) \
18 | type X ## _ AP t = Y ## _ YP (XC XP t) ; \
19 | type X AP = X ## _ AP () ; \
20 | \
21 | instance (CONSTR) => Narrow (X AP) (Y YP) where { \
22 | narrow = modify_ ## Y ## _Tail hideRecord } ; \
23 | \
24 | instance (CONSTR) => Widen (Y YP) (X AP) where { \
25 | widen o = genericWiden o get_ ## Y ## _Tail set_ ## Y ## _Tail } ; \
26 | \
27 | deriving instance Typeable ## NP XC ; \
28 | \
29 | instance ModTail (XC XP) where { \
30 | getTail = _ ## XTAIL ; \
31 | setTail o v = o { _ ## XTAIL = v } } ; \
32 | \
33 | get_ ## X ## _Tail :: X ## _ AP t -> Record t ; \
34 | get_ ## X ## _Tail = getTail . unRecord . get_ ## Y ## _Tail ; \
35 | set_ ## X ## _Tail :: X ## _ AP t -> Record tt -> X ## _ AP tt ; \
36 | set_ ## X ## _Tail o v = modify_ ## Y ## _Tail (\o -> record $ setTail (unRecord o) v) o ; \
37 | modify_ ## X ## _Tail = mkMod set_ ## X ## _Tail get_ ## X ## _Tail ;
38 |
--------------------------------------------------------------------------------
/lightoo/src/Examples/Print.hs:
--------------------------------------------------------------------------------
1 | {- Copied from OOHaskell source code -}
2 | {-# LANGUAGE FlexibleInstances#-}
3 | {-# LANGUAGE TypeSynonymInstances#-}
4 | {-# LANGUAGE UndecidableInstances#-}
5 | {-# LANGUAGE OverlappingInstances#-}
6 | {-# LANGUAGE DatatypeContexts #-}
7 | module Examples.Print
8 | (
9 | printLn,
10 | (<<)
11 | )
12 | where
13 |
14 | import Prelude hiding (print)
15 | --import Data.HList.HListPrelude
16 |
17 |
18 | -- The type-class for printing
19 |
20 | class PrintType x
21 | where
22 | print :: x -> IO ()
23 |
24 |
25 | -- Printable composites
26 |
27 | data (PrintType x, PrintType y) => PrintPair x y = PrintPair x y
28 |
29 |
30 | -- Compose printable expressions (aka daisy chaining)
31 |
32 | infixl 7 <<
33 | (<<) :: (PrintType x, PrintType y) => x -> y -> PrintPair x y
34 | x << y = PrintPair x y
35 |
36 |
37 | -- Strings are printable right away
38 |
39 | instance PrintType String
40 | where
41 | print = putStr
42 |
43 |
44 | -- IO computations are computed and then printed with the help of shown
45 |
46 | instance Show x => PrintType (IO x)
47 | where
48 | print x = x >>= putStr . show
49 |
50 |
51 | -- Printing compound expressions
52 |
53 | instance (PrintType x, PrintType y) => PrintType (PrintPair x y)
54 | where
55 | print (PrintPair x y) = print x >> print y
56 |
57 |
58 | -- Printing the rest
59 |
60 | instance Show x => PrintType x
61 | where
62 | print = putStr . show
63 |
64 |
65 | -- Print expression and begin a new line
66 |
67 | printLn x = print x >> putStr "\n"
68 |
--------------------------------------------------------------------------------
/uhc-js/tests/in-progress/jquery/jquery.hs:
--------------------------------------------------------------------------------
1 |
2 | import Language.UHC.JS.Assorted
3 | import Language.UHC.JS.ECMA.String
4 | import Language.UHC.JS.Primitives
5 | import Language.UHC.JS.Types
6 | import Language.UHC.JS.JQuery.JQuery
7 |
8 |
9 |
10 | main :: IO ()
11 | main = return ()
12 |
13 | -- Main function
14 | foreign export jscript "jQueryMain"
15 | jQueryMain :: IO ()
16 |
17 | jQueryMain :: IO ()
18 | jQueryMain = do
19 | showAlert
20 | sayHi
21 | addNeat
22 | showNeat
23 |
24 | -- Show an alert
25 | foreign export jscript "showAlert"
26 | showAlert :: IO ()
27 |
28 | showAlert :: IO ()
29 | showAlert = alert "Hello, World!"
30 |
31 | -- Set the contents for to the body element.
32 | foreign export jscript "sayHi"
33 | sayHi :: IO ()
34 |
35 | sayHi :: IO ()
36 | sayHi = do
37 | j <- jQuery "body"
38 | setHTML j "Hi there!"
39 |
40 | -- Add a (hidden) paragraph to the body element.
41 | foreign export jscript "addNeat"
42 | addNeat :: IO ()
43 |
44 | addNeat :: IO ()
45 | addNeat = do
46 | j <- jQuery "body"
47 | h <- getHTML j
48 | setHTML j $ h ++ ""
49 | ++ "Congratulations! This awesome "
50 | ++ "jQuery script has been called by a function you have "
51 | ++ "written in Haskell!
"
52 |
53 | -- Show the previously added paragraph using an animation.
54 | foreign export jscript "showNeat"
55 | showNeat :: IO ()
56 |
57 | showNeat :: IO ()
58 | showNeat = do
59 | j <- jQuery "p.neat"
60 | addClass j "ohmy"
61 | jqshow j (Just slow) Nothing Nothing
62 |
--------------------------------------------------------------------------------
/uhc-js/uhc-js/src/Language/UHC/JS/Backbone/Events.hs:
--------------------------------------------------------------------------------
1 | module Language.UHC.JS.Backbone.Events where
2 |
3 | import Language.UHC.JS.ECMA.String
4 | import Language.UHC.JS.Backbone.Model
5 | import Language.UHC.JS.Primitives
6 | import Language.UHC.JS.Types
7 | import Language.UHC.JS.Marshal
8 |
9 | bind :: JSAny a -> String -> JSFunction_ b -> IO ()
10 | bind p s = _bind p (toJS s)
11 |
12 | foreign import js "%1.bind(%*)"
13 | _bind :: JSAny a -> JSString -> JSFunction_ b -> IO ()
14 |
15 | bind' :: JSAny a -> String -> JSFunction_ b -> JSAny b -> IO ()
16 | bind' p s c = _bind' p (toJS s) c
17 |
18 | foreign import js "%1.bind(%*)"
19 | _bind' :: JSAny a -> JSString -> JSFunction_ b -> JSAny b -> IO ()
20 |
21 |
22 | foreign import js "%1.unbind()"
23 | unbind :: JSAny a -> IO ()
24 |
25 |
26 | unbind' :: JSAny a -> String -> IO ()
27 | unbind' p s = _unbind' p (toJS s)
28 |
29 | foreign import js "%1.unbind(%*)"
30 | _unbind' :: JSAny a -> JSString -> IO ()
31 |
32 | unbind'' :: JSAny a -> String -> JSFunction_ b -> IO ()
33 | unbind'' p s f = _unbind'' p (toJS s) f
34 |
35 | foreign import js "%1.unbind(%*)"
36 | _unbind'' :: JSAny a -> JSString -> JSFunction_ b -> IO ()
37 |
38 |
39 | trigger :: JSAny a -> String -> IO ()
40 | trigger p s = _trigger p (toJS s)
41 |
42 | foreign import js "%1.trigger(%*)"
43 | _trigger :: JSAny a -> JSString -> IO ()
44 |
45 | trigger' :: JSAny a -> String -> JSObject_ b -> IO ()
46 | trigger' p s o = _trigger' p (toJS s) o
47 |
48 | foreign import js "%1.trigger(%*)"
49 | _trigger' :: JSAny a -> JSString -> JSObject_ b -> IO ()
50 | -- etc.
51 |
--------------------------------------------------------------------------------
/wxasteroids/README.md:
--------------------------------------------------------------------------------
1 | A port of wxAsteroids to the web browser
2 | ===========
3 |
4 | The [wxHaskell paper][1] demonstrates its library design through a clone of the classic asteroids game coined: wxAsteroids.
5 | Using the Utrecht Haskell Compiler (UHC) we have ported a subset of wxHaskell to the web browser. This has enabled us
6 | to run a feature-light version of wxAsteroids in the browser. See [my thesis][2] for more information, for the demo [click here](http://uu-computerscience.github.com/js-asteroids/build/Asteroids.html).
7 |
8 | 
9 |
10 | Building wxAsteroids
11 | --------------------
12 |
13 | In order to build wxAsteroids you will need:
14 |
15 | * A recent version of [UHC](https://github.com/UU-ComputerScience/uhc) (tested with ehc-1.1.4, revision js@658578eae9)
16 | * [cpphs](http://projects.haskell.org/cpphs/)
17 |
18 | Make sure that you have an environment variable (UHC) setup to refer to your UHC binary:
19 |
20 | export UHC = "your UHC binary location here"
21 |
22 | Running make will compile the sources and output a single HTML file that links everything together.
23 |
24 | make
25 |
26 | To run the application open up the HTML file in your browser of choice:
27 |
28 | chromium-browser src/Asteroids.html
29 |
30 | Warning: only tested in Chrome on Ubuntu 12.10
31 |
32 | [1]: http://dl.acm.org/citation.cfm?id=1017472.1017483
33 | [2]: https://github.com/UU-ComputerScience/js-asteroids/raw/master/msc-thesis/thesis.pdf
34 |
--------------------------------------------------------------------------------
/wxasteroids/contravariant-0.1.2/LICENSE:
--------------------------------------------------------------------------------
1 | Copyright 2007-2011 Edward Kmett
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
7 | are met:
8 |
9 | 1. Redistributions of source code must retain the above copyright
10 | notice, this list of conditions and the following disclaimer.
11 |
12 | 2. Redistributions in binary form must reproduce the above copyright
13 | notice, this list of conditions and the following disclaimer in the
14 | documentation and/or other materials provided with the distribution.
15 |
16 | 3. Neither the name of the author nor the names of his contributors
17 | may be used to endorse or promote products derived from this software
18 | without specific prior written permission.
19 |
20 | THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
21 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
22 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
23 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
24 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
25 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
26 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
27 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
28 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
29 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
30 | POSSIBILITY OF SUCH DAMAGE.
31 |
--------------------------------------------------------------------------------
/thesis-snippets/OO/Substitution.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE ScopedTypeVariables, ImpredicativeTypes, TypeOperators, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}
2 | module Substitution where
3 | import Unsafe.Coerce
4 |
5 | class Sub a b where
6 | upcast :: a -> b
7 |
8 | -- depth 1
9 |
10 | instance Sub (a ()) (a ()) where
11 | upcast = id
12 |
13 | -- depth 2
14 |
15 | instance Sub (a (b ())) (a (b ())) where
16 | upcast = id
17 |
18 |
19 | instance (Sub (a ()) x) => Sub (a (b ())) x where
20 | upcast = upcast . (undefined :: a (b ()) -> a () )
21 |
22 | -- depth 3
23 |
24 | instance Sub (a (b (c ()))) (a (b (c ()))) where
25 | upcast = id
26 |
27 | instance (Sub (a (b ())) x) => Sub (a (b (c ()))) x where
28 | upcast = upcast . (undefined :: a (b (c ())) -> a (b ()))
29 |
30 |
31 |
32 | data A a
33 | data B a
34 | data C a
35 |
36 | --subst :: A () -> A (forall a. a)
37 | subst :: A () -> A a
38 | subst = unsafeCoerce
39 |
40 | subst' :: A (forall a. a) -> A ()
41 | subst' = unsafeCoerce
42 |
43 | test :: A a -> IO ()
44 | test a = putStrLn "Hi"
45 |
46 | _subst :: a () -> a (forall t. t)
47 | _subst = unsafeCoerce
48 |
49 | newtype CW a = CW { unC :: A (B (C a)) }
50 |
51 |
52 | trans :: A () -> A ()
53 | trans a =
54 | let f :: (Sub a (A ())) => a -> A ()
55 | f = upcast
56 |
57 | g :: A () -> A a
58 | g = subst
59 |
60 | in f (g a)
61 |
62 | main = do
63 | let a = undefined :: A ()
64 | let c = undefined :: A (B (C ()))
65 | let x = subst a -- :: A Bool
66 | let y = subst' x
67 | test x
68 | test y
69 | let c' = unC $ _subst (CW c)
70 | return c'
71 |
72 |
--------------------------------------------------------------------------------
/uhc-js/uhc-js/LICENSE:
--------------------------------------------------------------------------------
1 | Copyright (c)2011, Jurriën Stutterheim
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 Jurriën Stutterheim 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 |
--------------------------------------------------------------------------------
/uhc-js/uhc-js/src/Language/UHC/JS/Backbone/View.hs:
--------------------------------------------------------------------------------
1 | module Language.UHC.JS.Backbone.View where
2 |
3 | import Language.UHC.JS.JQuery.JQuery
4 | import Language.UHC.JS.Primitives
5 | import Language.UHC.JS.ECMA.String
6 | import Language.UHC.JS.Types
7 | import Language.UHC.JS.W3C.HTML5
8 | import Language.UHC.JS.Prelude
9 | import Language.UHC.JS.Marshal
10 |
11 | data BBViewPtr
12 | type BBView = JSObject_ BBViewPtr
13 |
14 | foreign import js "Backbone.View.extend(%*)"
15 | extend :: JSObject_ a -> IO (JSFunction_ b)
16 |
17 | foreign import js "Backbone.View.extend(%*)"
18 | extend' :: JSObject_ a -> JSObject_ b -> IO (JSFunction_ b)
19 |
20 | getEl :: BBView -> IO Element
21 | getEl = getAttr "el"
22 |
23 | setEl :: Element -> BBView -> IO BBView
24 | setEl = setAttr "el"
25 |
26 | jQuery :: String -> IO JQuery
27 | jQuery = _jQuery . toJS
28 |
29 | jQuery' :: String -> JSAny a -> IO JQuery
30 | jQuery' s j = _jQuery' (toJS s) j
31 |
32 | setRender :: JSFunction_ a -> BBView -> IO BBView
33 | setRender = setAttr "render"
34 |
35 | foreign import js "%1.remove()"
36 | remove :: BBView -> IO ()
37 |
38 | make :: String -> IO Element
39 | make = _make . toJS
40 |
41 | foreign import js "%1.make(%*)"
42 | _make :: JSString -> IO Element
43 |
44 | make' :: String -> JSObject_ a -> IO Element
45 | make' s o = _make' (toJS s) o
46 |
47 | foreign import js "%1.make(%*)"
48 | _make' :: JSString -> JSObject_ a -> IO Element
49 |
50 | make'' :: String -> JSObject_ a -> String -> IO Element
51 | make'' s1 o s2 = _make'' (toJS s1) o (toJS s2)
52 |
53 | foreign import js "%1.make(%*)"
54 | _make'' :: JSString -> JSObject_ a -> JSString -> IO Element
55 |
56 | foreign import js "delegateEvents(%*)"
57 | delegateEvents :: JSObject_ a -> IO ()
58 |
--------------------------------------------------------------------------------
/thesis-snippets/OO/InheritanceWithOverrideAndSuperRef.hs:
--------------------------------------------------------------------------------
1 | module InheritanceWithOverrideAndSuperRef where
2 | import Data.IORef
3 | import Control.Monad.Fix (mfix)
4 | import Prelude hiding ( print )
5 |
6 | o # f = f o
7 |
8 | nilRecord = ()
9 |
10 | emptyRecord = return $ const nilRecord
11 |
12 | new :: (IO (a -> ()) -> a -> IO a) -> IO a
13 | new oo = mfix $ oo emptyRecord
14 |
15 | data PrintablePointClass a = PrintablePointClass {
16 | varX :: IORef Int
17 | ,getX :: IO Int
18 | ,moveX :: Int -> IO ()
19 | ,print :: IO ()
20 | ,printablePointTail :: a
21 | }
22 |
23 | printable_point x_init cons self = do
24 | x <- newIORef x_init
25 | tail <- cons
26 | return PrintablePointClass {
27 | varX = x
28 | ,getX = readIORef x
29 | ,moveX = \d -> modifyIORef x ((+) d)
30 | ,print = (self # getX) >>= putStr . show
31 | ,printablePointTail = tail self
32 | }
33 |
34 | data ColoredPointClass a = ColoredPointClass {
35 | getColor :: IO String
36 | ,coloredPointTail :: a
37 | }
38 |
39 | colored_point' x color cons self = do
40 | super <- printable_point x emptyRecord self
41 | wrapper <- colored_point' super
42 | return super {
43 | print = do putStr "so far - "; super # print
44 | putStr "color - "; putStr (show color)
45 | ,printablePointTail = wrapper self
46 | }
47 |
48 | where
49 |
50 | colored_point' super = do
51 | tail <- cons
52 | return $ \self -> ColoredPointClass {
53 | getColor = do x <- super # getX
54 | putStrLn ("Retrieving color at position: " ++ show x)
55 | return color
56 | ,coloredPointTail = tail self
57 | }
58 |
59 | getColor' = getColor . printablePointTail
60 |
61 | myOverridingOOP = do
62 | p <- new $ colored_point' 3 "red"
63 | p # getColor'
64 | p # print
65 |
66 |
--------------------------------------------------------------------------------
/wxasteroids/src/Graphics/UI/WX.hs:
--------------------------------------------------------------------------------
1 | --------------------------------------------------------------------------------
2 | {-| Module : WX
3 | Copyright : (c) Daan Leijen 2003
4 | License : wxWindows
5 |
6 | Maintainer : wxhaskell-devel@lists.sourceforge.net
7 | Stability : provisional
8 | Portability : portable
9 |
10 | The WX module just re-exports functionality from helper modules and
11 | defines the 'start' function.
12 |
13 | The WX library provides a /haskellized/ interface to the raw wxWindows
14 | functionality provided by the "Graphics.UI.WXCore" library.
15 | -}
16 | --------------------------------------------------------------------------------
17 | module Graphics.UI.WX
18 | ( -- * Functions
19 | start
20 | -- * Modules
21 | , module Graphics.UI.WX.Types
22 | , module Graphics.UI.WX.Attributes
23 | , module Graphics.UI.WX.Classes
24 | , module Graphics.UI.WX.Variable
25 | --, module Graphics.UI.WX.Layout
26 | , module Graphics.UI.WX.Events
27 |
28 | , module Graphics.UI.WX.Window
29 | --, module Graphics.UI.WX.Frame
30 | , module Graphics.UI.WX.Timer
31 | , module Graphics.UI.WX.Media
32 | --, module Graphics.UI.WX.Menu
33 | --, module Graphics.UI.WX.Controls
34 | --, module Graphics.UI.WX.Dialogs
35 | , module Graphics.UI.WX.Draw
36 | ) where
37 |
38 | import Graphics.UI.WX.Types hiding (size)
39 | import Graphics.UI.WX.Attributes
40 | import Graphics.UI.WX.Classes
41 | import Graphics.UI.WX.Variable
42 | --import Graphics.UI.WX.Layout
43 | import Graphics.UI.WX.Events
44 |
45 | import Graphics.UI.WX.Window
46 | --import Graphics.UI.WX.Frame
47 | import Graphics.UI.WX.Timer
48 | import Graphics.UI.WX.Media
49 | --import Graphics.UI.WX.Menu
50 |
51 | --import Graphics.UI.WX.Controls
52 | --import Graphics.UI.WX.Dialogs
53 | import Graphics.UI.WX.Draw
54 |
55 | import Graphics.UI.WXCore (unitIO,run)
56 |
57 | -- | 'start' runs the GUI.
58 | start :: IO a -> IO ()
59 | start io
60 | = run (unitIO io)
--------------------------------------------------------------------------------
/thesis-snippets/JS/JSFFITestSuite.hs:
--------------------------------------------------------------------------------
1 | module JSFFITestSuite where
2 |
3 | import Foreign.Ptr
4 |
5 | -- selecting
6 | foreign import js "window"
7 | window :: IO ()
8 |
9 | foreign import js "window.alert"
10 | windowAlert :: IO ()
11 |
12 | foreign import js "window.%1.style"
13 | style :: a -> IO ()
14 |
15 | foreign import js "%1.%2.style"
16 | style1 :: a -> b -> IO ()
17 |
18 | foreign import js "abc12343.boe"
19 | testIdent :: IO ()
20 |
21 | -- calling
22 | foreign import js "alert()"
23 | alert :: IO ()
24 |
25 | foreign import js "foo(%*)"
26 | callFoo :: a -> b -> IO ()
27 |
28 | -- selecting and calling
29 | foreign import js "window.alert()"
30 | alert1 :: IO ()
31 |
32 | foreign import js "%1.alert(%*)"
33 | alert2 :: a -> b -> IO ()
34 |
35 | foreign import js "{}"
36 | obj :: IO ()
37 |
38 | foreign import js "'Hello World!'"
39 | helloWorld :: IO a
40 |
41 | foreign import js "window.alert(%1)"
42 | doAlert :: a -> IO ()
43 |
44 | main' = helloWorld >>= doAlert
45 | main = return "Hello World!" >>= doAlert
46 |
47 | -- new
48 | foreign import js "new Foo()"
49 | fooObj :: IO ()
50 |
51 | foreign import js "new Foo(%*)"
52 | fooObj1 :: a -> b -> IO ()
53 |
54 | foreign import js "new %1.Foo"
55 | fooObj2 :: a -> IO ()
56 |
57 | foreign import js "new %1.%2.Foo(%*)"
58 | fooObj3 :: a -> b -> c -> IO ()
59 |
60 | -- indexing
61 | foreign import js "%1['style']"
62 | styleIndex :: a -> IO ()
63 |
64 | foreign import js "%1['style']['color']"
65 | styleIndex1 :: a -> IO ()
66 |
67 | foreign import js "new %1['style']['color']"
68 | newColor :: a -> IO ()
69 |
70 | foreign import js "[]"
71 | emptyArr :: IO ()
72 |
73 | -- I imagine that this should also be valid...
74 | {-
75 | foreign import js "%1[0]"
76 | zeroIndex :: a -> IO ()
77 | -}
78 |
79 | -- exports
80 |
81 | -- does not work
82 | foreign export js "f"
83 | f :: Int -> Int
84 |
85 | f x = x * x
86 |
87 | foreign import js "dynamic"
88 | mkSumFun :: FunPtr (Int -> Int) -> (Int -> Int)
89 |
90 | foreign import js "wrapper"
91 | mkIntCb :: (Int -> IO ()) -> IO (FunPtr (Int -> IO ()))
92 |
93 |
94 |
--------------------------------------------------------------------------------
/uhc-js/uhc-js/uhc-js.cabal:
--------------------------------------------------------------------------------
1 | -- uhc-js.cabal auto-generated by cabal init. For additional
2 | -- options, see
3 | -- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr.
4 | -- The name of the package.
5 | Name: uhc-js
6 |
7 | -- The package version. See the Haskell package versioning policy
8 | -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for
9 | -- standards guiding when and how versions should be incremented.
10 | Version: 0.2
11 |
12 | -- A short (one-line) description of the package.
13 | Synopsis: JavaScript library for the UHC JS backend
14 |
15 | -- A longer description of the package.
16 | -- Description:
17 |
18 | -- URL for the project homepage or repository.
19 | Homepage: https://github.com/UU-ComputerScience/uhc-js
20 |
21 | -- The license under which the package is released.
22 | License: BSD3
23 |
24 | -- The file containing the license text.
25 | License-file: LICENSE
26 |
27 | -- The package author(s).
28 | Author: Jurriën Stutterheim, Alessandro Vermeulen
29 |
30 | -- An email address to which users can send suggestions, bug reports,
31 | -- and patches.
32 | Maintainer: j.stutterheim@uu.nl, a.vermeulen@uu.nl
33 |
34 | -- A copyright notice.
35 | -- Copyright:
36 |
37 | Category: Language
38 |
39 | Build-type: Simple
40 |
41 | -- Extra files to be distributed with the package, such as examples or
42 | -- a README.
43 | -- Extra-source-files:
44 |
45 | -- Constraint on the version of Cabal needed to build this package.
46 | Cabal-version: >=1.2
47 |
48 |
49 | Executable test-js
50 | Hs-Source-Dirs: src
51 | Build-depends: base >= 3.0
52 | Main-Is: Main.hs
53 | Library
54 | -- Modules exported by the library.
55 | Exposed-modules: Language.UHC.JS.Primitives, Language.UHC.JS.Prelude
56 | Hs-Source-Dirs: src
57 | -- Packages needed in order to build this package.
58 | Build-depends: base >= 3.0
59 |
60 | -- Modules not exported by this package.
61 | -- Other-modules:
62 |
63 | -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.
64 | -- Build-tools:
65 |
--------------------------------------------------------------------------------
/uhc-js/uhc-js/src/Language/UHC/JS/HTML5/Types.hs:
--------------------------------------------------------------------------------
1 | module Language.UHC.JS.HTML5.Types where
2 |
3 | import Language.UHC.JS.Types
4 | import Language.UHC.JS.Prelude
5 |
6 | data CNode a
7 | type Node_ a = JSObject_ (CNode a)
8 | type Node = Node_ ()
9 |
10 | data Element_ a
11 | type Element a = Node_ (Element_ a)
12 |
13 | data CHTMLDocument
14 | type HTMLDocument = JSObject_ CHTMLDocument
15 |
16 | data Event_ a
17 | type Event = JSObject_ (Event_ ())
18 |
19 | instance GetObjectRef HTMLElement where
20 | getObjectRef _ = _htmlElementRef
21 |
22 | foreign import js "HTMLElement"
23 | _htmlElementRef :: b
24 |
25 | data CHTMLElement a
26 | type HTMLElement_ a = Element (CHTMLElement a)
27 | type HTMLElement = HTMLElement_ ()
28 |
29 | data HTMLImageElement_
30 | type HTMLImageElement = HTMLElement_ HTMLImageElement_
31 |
32 | data HTMLCanvasElement_
33 | type HTMLCanvasElement = HTMLElement_ HTMLCanvasElement_
34 |
35 | instance GetObjectRef HTMLCanvasElement where
36 | getObjectRef _ = _htmlCanvasElementRef
37 |
38 | foreign import js "HTMLCanvasElement"
39 | _htmlCanvasElementRef :: b
40 |
41 | data AnchorPtr
42 | type Anchor = JSObject_ AnchorPtr
43 |
44 | data FormPtr
45 | type Form = JSObject_ FormPtr
46 |
47 | data ImagePtr
48 | type Image = JSObject_ ImagePtr
49 |
50 | data LinkPtr
51 | type Link = JSObject_ LinkPtr
52 |
53 | data CSSStyleDeclaration_
54 | type CSSStyleDeclaration = JSObject_ CSSStyleDeclaration_
55 |
56 | type CSSRule = JSObject
57 | type CSSValue = JSObject
58 |
59 | data HTMLCollection_
60 | type HTMLCollection = JSObject_ HTMLCollection_
61 |
62 | data NodeList_
63 | type NodeList = JSObject_ NodeList_
64 |
65 | data AttrPtr
66 | type Attr = JSObject_ AttrPtr
67 |
68 | data TextPtr
69 | type Text = JSObject_ TextPtr
70 |
71 | data Window_
72 | type Window = JSObject_ Window_
73 |
74 | instance GetObjectRef CanvasRenderingContext2D where
75 | getObjectRef _ = _canvasRenderingContext2D
76 |
77 | foreign import js "CanvasRenderingContext2D"
78 | _canvasRenderingContext2D :: b
79 |
80 | data CanvasRenderingContext2D_
81 | type CanvasRenderingContext2D = JSObject_ CanvasRenderingContext2D_
82 |
83 | data NamedNodeMap_
84 | type NamedNodeMap = JSObject_ NamedNodeMap_
--------------------------------------------------------------------------------
/msc-thesis/chapters/conclusion.lhs:
--------------------------------------------------------------------------------
1 | \chapter{Conclusion, Contributions \& Future Work}
2 | \label{chap:conclusion}
3 |
4 | Research question: \emph{how can we make wxHaskell run in the web browser?}
5 |
6 | To answer the research question we have explored the different paths that could potentially lead to a proof of concept implementation of wxHaskell for the web. Of these paths we picked the least obvious and most challenging one, developed the necessary tools, and applied them to successfully port a feature-light version of \emph{wxAsteroids} which is \emph{near to} interchangeable with the desktop version\footnote{\url{https://github.com/rubendg/wxasteroids}}. To the best of our knowledge we are also the first to actually implement a real-world OO design in Haskell.
7 |
8 | Besides the implementation of a subset of wxHaskell we contribute two independently useful libraries: an extended \js programming prelude\footnote{\url{https://github.com/UU-ComputerScience/uhc-js}}, and a light-weight approach for OO programming in Haskell inspired by OOHaskell which only requires Haskell 98 plus some lifting of type class restrictions\footnote{\url{https://github.com/rubendg/lightoo}}. Almost all code snippets in this thesis can be found at \footnote{\url{https://github.com/rubendg/thesis-snippets}}.
9 |
10 | From the discussions and conclusions of chapter 4, 5, and 6 it should be clear that in order for the wxWidgets implementation in Haskell to be of any real use there is still lots of work to be done. Also, some inherent limitations of the Haskell language such as the lack of first-class language support for extensible records and mutually recursive modules makes OO programming in Haskell feel a bit like a hack. It would be interesting to see if there exists a translation from feather-weight Java to our OO library as it would open up the possibility of creating a small language extension to hide the crufty details, and may even be able to work around the lack of an uniform treatment of subtyping in our encoding by inserting explicit casts at the required places. For all practical purposes, if the \js FFI keeps on improving, design option B remains the most practical approach to implement a fully fledged port of wxHaskell for the web.
11 |
--------------------------------------------------------------------------------
/wxasteroids/src/Graphics/UI/WX/Types.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE ScopedTypeVariables #-}
2 | --------------------------------------------------------------------------------
3 | {-| Module : Types
4 | Copyright : (c) Daan Leijen 2003
5 | License : wxWindows
6 |
7 | Maintainer : wxhaskell-devel@lists.sourceforge.net
8 | Stability : provisional
9 | Portability : portable
10 |
11 | Basic types.
12 | -}
13 | --------------------------------------------------------------------------------
14 | module Graphics.UI.WX.Types (
15 | module Graphics.UI.WXCore.Types
16 | ,module Graphics.UI.WX.Types
17 | ) where
18 |
19 | import Graphics.UI.WXCore.Types
20 | --import Graphics.UI.WXCore.Draw
21 | import Graphics.UI.WXCore.Event
22 |
23 | -- | Inverse application, i.e. @feed x f@ = @f x@.
24 | feed :: a -> (a -> b) -> b
25 | feed x f
26 | = f x
27 |
28 | -- | Composed Inverse application, i.e. @feed2 x y f@ = @f x y@.
29 | feed2 :: a -> b -> (a -> b -> c) -> c
30 | feed2 x y f
31 | = f x y
32 |
33 | -- | Data types that can be represented through a bit mask. Only the @assocBitMask@ method
34 | -- is required for a new instance.
35 | class Eq b => BitMask b where
36 | -- | Give the association between the constructors and the bits. If a constructor
37 | -- corresponds to no bits set, it should come as the last element.
38 | assocBitMask :: [(b,Int)]
39 |
40 | -- | Convert to a bitmask
41 | toBitMask :: b -> Int
42 | -- | Convert from a bitmask
43 | fromBitMask :: Int -> b
44 | -- | Set the correct bits corresponding to a constructor in a mask.
45 | setBitMask :: b -> Int -> Int
46 |
47 | toBitMask x
48 | = case lookup x assocBitMask of
49 | Just m -> m
50 | Nothing -> 0
51 |
52 | fromBitMask i
53 | = walk assocBitMask
54 | where
55 | walk [] = error "Graphics.UI.WX.Types.fromBitMask: empty list"
56 | walk [(x,0)] = x
57 | walk ((x,m):xs) | bitsSet m i = x
58 | | otherwise = walk xs
59 |
60 | setBitMask x i
61 | = i .-. (bits (map snd (assocBitMask::[(b,Int)]))) .+. toBitMask x
62 |
63 |
64 | -- | Create a bitmask from a list of types.
65 | mask :: BitMask b => [b] -> Int
66 | mask xs
67 | = foldr (.+.) 0 (map toBitMask xs)
--------------------------------------------------------------------------------
/wxasteroids/src/Graphics/UI/WXCore.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE CPP #-}
2 | {-# OPTIONS -pgmP cpp #-}
3 | module Graphics.UI.WXCore (
4 | #ifdef __UHC__
5 | module Graphics.UI.WXCore.WebWindow
6 | #else
7 | module Graphics.UI.WXCore.Window
8 | #endif
9 |
10 | ,module Graphics.UI.WXCore.Types
11 | ,module Graphics.UI.WXCore.GraphicsRenderer
12 | ,module Graphics.UI.WXCore.GraphicsContext
13 | ,module Graphics.UI.WXCore.GraphicsObject
14 | ,module Graphics.UI.WXCore.GraphicsBitmap
15 |
16 | ,module Graphics.UI.WXCore.EvtHandler
17 |
18 | ,module Graphics.UI.WXCore.Event
19 | ,module Graphics.UI.WXCore.Events
20 |
21 | ,module Graphics.UI.WXCore.Timer
22 |
23 | --,module Graphics.UI.WXCore.TopLevelWindow
24 | --,module Graphics.UI.WXCore.Frame
25 | ,run
26 | ) where
27 |
28 | #ifdef __UHC__
29 | import Graphics.UI.WXCore.WebWindow
30 | import qualified Language.UHC.JS.HTML5.Window as W
31 | import Language.UHC.JS.Prelude
32 | #else
33 | import Graphics.UI.WXCore.Window
34 | #endif
35 |
36 | import Graphics.UI.WXCore.GraphicsRenderer
37 | import Graphics.UI.WXCore.GraphicsContext
38 | import Graphics.UI.WXCore.GraphicsObject
39 | import Graphics.UI.WXCore.GraphicsBitmap
40 | import Graphics.UI.WXCore.Types
41 |
42 | import Graphics.UI.WXCore.EvtHandler
43 |
44 | import Graphics.UI.WXCore.Event
45 | import Graphics.UI.WXCore.Events
46 |
47 | import Graphics.UI.WXCore.Timer hiding (timer)
48 |
49 | --import Graphics.UI.WXCore.TopLevelWindow
50 | --import Graphics.UI.WXCore.Frame hiding (frame)
51 |
52 | {-
53 | -- | Start the event loop. Takes an initialisation action as argument.
54 | -- Except for 'run', the functions in the WXH library can only be called
55 | -- from this intialisation action or from event handlers, or otherwise bad
56 | -- things will happen :-)
57 | run :: IO a -> IO ()
58 | run init
59 | = do appOnInit (do wxcAppInitAllImageHandlers
60 | init
61 | return ())
62 | performGC
63 | performGC
64 | -}
65 | run :: IO a -> IO ()
66 | run init = do
67 | appOnInit (do init; return ())
68 |
69 | #ifdef __UHC__
70 | appOnInit f = do
71 | w <- W.window
72 | cb <- wrapFunc f
73 | setAttr_ "onload" cb w
74 | return ()
75 | #else
76 | appOnInit = undefined
77 | #endif
--------------------------------------------------------------------------------
/uhc-js/uhc-js/src/Language/UHC/JS/Prelude.hs:
--------------------------------------------------------------------------------
1 | module Language.UHC.JS.Prelude where
2 |
3 | import Language.UHC.JS.Types
4 | import Language.UHC.JS.Marshal
5 | import Language.UHC.JS.Primitives
6 | import Language.UHC.JS.ECMA.String
7 |
8 | class GetObjectRef a where
9 | getObjectRef :: a -> b
10 |
11 | cast :: GetObjectRef b => a -> Maybe b
12 | cast a :: Maybe b =
13 | if _primInstanceOf a (getObjectRef (undefined :: b))
14 | then Just (unsafeCoerce a)
15 | else Nothing
16 |
17 | foreign import js "wrapper"
18 | wrapFunc :: IO a -> IO (JSFunction_ (IO a))
19 |
20 | foreign import js "wrapper"
21 | wrapFunc1 :: (a -> IO b) -> IO (JSFunction_ (a -> IO b))
22 |
23 | foreign import js "dynamic"
24 | unwrapFunc :: JSFunction_ (IO a) -> IO (IO a)
25 |
26 | foreign import js "dynamic"
27 | unwrapFunc1 :: JSFunction_ (a -> IO b) -> IO (a -> IO b)
28 |
29 | newObj :: String -> IO JSObject
30 | newObj = _primNewObj . toJS
31 |
32 | mkCtor :: String -> IO (JSFunction_ a)
33 | mkCtor = _primMkCtor . toJS
34 |
35 | getCtor :: String -> IO (JSFunction_ a)
36 | getCtor s1 = _primGetCtor (toJS s1)
37 |
38 | setCtor :: String -> JSFunction_ a -> IO ()
39 | setCtor s1 fp = _primSetCtor (toJS s1) fp
40 |
41 | getAttr :: String -> JSObject_ p -> IO a
42 | getAttr s p = _primGetAttr (toJS s) p
43 |
44 | setAttr :: String -> a -> JSObject_ p -> IO (JSObject_ p)
45 | setAttr s a p = _primSetAttr (toJS s) a p
46 |
47 | setAttr_ :: String -> a -> JSObject_ p -> IO ()
48 | setAttr_ s a p = setAttr s a p >> return ()
49 |
50 | pureSetAttr :: String -> a -> JSObject_ p -> JSObject_ p
51 | pureSetAttr s a p = _primPureSetAttr (toJS s) a p
52 |
53 | modAttr :: String -> (a -> b) -> JSObject_ p -> IO (JSObject_ p)
54 | modAttr s f p = _primModAttr (toJS s) f p
55 |
56 | pureModAttr :: String -> (a -> b) -> JSObject_ p -> JSObject_ p
57 | pureModAttr s f p = _primPureModAttr (toJS s) f p
58 |
59 | getProtoAttr :: String -> String -> IO a
60 | getProtoAttr x y = _primGetProtoAttr (toJS x) (toJS y)
61 |
62 | setProtoAttr :: String -> a -> String -> IO ()
63 | setProtoAttr x a y = _primSetProtoAttr (toJS x) a (toJS y)
64 |
65 | modProtoAttr :: String -> (a -> b) -> String -> IO ()
66 | modProtoAttr x f y = _primModProtoAttr (toJS x) f (toJS y)
67 |
68 | foreign import js "{}"
69 | mkObj :: a -> IO (JSObject_ b)
70 |
71 | foreign import js "console.log(%*)"
72 | _trace :: a -> IO ()
73 |
--------------------------------------------------------------------------------
/thesis-snippets/OO/FirstClassClasses.hs:
--------------------------------------------------------------------------------
1 | module FirstClassClasses where
2 | import Data.IORef
3 | import Control.Monad.Fix (mfix)
4 | import Prelude hiding (print)
5 |
6 | o # f = f o
7 |
8 | nilRecord = ()
9 |
10 | emptyRecord = return $ const nilRecord
11 |
12 | new :: (IO (a -> ()) -> a -> IO a) -> IO a
13 | new oo = mfix $ oo emptyRecord
14 |
15 | inherit ::
16 | (cons -> super -> IO (self -> w)) -- w
17 | -> (IO (x -> ()) -> self -> IO super) -- g
18 | -> (super -> IO (self -> g)) -- override
19 | -> (g -> w -> b) -- oplus
20 | -> cons -- cons
21 | -> self -- self
22 | -> IO b
23 | inherit w g override oplus = \cons self -> do
24 | super <- g emptyRecord self
25 | wrapper <- w cons super
26 | super' <- override super
27 | return $ (super' self) `oplus` (wrapper self)
28 |
29 | data PrintablePointClass a = PrintablePointClass {
30 | varX :: IORef Int
31 | ,getX :: IO Int
32 | ,moveX :: Int -> IO ()
33 | ,print :: IO ()
34 | ,printablePointTail :: a
35 | }
36 |
37 | printable_point x_init cons self = do
38 | x <- newIORef x_init
39 | tail <- cons
40 | return PrintablePointClass {
41 | varX = x
42 | ,getX = readIORef x
43 | ,moveX = \d -> modifyIORef x ((+) d)
44 | ,print = (self # getX) >>= putStr . show
45 | ,printablePointTail = tail self
46 | }
47 |
48 | data ColoredPointClass a = ColoredPointClass {
49 | getColor :: IO String
50 | ,coloredPointTail :: a
51 | }
52 |
53 | colored_point' x color =
54 | inherit wrapper (printable_point x) override (\o v -> o { printablePointTail = v })
55 |
56 | where
57 |
58 | override super = return $ \self -> super {
59 | print = do putStr "so far - "; super # print
60 | putStr "color - "; putStr (show color)
61 | }
62 |
63 | wrapper cons super = do
64 | tail <- cons
65 | return $ \self -> ColoredPointClass {
66 | getColor = do x <- super # getX
67 | putStrLn ("Retrieving color at position: " ++ show x)
68 | return color
69 | ,coloredPointTail = tail self
70 | }
71 |
72 | getColor' = getColor . printablePointTail
73 |
74 | myFirstClassOOP point_class = do
75 | p <- new $ point_class 7
76 | p # moveX $ 35
77 | p # print
78 |
--------------------------------------------------------------------------------
/uhc-js/tests/works/lenses/lenses.hs:
--------------------------------------------------------------------------------
1 | data JSPtr a
2 | type JSString = PackedString
3 |
4 | data BookPtr
5 |
6 | type AnonObj = JSPtr ()
7 | type Book = JSPtr BookPtr
8 |
9 |
10 | pages :: JSString
11 | pages = s2js "pages"
12 |
13 | num :: JSString
14 | num = s2js "num"
15 |
16 |
17 | -- TODO: Do we need a mkProto as well?
18 | mkBook :: IO Book
19 | mkBook = mkObj $ s2js "Book"
20 |
21 | getPages :: Book -> IO Int
22 | getPages = getAttr pages
23 |
24 | setPages :: Int -> Book -> IO Book
25 | setPages = setAttr pages
26 |
27 | modPages :: (Int -> Int) -> Book -> IO Book
28 | modPages = modAttr pages
29 |
30 |
31 | isAwesome :: Book -> IO Bool
32 | isAwesome = getAttr $ s2js "isAwesome"
33 |
34 |
35 | mkAnon :: IO AnonObj
36 | mkAnon = mkAnonObj
37 |
38 | getNum :: AnonObj -> IO Int
39 | getNum = getAttr num
40 |
41 | setNum :: Int -> AnonObj -> IO AnonObj
42 | setNum = setAttr num
43 |
44 | modNum :: (Int -> Int) -> AnonObj -> IO AnonObj
45 | modNum = modAttr num
46 |
47 |
48 | -- TODO: How do we deal with setting functions to be attributes on the objects?
49 |
50 | main :: IO ()
51 | main = do
52 | b <- mkBook
53 | _ <- setPages 1 b
54 | a <- getPages b
55 | b' <- modPages (+1) b
56 | c <- getPages b'
57 | putStrLn $ "Book pages before: " ++ show a
58 | putStrLn "
"
59 | putStrLn $ "Book pages after: " ++ show c
60 | putStrLn "
"
61 | anon <- mkAnon
62 | _ <- setNum 13 anon
63 | pgs' <- getNum anon
64 | ano' <- modNum (*2) anon
65 | pgs <- getNum ano'
66 | putStrLn $ "Anon num before: " ++ show pgs'
67 | putStrLn "
"
68 | putStrLn $ "Anon num after: " ++ show pgs
69 |
70 | foreign import prim "primMkAnonObj"
71 | mkAnonObj :: IO AnonObj
72 |
73 | foreign import prim "primMkObj"
74 | mkObj :: JSString -> IO (JSPtr p)
75 |
76 | foreign import prim "primGetAttr"
77 | getAttr :: JSString -> JSPtr p -> IO a
78 |
79 | foreign import prim "primSetAttr"
80 | setAttr :: JSString -> a -> JSPtr p -> IO (JSPtr p)
81 |
82 | foreign import prim "primModAttr"
83 | modAttr :: JSString -> (a -> b) -> JSPtr p -> IO (JSPtr p)
84 |
85 |
86 | foreign import prim "primGetProtoAttr"
87 | getProtoAttr :: JSString -> JSString -> IO a
88 |
89 | foreign import prim "primSetProtoAttr"
90 | setProtoAttr :: JSString -> a -> JSString -> IO ()
91 |
92 | foreign import prim "primModProtoAttr"
93 | modProtoAttr :: JSString -> (a -> b) -> JSString -> IO ()
94 |
95 |
96 | foreign import prim "primStringToPackedString"
97 | s2js :: String -> JSString
98 |
--------------------------------------------------------------------------------
/uhc-js/tests/works/js_oo/js_oo.hs:
--------------------------------------------------------------------------------
1 | main :: IO ()
2 | main = do
3 | putStrLn "JSOO
"
4 | let pl = plainDull 10 20
5 | putStrLn $ show objFish
6 | putStrLn $ ppBook objBook objBook
7 |
8 | data Book = Book {
9 | title :: String
10 | , author :: String
11 | , ppBook :: Book -> String
12 | }
13 |
14 | objBook = Book {
15 | title = "defaultTitle"
16 | , author = "defaultAuthor"
17 | , ppBook = ppBook'
18 | }
19 |
20 | ppBook' :: Book -> String
21 | ppBook' (Book t a _) = t ++ " by " ++ a
22 |
23 | data NoConstrTy
24 |
25 | plainDull, plainDull2 :: Int -> Int -> Int
26 | plainDull x y = y + x
27 | plainDull2 x y = y + x
28 |
29 | secondMain :: IO ()
30 | secondMain = putStrLn "secondMain"
31 |
32 | foreign export jscript "plainDull" plainDull :: Int -> Int -> Int
33 | foreign export jscript "plainDull2" plainDull2 :: Int -> Int -> Int
34 | foreign export jscript "secondMain" secondMain :: IO ()
35 |
36 | data Fish = Fish {
37 | species :: String
38 | , gils :: Bool
39 | }
40 | | Fush Int Int Int Int Int
41 | deriving Show
42 |
43 | objFish = Fish {
44 | species = "shark"
45 | , gils = True
46 | }
47 |
48 | foreign export jscript "Fish" objFish :: Fish
49 | {- foreign export jscript "Book" objBook :: Book-}
50 |
51 |
52 |
53 | -- TODO: it doesn't like the fact that ppBook is a function...
54 | -- foreign export jscript "%proto[Book]" objBook :: Book
55 | -- foreign export jscript "%obj[Book]" objBook :: Book
56 |
57 |
58 | {-
59 |
60 | The above should generate something along the lines of
61 |
62 | function Book() {
63 | }
64 |
65 | Book.prototype.title = "defaultTitle"
66 | Book.prototype.title = "defaultAuthor"
67 | Book.prototype.ppBook = function(b) {
68 | return (b.title + " by " + b.author);
69 | }
70 |
71 | -}
72 |
73 |
74 | -- foreign export jscript "%obj[myBook]" objBook :: Book
75 |
76 | {-
77 |
78 | Similar to the above, this should generate something along the lines of
79 |
80 | myBook = {
81 | title : "defaultTitle",
82 | author : "defaultAuthor",
83 | ppBook : function(b) {
84 | return (b.title + " by " + b.author);
85 | }
86 | }
87 |
88 |
89 | Especially this last setup would allow for friendly interaction with frameworks
90 | like Backbone:
91 |
92 | data BBBook
93 |
94 | foreign import jscript "Backbone.Model.extend(%1)" :: Book -> IO BBBook
95 |
96 |
97 | This would require the obj to be exported as well, though.
98 |
99 | -}
100 |
--------------------------------------------------------------------------------
/thesis-snippets/OO/InheritanceWithComb.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE MultiParamTypeClasses #-}
2 | module InheritanceWithComb where
3 | import Data.IORef
4 | import Control.Monad.Fix (mfix)
5 | import Prelude hiding ( print )
6 |
7 | o # f = f o
8 |
9 | nilRecord = ()
10 |
11 | emptyRecord = return $ const nilRecord
12 |
13 | new :: (IO (a -> ()) -> a -> IO a) -> IO a
14 | new oo = mfix $ oo emptyRecord
15 |
16 | inherit ::
17 | (cons -> super -> IO (self -> w))
18 | -> (IO (a -> ()) -> self -> IO super)
19 | -> (super -> IO (self -> super'))
20 | -> (super' -> w -> b)
21 | -> cons
22 | -> self
23 | -> IO b
24 | inherit w g override oplus = \cons self -> do
25 | super <- g emptyRecord self
26 | wrapper <- w cons super
27 | super' <- override super
28 | return $ (super' self) `oplus` (wrapper self)
29 |
30 | b `extends` a = inherit b a
31 |
32 | data PrintablePointClass a = PrintablePointClass {
33 | varX :: IORef Int
34 | ,getX :: IO Int
35 | ,moveX :: Int -> IO ()
36 | ,print :: IO ()
37 | ,printablePointTail :: a
38 | }
39 |
40 | printable_point x_init cons self = do
41 | x <- newIORef x_init
42 | tail <- cons
43 | return PrintablePointClass {
44 | varX = x
45 | ,getX = readIORef x
46 | ,moveX = \d -> modifyIORef x ((+) d)
47 | ,print = (self # getX) >>= putStr . show
48 | ,printablePointTail = tail self
49 | }
50 |
51 | data ColoredPointClass a = ColoredPointClass {
52 | getColor :: IO String
53 | ,coloredPointTail :: a
54 | }
55 |
56 | colored_point x color =
57 | (wrapper `extends` printable_point x) override (\o v -> o { printablePointTail = v })
58 |
59 | where
60 |
61 | override super = return $ \self -> super {
62 | print = do putStr "so far - "; super # print
63 | putStr "color - "; putStr (show color)
64 | }
65 |
66 | wrapper cons super = do
67 | tail <- cons
68 | return $ \self -> ColoredPointClass {
69 | getColor = do x <- super # getX
70 | putStrLn ("Retrieving color at position: " ++ show x)
71 | return color
72 | ,coloredPointTail = tail self
73 | }
74 |
75 | getColor' = getColor . printablePointTail
76 |
77 | colored_point' x_init color cons self = do
78 | super <- colored_point x_init color cons self
79 | return $ super {
80 | print = putStr "I'm a colored point"
81 | }
82 |
83 | myOverridingOOP = do
84 | p <- new $ colored_point 3 "red"
85 | p # getColor'
86 | p # print
87 |
88 |
--------------------------------------------------------------------------------
/wxasteroids/src/Graphics/UI/WXCore/TimerClass.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE CPP, StandaloneDeriving, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable #-}
2 | {-# OPTIONS -pgmP cpp #-}
3 | module Graphics.UI.WXCore.TimerClass where
4 |
5 | import LightOO
6 | import Data.Typeable
7 | import Graphics.UI.WXCore.Types
8 | import Graphics.UI.WXCore.EvtHandlerClass
9 | import Graphics.UI.WXCore.EventClass
10 |
11 | #ifdef __UHC__
12 | #include "Typeable.h"
13 | #include "LightOOUHC.h"
14 | #else
15 | #include "LightOO.h"
16 | #endif
17 |
18 | data TimerEventClass a = TimerEventClass {
19 | _timerEventGetInterval :: IO Int
20 | ,_timerEventGetTimer :: IO Timer
21 | ,_timerEventTail :: Record a
22 | }
23 | DefineSubClass(TimerEvent,Event,TimerEventClass,timerEventTail,,,,1,)
24 |
25 | #ifdef __UHC__
26 | INSTANCE_TYPEABLE1(TimerEventClass,timerEventTc,"TimerEvent")
27 | #endif
28 |
29 | timerEvent_Methods = unRecord . get_Event_Tail
30 | timerEventGetInterval = _timerEventGetInterval . timerEvent_Methods
31 | timerEventGetTimer = _timerEventGetTimer . timerEvent_Methods
32 |
33 | data TimerClass a = TimerClass {
34 | _timerGetId :: IO Int
35 | ,_timerGetInterval :: IO Int
36 | ,_timerGetOwner :: IO EvtHandler
37 | ,_timerIsOneShot :: IO Bool
38 | ,_timerIsRunning :: IO Bool
39 | ,_timerSetOwner :: EvtHandler -> Id -> IO ()
40 | ,_timerStart :: Int -> Bool -> IO Bool
41 | ,_timerStop :: IO ()
42 | ,_timerTail :: Record a
43 | }
44 | DefineSubClass(Timer,EvtHandler,TimerClass,timerTail,,,,1,)
45 |
46 | #ifdef __UHC__
47 | INSTANCE_TYPEABLE1(TimerClass,timerTc,"Timer")
48 | #endif
49 |
50 | timer_Methods = unRecord . get_EvtHandler_Tail
51 |
52 | timerIsRunning = _timerIsRunning . timer_Methods
53 | timerStop = _timerStop . timer_Methods
54 | timerIsOneShot = _timerIsOneShot . timer_Methods
55 | timerStart = _timerStart . timer_Methods
56 | timerGetOwner = _timerGetOwner . timer_Methods
57 | timerGetInterval = _timerGetInterval . timer_Methods
58 |
59 | -- static methods
60 |
61 | -- TODO: not really sure what this is for..?
62 | timerGetOnCommand :: Timer_ a -> IO (IO ())
63 | timerGetOnCommand t = do
64 | owner <- t # timerGetOwner
65 | cb <- do { cd <- (owner # evtHandlerGetHandler) wxEVT_TIMER idAny idAny
66 | ; return $ maybe (const $ return ()) id cd
67 | }
68 | return $ cb (error "touched: event object")
69 |
70 | timerOnCommand :: Timer_ a -> IO () -> IO ()
71 | timerOnCommand t f = do
72 | owner <- t # timerGetOwner
73 | (owner # evtHandlerBind) wxEVT_TIMER (const f) idAny idAny
--------------------------------------------------------------------------------
/uhc-js/uhc-js/src/Language/UHC/JS/HTML5/CSSStyleDeclaration.hs:
--------------------------------------------------------------------------------
1 | {-
2 | // Introduced in DOM Level 2:
3 | interface CSSStyleDeclaration {
4 | attribute DOMString cssText;
5 | // raises(DOMException) on setting
6 |
7 | DOMString getPropertyValue(in DOMString propertyName);
8 | CSSValue getPropertyCSSValue(in DOMString propertyName);
9 | DOMString removeProperty(in DOMString propertyName)
10 | raises(DOMException);
11 | DOMString getPropertyPriority(in DOMString propertyName);
12 | void setProperty(in DOMString propertyName,
13 | in DOMString value,
14 | in DOMString priority)
15 | raises(DOMException);
16 | readonly attribute unsigned long length;
17 | DOMString item(in unsigned long index);
18 | readonly attribute CSSRule parentRule;
19 | };
20 | -}
21 | module Language.UHC.JS.HTML5.CSSStyleDeclaration where
22 |
23 | import Language.UHC.JS.HTML5.Types
24 | import Language.UHC.JS.Types
25 |
26 | foreign import js "%1.cssText"
27 | cssText :: CSSStyleDeclaration -> IO JSString
28 |
29 | foreign import js "%1.getPropertyValue(%*)"
30 | getPropertyValue :: CSSStyleDeclaration -> JSString -> IO JSString
31 |
32 | foreign import js "%1.getPropertyCSSValue(%*)"
33 | getPropertyCSSValue :: CSSStyleDeclaration -> IO CSSValue
34 |
35 | foreign import js "%1.getPropertyPriority(%*)"
36 | getPropertyPriority :: CSSStyleDeclaration -> IO JSString
37 |
38 | foreign import js "%1.setProperty(%*)"
39 | setProperty :: CSSStyleDeclaration -> JSString -> a -> IO ()
40 |
41 | foreign import js "%1.length"
42 | length :: CSSStyleDeclaration -> IO Int
43 |
44 | foreign import js "%1.item(%*)"
45 | item :: CSSStyleDeclaration -> IO JSString
46 |
47 | foreign import js "%1.parentRule"
48 | parentRule :: CSSStyleDeclaration -> IO CSSRule
49 |
50 | {-
51 | // Introduced in DOM Level 2:
52 | interface CSSValue {
53 |
54 | // UnitTypes
55 | const unsigned short CSS_INHERIT = 0;
56 | const unsigned short CSS_PRIMITIVE_VALUE = 1;
57 | const unsigned short CSS_VALUE_LIST = 2;
58 | const unsigned short CSS_CUSTOM = 3;
59 |
60 | attribute DOMString cssText;
61 | // raises(DOMException) on setting
62 |
63 | readonly attribute unsigned short cssValueType;
64 | };
65 | -}
--------------------------------------------------------------------------------
/thesis-snippets/JS/rts.js:
--------------------------------------------------------------------------------
1 | primIsFunction = function(a) {
2 | return PrimMkBool(typeof a === "function");
3 | }
4 |
5 | primIsBool = function(a) {
6 | return PrimMkBool(typeof a === "boolean" || _primIsA(a, Boolean));
7 | }
8 |
9 | _primIsNumber = function(a) {
10 | return typeof a === "number" || _primIsA(a, Number);
11 | }
12 |
13 | primIsNumber = function(a) {
14 | return PrimMkBool(_primIsNumber(a));
15 | }
16 |
17 | _primIsString = function(a) {
18 | return typeof a === "string" || _primIsA(a, String);
19 | }
20 |
21 | primIsString = function(a) {
22 | return PrimMkBool(_primIsString(a));
23 | }
24 |
25 | primIsChar = function(a) {
26 | return PrimMkBool(_primIsString(a) && a.length == 1);
27 | }
28 |
29 | primIsInt = function(a) {
30 | return PrimMkBool(_primIsNumber(a) && parseFloat(a) == parseInt(a, 10) && !isNaN(a));
31 | }
32 |
33 | primIsDouble = function(a) {
34 | return PrimMkBool(_primIsNumber(a) && parseFloat(a) != parseInt(a, 10) && !isNaN(a));
35 | }
36 |
37 | primIsNull = function(a) {
38 | //typeof does not work, known bug.
39 | return PrimMkBool(a === null);
40 | }
41 |
42 | primIsUndefined = function(a) {
43 | return PrimMkBool(typeof a === "undefined");
44 | }
45 |
46 | primIsObject = function(a) {
47 | return PrimMkBool(typeof a === "object" && a !== null);
48 | }
49 |
50 | _primIsA = function(a, b) {
51 | //if a isObject and b isFunction
52 | if(typeof a === "object" && a !== null && typeof b === "function") {
53 | return a.constructor == b;
54 | }
55 | return false;
56 | }
57 |
58 | primIsA = function(a, b) {
59 | return PrimMkBool(_primIsA(a,b));
60 | }
61 |
62 | primIsInstanceOf = function(a, b) {
63 | if(typeof a === "object" && typeof b === "function") {
64 | return PrimMkBool(a instanceof b);
65 | }
66 | return PrimMkBool(false);
67 | }
68 |
69 | primEq = function(a, b) {
70 | return PrimMkBool(a == b);
71 | }
72 |
73 | function bar(a) {
74 | return "hello world";
75 | }
76 |
77 | function getNodeType(a) {
78 | if(a === null) {
79 | return -1;
80 | }
81 | return a.nodeType;
82 | }
83 |
84 | function getNodeOrNull(b) {
85 | if(b) {
86 | return document.body;
87 | } else {
88 | return null;
89 | }
90 | }
91 |
92 | function twice(f) {
93 | f();
94 | f();
95 | }
96 |
97 | function hof1(f) {
98 | alert(f(true));
99 | return "done";
100 | }
101 |
102 | function createCounter() {
103 | var i = 0;
104 | return function() {
105 | return i++;
106 | }
107 | }
108 |
109 | function callMinus() {
110 | }
111 |
112 | x = 0;
113 | function mutX() {
114 | x += 10;
115 | }
116 |
--------------------------------------------------------------------------------
/wxasteroids/src/Graphics/UI/WXCore/Timer.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE CPP #-}
2 | {-# OPTIONS -pgmP cpp #-}
3 | module Graphics.UI.WXCore.Timer (
4 | module Graphics.UI.WXCore.TimerClass
5 | ,timerEvent
6 | ,timer
7 | ) where
8 |
9 | import LightOO
10 | import Graphics.UI.WXCore.TimerClass
11 | import Data.IORef
12 | import Data.Maybe
13 | import Control.Monad
14 | import Graphics.UI.WXCore.Types
15 | import Graphics.UI.WXCore.EvtHandler
16 | import Graphics.UI.WXCore.Event
17 | #ifdef __UHC__
18 | import Language.UHC.JS.HTML5.Window
19 | #else
20 | window = undefined
21 | clearInterval = undefined
22 | setInterval = undefined
23 | #endif
24 |
25 | timerEvent id timer =
26 | (timerEvent' `extends` event id wxEVT_TIMER) noOverride set_Event_Tail
27 | where
28 | timerEvent' tail super self =
29 | return TimerEventClass {
30 | _timerEventGetInterval = self # timerEventGetTimer >>= timerGetInterval
31 | ,_timerEventGetTimer = return timer
32 | ,_timerEventTail = tail
33 | }
34 |
35 | timer owner id =
36 | (timer' `extends` evthandler) noOverride set_EvtHandler_Tail
37 | where
38 | timer' tail super self = do
39 | interval <- newIORef 0
40 | owner <- newIORef owner
41 | isone <- newIORef False
42 | isRunning <- newIORef False
43 | i <- if id == idAny then idCreate else return id
44 | id <- newIORef i
45 | return TimerClass {
46 | _timerGetId = readIORef id
47 | ,_timerGetInterval = readIORef interval
48 | ,_timerGetOwner = readIORef owner
49 | ,_timerIsOneShot = readIORef isone
50 | ,_timerIsRunning = readIORef isRunning
51 | ,_timerSetOwner = \newOwner newId -> do
52 | writeIORef id newId
53 | writeIORef owner newOwner
54 | ,_timerStart = \milli oneshot -> do
55 |
56 | writeIORef isone oneshot
57 |
58 | let this :: Timer
59 | this = upcast self
60 |
61 | timerEventId <- idCreate
62 | timingEvent <- new $ timerEvent timerEventId this
63 | timingEvent # eventSetEventObject $ (upcast this)
64 |
65 | handler <- readIORef owner
66 |
67 | let cb = do {
68 | ; handler # evtHandlerProcessEvent $ (upcast timingEvent)
69 | ; when oneshot (self # timerStop)
70 | }
71 |
72 | w <- window
73 | timerId <- setInterval w cb milli
74 | writeIORef isRunning True
75 | writeIORef id timerId
76 | return True
77 |
78 | ,_timerStop = do
79 | w <- window
80 | timerId <- readIORef id
81 | clearInterval w timerId
82 | writeIORef isRunning False
83 | ,_timerTail = tail
84 | }
85 |
86 |
--------------------------------------------------------------------------------
/uhc-js/tests/in-progress/import_wrapper/import_wrapper.hs:
--------------------------------------------------------------------------------
1 | import Language.UHC.JS.ECMA.String
2 | import Language.UHC.JS.Assorted
3 | import Language.UHC.JS.Primitives
4 | import Language.UHC.JS.JQuery.JQuery
5 |
6 |
7 | foreign import jscript "some_function(%*)"
8 | someFun :: Int -> Int -> JSFunPtr (Int -> IO ()) -> IO ()
9 |
10 | foreign import jscript "wrapper"
11 | wrap :: (Int -> IO ()) -> IO (JSFunPtr (Int -> IO ()))
12 |
13 | myCB :: Int -> Int -> IO ()
14 | myCB n m = alert (show $ m + n)
15 |
16 | main :: IO ()
17 | main =
18 | putStrLn "data_export_wrapper"
19 | >>= \_ -> wrap (myCB 2)
20 | >>= \sf -> someFun 2 3 sf
21 | {- main = do-}
22 | {- putStrLn "data_export_wrapper"-}
23 | {- sf <- wrap myCB-}
24 | {- someFun 2 3 sf-}
25 |
26 | {-
27 |
28 |
29 | In this particular case, alert is actually the culprit. It requires two
30 | arguments, because it is in IO. The current hardcoding is correct in the sense
31 | that we're passing the right argument (the monad), but obviously we can't rely
32 | on hardcoding (it won't work with pure functions, for example).
33 |
34 |
35 |
36 | We now require all functions in an exported constructor to be wrapped in an
37 | IO JSFunPtr construction. To enforce this, we need to modify the type-checker.
38 | We then also need to implement wrapper support in the FFI and do lambda lifting
39 | for lambda functions based on the wrappers
40 |
41 |
42 | Why do we want to wrap functions in IO JSFunPtr?
43 | Because otherwise a plain JS function would get a Haskell representation of a
44 | function, i.e., a: new _A_(new _F_(...)) etc. Regular JS functions do not know
45 | how to deal with these, so we need to wrap them in a regular JS function, which
46 | takes as many arguments as the Haskell function. The Haskell function is then
47 | applied to the arguments and the result is returned. This also explains the
48 | name wrapper....
49 |
50 |
51 | $import_wrapper.$wrap=
52 | new _F_("import_wrapper.wrap",function($__,$__2)
53 | {trace(">$import_wrapper.$wrap"," <- "+$__+", "+$__2);
54 | var $__3=
55 | _e_($__);
56 | var $__4=
57 | _e_(function(vr1)
58 | {return _e_(new _A_($__3,[vr1]));});
59 | var _=
60 | [$__2,$__4];
61 | trace("<$import_wrapper.$wrap"," -> "+_);
62 | return _;});
63 |
64 |
65 | This is an example of the code that's generated for the wrap import. Would the
66 | $__2 represent the IO monad? So in case our callback is in IO, we require the
67 | callback function to be also applied to $__2, whereas we don't require this if
68 | it's pure.
69 |
70 |
71 | -}
72 |
--------------------------------------------------------------------------------
/uhc-js/tests/works/nargs/nargs.hs:
--------------------------------------------------------------------------------
1 | -- The goal of this module is to test the following usecase:
2 | --
3 | -- A JS function can take an arbitrary number of arguments. The ECMA standard,
4 | -- as well as popular libraries like jQuery make use of this feature. Example:
5 | --
6 | -- myArr.concat(arr1, arr2, arr3, arr4, ...); etc.
7 | --
8 | -- How do we encode this in Haskell?
9 |
10 | module Main where
11 |
12 | main :: IO ()
13 | main = accepts3Args 1 2 3
14 |
15 | -- The whole problem of this approach is the fact that we do not know how many
16 | -- elements are in the list until runtime. For a stupid and simple solution,
17 | -- see the next FFI import.
18 | -- Could we use some type-level programming to specify the number of elements
19 | -- that the list can receive? Like the type-level vectors we've see so very
20 | -- frequently? This would require GADTs.. does UHC support that? More
21 | -- importantly, would this provide a solution? We would definitely know the
22 | -- _maximum_ number of elements in the vector, but would this be enough? Also,
23 | -- would this be sufficiently more powerful than the approach below? At the
24 | -- very least, would the increased expressiveness be worth all the hassle of
25 | -- type-level programming?
26 | -- Another question related to that vector... would it specify the _exact_
27 | -- number of elements in the vector? Also, would this actually give us
28 | -- anything?
29 | --
30 | -- I think the bottom line is that lists won't work as a pure Haskell solution.
31 | -- They have a dynamic lenght. We cannot compile JS this way. We will require
32 | -- vectors of which the length is encoded in the type. This, however, is rather
33 | -- complicated.
34 | --
35 | -- Another solution might be to do part of this in the JS world. When we detect
36 | -- an n-argument application, we generate a call to the JS apply() function.
37 | -- This function takes the function name that is to be called as a first
38 | -- argument and a list of arguments as second parameter. We would merge all
39 | -- arguments into one list (e.g. by prepending the first arguments to the
40 | -- n-args list) and then call apply(). Does the UHC JS lib already have a
41 | -- function for this?
42 | --
43 | -- This function below is commented out, because the proposed interface has
44 | -- been discarded in favor of the suggested approach below
45 | {- foreign import jscript "acceptsNArgs(%[*])"-}
46 | {- acceptsNArgs :: [Int] -> IO ()-}
47 |
48 | -- This solution isn't exactly pretty: we're still hardcoding the number of
49 | -- arguments the JS function is given. The difference is that on the JS side,
50 | -- the overloading happens nicely. Also, it's the way one would expect an FFI
51 | -- import to be defined; there are no weird n-argument conventions.
52 | foreign import jscript "acceptsNArgs(%*)"
53 | accepts3Args :: Int -> Int -> Int -> IO ()
54 |
--------------------------------------------------------------------------------
/uhc-js/uhc-js/src/Language/UHC/JS/Primitives.hs:
--------------------------------------------------------------------------------
1 | module Language.UHC.JS.Primitives where
2 |
3 | import Language.UHC.JS.Types
4 |
5 | foreign import prim "primMkAnonObj"
6 | mkAnonObj :: IO JSObject
7 |
8 | foreign import prim "primEq"
9 | _primEq :: JSAny a -> JSAny b -> Bool
10 |
11 | foreign import prim "primMkObj"
12 | _primNewObj :: JSString -> IO JSObject
13 |
14 | foreign import prim "primMkCtor"
15 | _primMkCtor :: JSString -> IO (JSFunction_ a)
16 |
17 | foreign import prim "primGetCtor"
18 | _primGetCtor :: JSString -> IO (JSFunction_ a)
19 |
20 | foreign import prim "primSetCtor"
21 | _primSetCtor :: JSString -> JSFunction_ a -> IO ()
22 |
23 | foreign import prim "primGetAttr"
24 | _primGetAttr :: JSString -> JSObject_ p -> IO a
25 |
26 | foreign import prim "primPureGetAttr"
27 | _primPureGetAttr :: JSString -> JSObject_ p -> a
28 |
29 | foreign import prim "primSetAttr"
30 | _primSetAttr :: JSString -> a -> JSObject_ p -> IO (JSObject_ p)
31 |
32 | foreign import prim "primPureSetAttr"
33 | _primPureSetAttr :: JSString -> a -> JSObject_ p -> JSObject_ p
34 |
35 | foreign import prim "primModAttr"
36 | _primModAttr :: JSString -> (a -> b) -> JSObject_ p -> IO (JSObject_ p)
37 |
38 | foreign import prim "primPureModAttr"
39 | _primPureModAttr :: JSString -> (a -> b) -> JSObject_ p -> JSObject_ p
40 |
41 | foreign import prim "primGetProtoAttr"
42 | _primGetProtoAttr :: JSString -> JSString -> IO a
43 |
44 | foreign import prim "primSetProtoAttr"
45 | _primSetProtoAttr :: JSString -> a -> JSString -> IO ()
46 |
47 | foreign import prim "primModProtoAttr"
48 | _primModProtoAttr :: JSString -> (a -> b) -> JSString -> IO ()
49 |
50 | foreign import prim "primClone"
51 | _primClone :: JSObject_ a -> JSObject_ a
52 |
53 | foreign import prim "primToPlainObj"
54 | _primToPlainObj :: JSObject_ a -> JSObject_ b
55 |
56 | foreign import prim "primInstanceOf"
57 | _primInstanceOf :: a -> b -> Bool
58 |
59 | foreign import prim "primIsNull"
60 | _primIsNull :: a -> Bool
61 |
62 | foreign import prim "primIsUndefined"
63 | _primIsUndefined :: a -> Bool
64 |
65 | foreign import prim "primIsBool"
66 | _primIsBool :: a -> Bool
67 |
68 | foreign import prim "primIsString"
69 | _primIsString :: a -> Bool
70 |
71 | foreign import prim "primIsChar"
72 | _primIsChar :: a -> Bool
73 |
74 | foreign import prim "primIsNumber"
75 | _primIsNumber :: a -> Bool
76 |
77 | foreign import prim "primIsDouble"
78 | _primIsDouble :: a -> Bool
79 |
80 | foreign import prim "primIsObject"
81 | _primIsObject :: a -> Bool
82 |
83 | foreign import prim "primIsFunction"
84 | _primIsFunction :: a -> Bool
85 |
86 | foreign import prim
87 | primNewArray :: Int -> x -> JSArray x
88 |
89 | foreign import prim "primWriteArray"
90 | primWriteArray :: JSArray x -> Int -> x -> ()
91 |
92 | foreign import prim "primStrictWriteArray"
93 | primStrictWriteArray :: JSArray x -> Int -> x -> ()
--------------------------------------------------------------------------------
/uhc-js/uhc-js/src/Language/UHC/JS/HTML5/HTMLDocument.hs:
--------------------------------------------------------------------------------
1 | {-
2 | interface Document : Node {
3 | readonly attribute DOMImplementation implementation;
4 | readonly attribute DOMString URL;
5 | readonly attribute DOMString documentURI;
6 | readonly attribute DOMString compatMode;
7 | readonly attribute DOMString characterSet;
8 | readonly attribute DOMString contentType;
9 |
10 | readonly attribute DocumentType? doctype;
11 | readonly attribute Element? documentElement;
12 | HTMLCollection getElementsByTagName(DOMString localName);
13 | HTMLCollection getElementsByTagNameNS(DOMString? namespace, DOMString localName);
14 | HTMLCollection getElementsByClassName(DOMString classNames);
15 | Element? getElementById(DOMString elementId);
16 |
17 | Element createElement(DOMString localName);
18 | Element createElementNS(DOMString? namespace, DOMString qualifiedName);
19 | DocumentFragment createDocumentFragment();
20 | Text createTextNode(DOMString data);
21 | Comment createComment(DOMString data);
22 | ProcessingInstruction createProcessingInstruction(DOMString target, DOMString data);
23 |
24 | Node importNode(Node node, optional boolean deep = true);
25 | Node adoptNode(Node node);
26 |
27 | Event createEvent(DOMString interface);
28 |
29 | Range createRange();
30 |
31 | // NodeFilter.SHOW_ALL = 0xFFFFFFFF
32 | NodeIterator createNodeIterator(Node root, optional unsigned long whatToShow = 0xFFFFFFFF, optional NodeFilter? filter = null);
33 | TreeWalker createTreeWalker(Node root, optional unsigned long whatToShow = 0xFFFFFFFF, optional NodeFilter? filter = null);
34 |
35 | // NEW
36 | void prepend((Node or DOMString)... nodes);
37 | void append((Node or DOMString)... nodes);
38 | };
39 |
40 | -}
41 | module Language.UHC.JS.HTML5.HTMLDocument where
42 |
43 | import Language.UHC.JS.HTML5.Types
44 | import Language.UHC.JS.Types
45 |
46 | foreign import js "document"
47 | document :: IO HTMLDocument
48 |
49 | --foreign import js "%1.body"
50 | -- body :: HTMLDocument -> IO (Node ())
51 |
52 | --foreign import js "%1.anchors"
53 | -- anchors :: HTMLDocument -> JSArray k Anchor
54 |
55 | --foreign import js "%1.forms"
56 | -- forms :: HTMLDocument -> JSArray k Form
57 |
58 | --foreign import js "%1.images"
59 | -- images :: HTMLDocument -> JSArray k Image
60 |
61 | --foreign import js "%1.links"
62 | -- links :: HTMLDocument -> JSArray k Link
63 |
64 | foreign import js "%1.write(%*)"
65 | write :: HTMLDocument -> JSString -> IO ()
66 |
67 | foreign import js "%1.writeln(%*)"
68 | writeln :: HTMLDocument -> JSString -> IO ()
69 |
70 | foreign import js "%1.getElementById(%*)"
71 | getElementById :: HTMLDocument -> JSString -> IO (Element ())
72 |
73 | foreign import js "%1.getElementsByName(%*)"
74 | getElementsByName :: HTMLDocument -> JSString -> IO HTMLCollection
75 |
76 | foreign import js "%1.getElementsByTagName(%*)"
77 | getElementsByTagName :: HTMLDocument -> JSString -> IO HTMLCollection
78 |
79 | foreign import js "%1.createElement(%*)"
80 | createElement :: HTMLDocument -> JSString -> IO (Element ())
81 |
--------------------------------------------------------------------------------
/wxasteroids/src/Graphics/UI/WX/Timer.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE CPP, TypeSynonymInstances, FlexibleInstances, FlexibleContexts #-}
2 | --------------------------------------------------------------------------------
3 | {-| Module : Timer
4 | Copyright : (c) Daan Leijen 2003
5 | License : wxWindows
6 |
7 | Maintainer : wxhaskell-devel@lists.sourceforge.net
8 | Stability : provisional
9 | Portability : portable
10 |
11 | Support for milli-second timers.
12 | -}
13 | --------------------------------------------------------------------------------
14 | module Graphics.UI.WX.Timer where
15 |
16 | -- change from a single import with all types ands functions to importing the actual
17 | -- implementations.
18 | --import Graphics.UI.WXCore.WxcClasses hiding (Timer)
19 | import Graphics.UI.WXCore.Timer
20 | #ifdef __UHC__
21 | import Graphics.UI.WXCore.WebWindow
22 | #else
23 | import Graphics.UI.WXCore.Window
24 | #endif
25 | import Graphics.UI.WXCore.Event
26 | import Graphics.UI.WXCore.EvtHandler
27 |
28 | import Graphics.UI.WX.Types
29 | import Graphics.UI.WX.Attributes
30 | --import Graphics.UI.WX.Layout
31 | import Graphics.UI.WX.Classes
32 | import Graphics.UI.WX.Events
33 |
34 | import Control.Monad
35 | import LightOO
36 |
37 | {--------------------------------------------------------------------
38 |
39 | --------------------------------------------------------------------}
40 | -- | A timer generates a 'command' event on a specified milli-second 'interval'.
41 | --
42 | -- * Attributes: 'interval'
43 | --
44 | -- * Instances: 'Able', 'Commanding'
45 | --
46 | --type Timer = TimerEx ()
47 |
48 | -- | Create a new timer with a 1 second interval. The timer is automatically discarded
49 | -- when the parent is deleted.
50 | --type Timer = TimerEx ()
51 | --timer :: Window_ a -> [Prop Timer] -> IO Timer
52 | timer :: Window -> [Prop Timer] -> IO Timer
53 | timer parent props
54 | = do t <- windowTimerCreate parent
55 | timerStart t 1000 False
56 | set t props
57 | return t
58 |
59 | -- | The milli-second interval of the timer.
60 | interval :: Attr Timer Int
61 | interval
62 | = newAttr "timer-interval"
63 | (\t -> timerGetInterval t)
64 | (\t i -> do runs <- timerIsRunning t
65 | if (runs)
66 | then do timerStop t
67 | isone <- timerIsOneShot t
68 | timerStart t i isone
69 | return ()
70 | else do timerStart t i True
71 | timerStop t)
72 |
73 | instance Able Timer where
74 | enabled
75 | = newAttr "enabled"
76 | (\t -> timerIsRunning t)
77 | (\t able -> do runs <- timerIsRunning t
78 | when (runs /= able)
79 | (if able then do i <- get t interval
80 | timerStart t i False
81 | return ()
82 | else do timerStop t))
83 |
84 | instance Commanding Timer where
85 | command
86 | = newEvent "command" timerGetOnCommand timerOnCommand
--------------------------------------------------------------------------------
/uhc-js/tests/works/data_export_plain/data_export_plain.hs:
--------------------------------------------------------------------------------
1 | import Language.UHC.JS.ECMA.String
2 | import Language.UHC.JS.Primitives
3 | import Language.UHC.JS.Assorted
4 |
5 | {-
6 |
7 | So this would be somewhat of a decent idea. The thing is, though, that we'd
8 | still be doing runtime conversion. If we're going to be stuck with that anyway,
9 | we might just as well just have a primitive JS function to do this for us. We'd
10 | still need to wrap the functions in an object, though. Would we need some
11 | facility to turn the datatype into an object first? I don't think so; we'd just
12 | have to evaluate the datatype and then call primToPlainObj on it. In fact, we
13 | might as well embed the evaluation in primToPlainObj and do the evaluation
14 | inside. We would then import it with type `a -> JSPtr b`.
15 |
16 | So, in short: the original object export approach won't be good enough. In
17 | common usecases, one stores callbacks in an object. These callbacks need to
18 | be of type JSFunPtr (...). The only way to obtain something of that type is
19 | to wrap a function using a wrapper, which is a dynamic process. Converting a
20 | Haskell datatype is therefor also defered to runtime. In fact, the entire
21 | process is very similar to a function wrapper. One could call it an object
22 | wrapper.
23 | -}
24 |
25 | main = do
26 | putStrLn "data_export"
27 | add' <- mkMath add
28 | bptr <- mkBook (myBook add')
29 | print $ getCount bptr
30 | myFun bptr
31 |
32 | getCount :: JSBook -> Int
33 | getCount = getAttr "count"
34 |
35 | data BookPtr
36 | type JSBook = JSPtr BookPtr
37 |
38 | data Book
39 | = Book
40 | { title :: JSString
41 | , author :: JSString
42 | , count :: Int
43 | , stuff :: String
44 | , doMath :: JSFunPtr (Int -> Int -> IO ())
45 | }
46 |
47 | add :: Int -> Int -> IO ()
48 | add x y = print $ y + x
49 |
50 | -- TODO
51 | -- The current problem is that we need to do something like this:
52 | --
53 | -- main = do
54 | -- add' <- mkMath add
55 | -- let b = myBook add'
56 | -- ...
57 | -- where myBook add' = Book "" "" 1 "" add'
58 | --
59 | -- but the current object export cannot deal with exporting functions. How
60 | -- do we fix this?
61 | --
62 | -- Perhaps we need a mechanism similar to wrapper and dynamic, which
63 | -- dynamically creates a plain object from a datatype:
64 | --
65 | -- foreign import jscript "{}" mkJSObj :: a -> JSPtr b
66 | --
67 | -- where `a` must be a data value. If so, we should remove it from the FEL
68 | -- and parse it as a token instead. Though, that would require modifying
69 | -- _every_ FFI backend. Lets leave it in the FEL anyway.
70 | --
71 | myBook f = Book (stringToJSString "story") (stringToJSString "me") 123 "foo" f
72 |
73 |
74 | {- foreign export jscript "myBook" myBook :: Book-}
75 | {- foreign export jscript "{myBook}" myBook :: Book-}
76 | {- foreign import jscript "myBook()" myBookPtr :: JSBook-}
77 | {- foreign import jscript "{myBook}" myBookPtr :: JSBook-}
78 |
79 | mkBook :: Book -> IO JSBook
80 | mkBook = mkObj
81 |
82 | foreign import jscript "myFun(%1)"
83 | myFun :: JSBook -> IO ()
84 |
85 | foreign import jscript "{}"
86 | mkObj :: a -> IO (JSPtr b)
87 |
88 | foreign import jscript "wrapper"
89 | mkMath :: (Int -> Int -> IO ()) -> IO (JSFunPtr (Int -> Int -> IO ()))
90 |
91 |
--------------------------------------------------------------------------------
/msc-thesis/thesis.fmt:
--------------------------------------------------------------------------------
1 | % -----------------------------------------------------------------------------
2 | % GENERIC
3 | % -----------------------------------------------------------------------------
4 |
5 | %format Bool = "\TConId{Bool}"
6 | %format Int = "\TConId{Int}"
7 | %format Char = "\TConId{Char}"
8 | %format String = "\TConId{String}"
9 | %format Identity = "\TConId{Identity}"
10 | %format IO = "\TConId{IO}"
11 | %format Reader = "\TConId{Reader}"
12 | %format State = "\TConId{State}"
13 | %format ReaderT = "\TConId{ReaderT}"
14 | %format StateT = "\TConId{ReaderT}"
15 | %format FilePath = "\TConId{FilePath}"
16 | %format Dynamic = "\TConId{Dynamic}"
17 |
18 | %format MonadIO = "\TClassId{MonadIO}"
19 | %format Monad = "\TClassId{Monad}"
20 | %format Monoid = "\TClassId{Monoid}"
21 | %format Applicative = "\TClassId{Applicative}"
22 | %format Alternative = "\TClassId{Alternative}"
23 | %format Foldable = "\TClassId{Foldable}"
24 | %format Traversable = "\TClassId{Traversable}"
25 | %format Eq = "\TClassId{Eq}"
26 | %format Binary = "\TClassId{Binary}"
27 | %format AM = "\TClassId{Monad}"
28 | %format AMIO = "\TClassId{MonadIO}"
29 |
30 | %format ~ = " \sim "
31 | %format mempty = "\varnothing "
32 | %format `mappend` = "\oplus "
33 | %format fmap' a = "\widehat{" a "}"
34 | %format <*> = "\circledast "
35 | %format <=< = "\bullet "
36 | %format >>= = "\rightarrowtail "
37 | %format =<< = "\leftarrowtail "
38 | %format fixp = "fix"
39 | %format Left = "L"
40 | %format Right = "R"
41 | %format fmap2 = "fmap_2"
42 |
43 | %format foreign = "\Keyword{foreign}"
44 | %format js = "\Keyword{js}"
45 |
46 | %format top = "\top "
47 | %format :|: = " + "
48 | %format :<: = " \TClassId{$\ \prec\ $} "
49 | %format :>: = " \TClassId{$\ \succ\ $} "
50 | %format iso = " \cong "
51 | %format DefineClass = "DefineClass_{macro}"
52 | %format DefineSubClass = "DefineSubClass_{macro}"
53 | %format alpha = "\alpha"
54 | %format beta = "\beta"
55 | %format Comp = "\circ"
56 | %format oplus = "\oplus"
57 | %format Narrow = "\TClassId{Narrow}"
58 | %format Widen = "\TClassId{Widen}"
59 | %format Typeable = "\TClassId{Typeable}"
60 |
61 | %format clazz = "\Keyword{clazz}"
62 | %format extends = "\Keyword{extends}"
63 | %format new = "\Keyword{new}"
64 | %format equiv = "\equiv"
65 | %format cp1 = "cp_1"
66 | %format cp2 = "cp_2"
67 | %format cv1 = "cv_1"
--------------------------------------------------------------------------------
/uhc-js/uhc-js/src/Language/UHC/JS/Marshal.hs:
--------------------------------------------------------------------------------
1 | module Language.UHC.JS.Marshal where
2 |
3 | import Language.UHC.JS.Primitives
4 | import Language.UHC.JS.Types
5 | import UHC.BoxArray
6 | import UHC.Array
7 | import Data.Maybe
8 | import Control.Monad
9 |
10 | class ToJS a b where
11 | toJS :: a -> b
12 |
13 | class FromJS b a where
14 | fromJS :: b -> Maybe a
15 |
16 | -- JSNull
17 |
18 | instance ToJS a a where
19 | toJS = id
20 |
21 | instance FromJS JSNull (Maybe a) where
22 | fromJS _ = Nothing
23 |
24 | instance ToJS () JSUndefined where
25 | toJS _ = _undefined
26 |
27 | instance FromJS JSUndefined () where
28 | fromJS _ = Just ()
29 |
30 | -- JSBool
31 |
32 | instance ToJS Bool JSBool where
33 | toJS = boolToJSBool
34 |
35 | instance FromJS JSBool Bool where
36 | fromJS v =
37 | if _primIsBool v
38 | then if _primEq _true v
39 | then Just True
40 | else Just False
41 | else Nothing
42 |
43 |
44 | boolToJSBool :: Bool -> JSBool
45 | boolToJSBool True = _true
46 | boolToJSBool False = _false
47 |
48 | -- JSString
49 |
50 | fromJS_ = fromJust. fromJS
51 |
52 | instance Show JSString where
53 | show = fromJS_
54 |
55 | instance ToJS String JSString where
56 | toJS = stringToJSString
57 |
58 | instance FromJS JSString String where
59 | fromJS v =
60 | if _primIsString v
61 | then Just (jsStringToString v)
62 | else Nothing
63 |
64 | instance (Show a) => ToJS a JSString where
65 | toJS v = toJS (show v) :: JSString
66 |
67 | jsStringToString :: JSString -> String
68 | jsStringToString = packedStringToString . unsafeCoerce
69 |
70 | foreign import prim "primStringToPackedString"
71 | stringToJSString :: String -> JSString
72 |
73 | instance ToJS [a] (JSArray a) where
74 | toJS = listToStrictJSArray
75 |
76 | listToJSArray :: [a] -> JSArray a
77 | listToJSArray [] = error "Cannot convert empty list"
78 | listToJSArray xs = snd $ foldr f (0, primNewArray (length xs) (head xs)) xs
79 | where f x (n, arr) = (n+1, seq (primWriteArray arr n x) arr)
80 |
81 | listToStrictJSArray :: [a] -> JSArray a
82 | listToStrictJSArray [] = error "Cannot convert empty list"
83 | listToStrictJSArray xs = snd $ foldr f (0, primNewArray (length xs) (head xs)) xs
84 | where f x (n, arr) = (n+1, seq (primStrictWriteArray arr n x) arr)
85 |
86 | lengthJSArray :: JSArray a -> Int
87 | lengthJSArray = _primPureGetAttr (toJS "length" :: JSString)
88 |
89 | --indexJSArray :: JSArray x -> Int -> x
90 | --indexJSArray = indexArray
91 |
92 | --{- instance FromJS (JSArray x) where-}
93 | -- {- fromJS = jsArrayToArray-}
94 |
95 | jsArrayToArray :: JSArray x -> Array Int x
96 | jsArrayToArray a
97 | = Array 0 (l-1) l (unsafeCoerce a)
98 | where l = lengthJSArray a
99 |
100 | str :: String -> JSString
101 | str = toJS
102 |
103 | bl :: Bool -> JSBool
104 | bl = toJS
105 |
106 | liftFromJS :: (Monad m, FromJS b a) => m b -> m (Maybe a)
107 | liftFromJS = liftM fromJS
108 |
109 | liftFromJS_ :: (Monad m, FromJS b a) => m b -> m a
110 | liftFromJS_ m = do
111 | x <- liftM fromJS m
112 | maybe (error "no string") return x
113 |
114 | liftToJS :: (Monad m, ToJS a b) => m a -> m b
115 | liftToJS = liftM toJS
116 |
117 | mkIdxRes :: Int -> Maybe Int
118 | mkIdxRes (-1) = Nothing
119 | mkIdxRes n = Just n
120 |
--------------------------------------------------------------------------------
/uhc-js/uhc-js/src/Language/UHC/JS/ECMA/String.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE MultiParamTypeClasses #-}
2 | module Language.UHC.JS.ECMA.String where
3 |
4 | import Language.UHC.JS.Types
5 | import Language.UHC.JS.Marshal
6 |
7 | foreign import js "String.fromCharCode(%*)"
8 | fromCharCode :: Int -> JSString
9 |
10 | foreign import js "String.fromCharCode(%*)"
11 | fromCharCode2 :: Int -> Int -> JSString
12 | -- etc.
13 |
14 | foreign import js "%1.toString()"
15 | toString :: JSString -> JSString
16 |
17 | foreign import js "%1.valueOf()"
18 | valueOf :: JSString -> JSString
19 |
20 | foreign import js "%1.charAt(%2)"
21 | charAt :: JSString -> Int -> JSString
22 |
23 | foreign import js "%1.charCodeAt(%2)"
24 | charCodeAt :: JSString -> Int -> Int
25 |
26 | foreign import js "%1.concat(%*)"
27 | concat :: JSString -> JSString -> JSString
28 |
29 | foreign import js "%1.concat(%*)"
30 | concat2 :: JSString -> JSString -> JSString -> JSString
31 | -- etc.
32 |
33 | foreign import js "%1.indexOf(%*)"
34 | _indexOf :: JSString -> JSString -> Int
35 |
36 | foreign import js "%1.indexOf(%*)"
37 | _indexOf' :: JSString -> JSString -> Int -> Int
38 |
39 | indexOf :: JSString -> JSString -> Maybe Int
40 | indexOf a x = mkIdxRes $ _indexOf a x
41 |
42 | indexOf' :: JSString -> JSString -> Int -> Maybe Int
43 | indexOf' a x i = mkIdxRes $ _indexOf' a x i
44 |
45 | foreign import js "%1.lastIndexOf(%*)"
46 | _lastIndexOf :: JSString -> JSString -> Int
47 |
48 | foreign import js "%1.lastIndexOf(%*)"
49 | _lastIndexOf' :: JSString -> JSString -> Int -> Int
50 |
51 | lastIndexOf :: JSString -> JSString -> Maybe Int
52 | lastIndexOf a x = mkIdxRes $ _lastIndexOf a x
53 |
54 | lastIndexOf' :: JSString -> JSString -> Int -> Maybe Int
55 | lastIndexOf' a x i = mkIdxRes $ _lastIndexOf' a x i
56 |
57 | foreign import js "%1.localeCompare(%*)"
58 | localeCompare :: JSString -> JSString -> Int
59 |
60 | -- TODO: The argument to match() should be a regex. Define a regex type?
61 | -- Though, in JS, just supplying a string works fine too.
62 | foreign import js "%1.match(%*)"
63 | match :: JSString -> JSString -> [JSString]
64 |
65 | foreign import js "%1.replace(%*)"
66 | replace :: JSString -> JSString -> JSString -> JSString
67 |
68 | foreign import js "%1.search(%*)"
69 | _search :: JSString -> JSString -> Int
70 |
71 | search :: JSString -> JSString -> Maybe Int
72 | search a x = mkIdxRes $ _search a x
73 |
74 | foreign import js "%1.slice(%*)"
75 | slice :: JSString -> Int -> Int -> JSString
76 |
77 | -- TODO: The separator argument can also be a RegExp
78 | foreign import js "%1.split(%*)"
79 | split :: JSString -> JSString -> [JSString]
80 |
81 | foreign import js "%1.split(%*)"
82 | split' :: JSString -> JSString -> Int -> [JSString]
83 |
84 | foreign import js "%1.substring(%*)"
85 | substring :: JSString -> Int -> Int -> JSString
86 |
87 | foreign import js "%1.toLowerCase()"
88 | toLowerCase :: JSString -> JSString
89 |
90 | foreign import js "%1.toLocaleLowerCase()"
91 | toLocaleLowerCase :: JSString -> JSString
92 |
93 | foreign import js "%1.toUpperCase()"
94 | toUpperCase :: JSString -> JSString
95 |
96 | foreign import js "%1.toLocaleUpperCase()"
97 | toLocaleUpperCase :: JSString -> JSString
98 |
99 | foreign import js "%1.trim()"
100 | trim :: JSString -> JSString
101 |
102 | foreign import js "%1.length"
103 | length :: JSString -> Int
--------------------------------------------------------------------------------
/lightoo/src/Examples/ReturnSelfShape.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE CPP, MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances, DeriveDataTypeable, StandaloneDeriving, FlexibleContexts #-}
2 | {-# OPTIONS -pgmP cpp #-}
3 | module Examples.ReturnSelfShape where
4 |
5 | #ifdef __UHC__
6 | #include "../LightOOUHC.h"
7 | #include "Typeable.h"
8 | #else
9 | #include "../LightOO.h"
10 | #endif
11 |
12 | import LightOO
13 | import Examples.Print
14 | import Data.Typeable
15 | import Data.IORef
16 |
17 | data IShape a = IShape {
18 | getX :: IO Int
19 | , getY :: IO Int
20 | , setX :: Int -> IO ()
21 | , setY :: Int -> IO ()
22 | , moveTo :: Int -> Int -> IO ()
23 | , rMoveTo :: Int -> Int -> IO ()
24 | , draw :: IO ()
25 | , meShape :: IO Shape
26 | , _shapeTail :: Record a
27 | }
28 | DefineClass(Shape,IShape,shapeTail,,1)
29 |
30 | #ifdef __UHC__
31 | INSTANCE_TYPEABLE1(IShape,shapeTc,"Shape")
32 | #endif
33 |
34 | shape newx newy concreteDraw =
35 | clazz $ \tail self -> do
36 | x <- newIORef newx
37 | y <- newIORef newy
38 | return IShape {
39 | getX = readIORef x
40 | , getY = readIORef y
41 | , setX = writeIORef x
42 | , setY = writeIORef y
43 | , moveTo = \newx newy -> do
44 | self # setX $ newx
45 | self # setY $ newy
46 | , rMoveTo = \deltax deltay -> do
47 | x <- self # getX
48 | y <- self # getY
49 | (self # moveTo) (x + deltax) (y + deltay)
50 | , draw = concreteDraw self
51 | , meShape = return (upcast self :: Shape)
52 | , _shapeTail = tail
53 | }
54 |
55 | data IRectangle a = IRectangle {
56 | _getWidth :: IO Int
57 | ,_getHeight :: IO Int
58 | ,_setWidth :: Int -> IO ()
59 | ,_setHeight :: Int -> IO ()
60 | ,_meRect :: IO Rectangle
61 | ,_rectangleTail :: Record a
62 | }
63 | DefineSubClass(Rectangle,Shape,IRectangle,rectangleTail,,,,1,)
64 |
65 | #ifdef __UHC__
66 | INSTANCE_TYPEABLE1(IRectangle,rectangleTc,"Rectangle")
67 | #endif
68 |
69 | rectangleMethods = unRecord . get_Shape_Tail
70 | getWidth = _getWidth . rectangleMethods
71 | getHeight = _getHeight . rectangleMethods
72 | setWidth = _getWidth . rectangleMethods
73 | setHeight = _getHeight . rectangleMethods
74 | meRect = _meRect . rectangleMethods
75 |
76 | rectangle x y width height =
77 | (wrapper `extends` shape x y draw) noOverride set_Shape_Tail
78 | where
79 | wrapper tail super self = do
80 | w <- newIORef width
81 | h <- newIORef height
82 | return IRectangle {
83 | _getWidth = readIORef w
84 | , _getHeight = readIORef h
85 | , _setWidth = writeIORef w
86 | , _setHeight = writeIORef h
87 | , _meRect = return $ upcast self
88 | , _rectangleTail = tail
89 | }
90 |
91 | draw self = printLn ("Drawing a Rectangle at:(" <<
92 | self # getX << ", " << self # getY <<
93 | "), width " << self # getWidth <<
94 | ", height " << self # getHeight)
95 |
96 | mySelf = do
97 | s1 <- new $ rectangle 10 20 5 6
98 |
99 | shape <- s1 # meShape
100 | shape # draw
101 | let Just rect = downcast shape :: Maybe Rectangle
102 | rect # getWidth >>= putStrLn . show
103 |
104 | return ()
105 |
106 |
--------------------------------------------------------------------------------
/thesis-snippets/JS/UnionExt.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE CPP, MultiParamTypeClasses, StandaloneDeriving, FlexibleInstances, TypeOperators, OverlappingInstances, ScopedTypeVariables #-}
2 | {-# OPTIONS -pgmP cpp #-}
3 | module UnionExt where
4 |
5 | import Unsafe.Coerce
6 | import Prelude hiding (log)
7 | import Data.Maybe
8 |
9 | data JSUndefined
10 | data JSNull
11 |
12 | data JSObject a
13 |
14 | deriving instance Show (JSObject a)
15 |
16 | data JSBool_
17 | type JSBool = JSObject JSBool_
18 |
19 | data Element_ a
20 | type Element a = JSObject (Element_ a)
21 |
22 | data Node_ a
23 | type Node a = Element (Node_ a)
24 |
25 | data CHTMLElement a
26 | type HTMLElement_ a = Node (CHTMLElement a)
27 |
28 | data Document_
29 | type Document = Node Document_
30 |
31 | data JSString_
32 | #ifdef __UHC__
33 | type JSString = JSObject PackedString
34 | #else
35 | type JSString = JSObject JSString_
36 | #endif
37 |
38 | data a :|: b = L a | R b
39 | infixr 5 :|:
40 |
41 | class SubType sub sup where
42 | inj :: sub -> sup -- injection
43 | prj :: sup -> Maybe sub -- projection
44 |
45 |
46 | instance SubType a a where
47 | inj = id
48 | prj = Just
49 |
50 | instance SubType a (a :|: b) where
51 | inj = L
52 | prj (L x) = Just x
53 | prj _ = Nothing
54 |
55 | instance SubType a c => SubType a (b :|: c) where
56 | inj = R . inj
57 | prj (R x) = prj x
58 | prj _ = Nothing
59 |
60 | x :: Int :|: String :|: Bool
61 | x = inj True
62 |
63 | bar :: JSNull :|: Int -> JSString :|: JSBool
64 | bar a =
65 | let jsVal =
66 | case prj a :: Maybe JSNull of
67 | Just v -> unsafeCoerce v
68 | Nothing ->
69 | case prj a :: Maybe Int of
70 | Just v -> unsafeCoerce v
71 | Nothing -> error "impossible"
72 |
73 | ret r | isString r = inj (unsafeCoerce r :: JSString)
74 | | isBool r = inj (unsafeCoerce r :: JSBool)
75 | in ret (_bar jsVal)
76 |
77 | fooBar :: JSNull :|: Int -> JSString :|: JSBool -> JSBool :|: Int
78 | fooBar = undefined
79 |
80 | test :: forall a. Node a :|: Bool -> IO ()
81 | test n = do
82 | let node = prj n :: Maybe (Node a)
83 | print (isJust node)
84 | putStr "yo"
85 |
86 | foo :: forall a. IO ()
87 | foo = test (inj (undefined :: Node a) :: Node a :|: Bool)
88 |
89 | fubar = \(x :: ((JSObject a) :|: Bool)) -> True
90 | fubar1 = \(x :: ((Element a) :|: Bool)) -> True
91 |
92 | test1 = fubar (inj (undefined :: JSObject ()) :: (JSObject () :|: Bool))
93 | test2 :: forall a. Bool
94 | test2 = fubar1 (inj (undefined :: Node a) :: (Node a :|: Bool))
95 |
96 |
97 | ($<) :: (SubType c a, SubType d b) => (a -> b) -> c -> Maybe d
98 | ($<) f = prj . f . inj
99 |
100 | #ifdef __UHC__
101 | foreign import js "primIsBool(%1)"
102 | isBool :: a -> Bool
103 |
104 | foreign import js "primIsString(%*)"
105 | isString :: a -> Bool
106 |
107 | foreign import js "bar(%1)"
108 | _bar :: a -> b
109 |
110 | foreign import js "null"
111 | _null :: JSNull
112 |
113 | foreign import js "console.log(%*)"
114 | log :: a -> IO ()
115 | #else
116 | _bar :: a -> b
117 | _bar = undefined
118 |
119 | _null :: JSNull
120 | _null = undefined
121 |
122 | log :: a -> IO ()
123 | log = undefined
124 |
125 | isString :: a -> Bool
126 | isString = undefined
127 |
128 | isBool :: a -> Bool
129 | isBool = undefined
130 | #endif
131 |
132 | main = do
133 | let Just v = (bar $< _null) :: Maybe JSString
134 | log v
135 |
--------------------------------------------------------------------------------
/uhc-js/uhc-js/src/Language/UHC/JS/JQuery/Ajax.hs:
--------------------------------------------------------------------------------
1 | module Language.UHC.JS.JQuery.Ajax (AjaxOptions(..), JSAjaxOptions(..), AjaxCallback, AjaxRequestType(..), ajaxBackend, ajax, toJSOptions, mkJSAjaxCallback, noop) where
2 |
3 | import Language.UHC.JS.ECMA.String
4 | import Language.UHC.JS.Types
5 | import Language.UHC.JS.Prelude
6 | import Language.UHC.JS.Marshal
7 |
8 | import Data.List
9 |
10 | data JQXHRPtr
11 | type JQXHR = JSObject_ JQXHRPtr
12 |
13 | -- These two types themselves do not contain the constraint JS r as these types
14 | -- are also used in the wrapper functions. The FFI does not support classes so
15 | -- hence their absence here.
16 | type AjaxCallback r = r -> String -> JQXHR -> IO()
17 | type JSAjaxCallback r = JSFunction_ (AjaxCallback r)
18 |
19 | data AjaxRequestType = GET | HEAD | POST | PUT | DELETE
20 | deriving Show
21 |
22 | -- Records for convenience passing
23 | data AjaxOptions a = AjaxOptions {
24 | ao_url :: String,
25 | ao_requestType :: AjaxRequestType,
26 | ao_contentType :: String,
27 | ao_dataType :: String
28 | }
29 |
30 |
31 | data JSAjaxOptions a = JSAjaxOptions {
32 | url :: JSString,
33 | requestType :: JSString,
34 | contentType :: JSString,
35 | dataType :: JSString
36 | }
37 |
38 | instance Show (AjaxOptions a) where
39 | show jsopt= "AjaxOptions: " ++ intercalate " " [show $ ao_url jsopt]
40 |
41 | instance Show (JSAjaxOptions a) where
42 | show jsopt = "JSAjaxOptions: " ++ intercalate " " [show $ url jsopt]
43 |
44 | -- | It should be possible to do this automatically by using generics with
45 | -- Generic Deriving
46 | toJSOptions :: AjaxOptions a -> JSAjaxOptions a
47 | toJSOptions options = let url' = toJS (ao_url options)
48 | requestType' = toJS (show $ ao_requestType options)
49 | contentType' = toJS (ao_contentType options)
50 | dataType' = toJS (ao_dataType options)
51 | in JSAjaxOptions { url = url'
52 | , requestType = requestType'
53 | , contentType = contentType'
54 | , dataType = dataType'
55 | }
56 |
57 | -- | Wrapper function that processes the needed arguments before passing it
58 | -- to |cont| that is responsible for doing the request. One can also partially
59 | -- apply this to get insert a debugger for requests.
60 | ajaxBackend :: (JSObject_ a -> IO ()) -> AjaxOptions a -> v -> AjaxCallback r -> AjaxCallback r -> IO ()
61 | ajaxBackend cont options valdata onSuccess onFailure =
62 | do let jsOptions = toJSOptions options
63 | onSuccess' <- mkJSAjaxCallback onSuccess
64 | onFailure' <- mkJSAjaxCallback onFailure
65 | o <- mkObj jsOptions
66 | _ <- setAttr "type" (requestType jsOptions) o
67 | _ <- setAttr "success" onSuccess' o
68 | _ <- setAttr "error" onFailure' o
69 | _ <- setAttr "data" valdata o
70 | cont o
71 |
72 | -- | Using the standard jQuery ajax function for executing the jQuery funcitons.
73 | ajax :: AjaxOptions a -> v -> AjaxCallback r -> AjaxCallback r -> IO ()
74 | ajax = ajaxBackend _ajax
75 |
76 |
77 | foreign import js "wrapper"
78 | mkJSAjaxCallback :: AjaxCallback r -> IO (JSAjaxCallback r)
79 |
80 |
81 | foreign import js "$.ajax(%1)"
82 | _ajax :: JSAny a -> IO ()
83 |
84 | noop :: AjaxCallback a
85 | noop _ _ _ = return ()
--------------------------------------------------------------------------------
/lightoo/src/LightOO.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE CPP, ScopedTypeVariables, StandaloneDeriving, DeriveDataTypeable, TypeSynonymInstances #-}
2 | {-# OPTIONS -pgmP cpp #-}
3 | module LightOO (
4 | module LightOO.Core
5 | ,instanceof
6 | ,returnIO
7 | ,singleton
8 | #ifndef __UHC__
9 | ,Castable(..)
10 | ,CastCons(..)
11 | #else
12 | ,consUb
13 | ,nilUb
14 | ,consLb
15 | ,nilLb
16 | #endif
17 | -- object stuff
18 | ,IObject
19 | ,object
20 | ,sameObject
21 | ,objectMethods
22 | ,Object
23 | ,Object_
24 | ,get_Object_Tail
25 | ,set_Object_Tail
26 | ,modify_Object_Tail
27 | ) where
28 |
29 | #ifdef __UHC__
30 | #include "Typeable.h"
31 | #include "LightOOUHC.h"
32 | #else
33 | #include "LightOO.h"
34 | #endif
35 |
36 | import LightOO.Core
37 | import Data.Typeable
38 | import Data.Maybe
39 | import Data.Array
40 | import Data.Foldable
41 | import Data.Monoid
42 | import Control.Applicative
43 | import Data.IORef
44 | import Prelude hiding (foldr)
45 | #ifndef __UHC__
46 | import qualified Data.Map as M
47 | #endif
48 | import qualified Data.Array as A
49 |
50 | #ifndef __UHC__
51 | class Functor f => Castable f where
52 | fup :: (Sub a b) => f a -> f b
53 | fup = fmap upcast
54 |
55 | fdown :: forall a b. (Foldable f, Applicative f, Monoid (f a), Sup b a) => f b -> f a
56 | fdown = foldr (mappend . maybe mempty pure . (downcast :: b -> Maybe a)) mempty
57 |
58 | instance Castable []
59 | instance Castable (M.Map k)
60 | instance Ix i => Castable (A.Array i)
61 | instance Castable Maybe
62 |
63 | class Applicative f => CastCons f where
64 | consUb :: forall a b. (Typeable b, Sub a b, Monoid (f b)) => a -> f b -> f b
65 | consUb o xs = pure (upcast o :: b) `mappend` xs
66 |
67 | consLb :: forall b a. (Typeable b, Sup b a, Monoid (f a)) => b -> f a -> f a
68 | consLb o xs = maybe xs (mappend xs . pure) (downcast o :: Maybe a)
69 |
70 | nilUb,nilLb :: Monoid (f a) => f a
71 | nilUb = mempty
72 | nilLb = mempty
73 |
74 | instance CastCons []
75 | instance CastCons Maybe
76 | #else
77 | consUb :: (Typeable a, Typeable b, Sub a b) => a -> [b] -> [b]
78 | consUb o (xs :: [b]) = (upcast o :: b) : xs
79 |
80 | nilUb :: (Typeable a, Sub a a) => [a]
81 | nilUb = []
82 |
83 | consLb :: (Typeable a, Typeable b, Sup b a) => b -> [a] -> [a]
84 | consLb o (xs :: [a]) =
85 | case downcast o :: Maybe a of
86 | Just x -> x : xs
87 | Nothing -> xs
88 |
89 | nilLb :: (Typeable a, Sup a a) => [a]
90 | nilLb = []
91 | #endif
92 |
93 | instanceof :: (Sup b a) => b -> a -> Bool
94 | instanceof b (_ :: a) = isJust (downcast b :: Maybe a)
95 |
96 | singleton :: IORef (Maybe o) -> ClosedClass o -> IO o
97 | singleton store o = do
98 | s <- readIORef store
99 | let storeInstance = do
100 | inst <- new o
101 | writeIORef store (Just inst)
102 | return inst
103 | maybe storeInstance return s
104 |
105 | data IObject t = IObject {
106 | objectGetFlag :: IO Bool
107 | ,objectSetFlag :: Bool -> IO ()
108 | ,_objectTail :: Record t
109 | }
110 | DefineClass(Object,IObject,objectTail,,1)
111 |
112 | #ifdef __UHC__
113 | INSTANCE_TYPEABLE1(IObject,objectTc,"Object")
114 | #endif
115 |
116 | object = clazz $ \tail self -> do
117 | flag <- newIORef False
118 | return IObject {
119 | objectSetFlag = writeIORef flag
120 | ,objectGetFlag = readIORef flag
121 | ,_objectTail = tail
122 | }
123 |
124 | sameObject a b = do
125 | a # objectSetFlag $ False
126 | b # objectSetFlag $ True
127 | a # objectGetFlag
128 |
129 | returnIO = return :: a -> IO a
130 |
131 | objectMethods = id
--------------------------------------------------------------------------------
/wxasteroids/AsteroidsDesktop.hs:
--------------------------------------------------------------------------------
1 | module Main where
2 |
3 | import Graphics.UI.WX
4 | import System.Random
5 |
6 | height :: Int
7 | height = 300
8 |
9 | width :: Int
10 | width = 300
11 |
12 | diameter :: Int
13 | diameter = 24
14 |
15 | chance :: Double
16 | chance = 0.1
17 |
18 | asteroids :: IO ()
19 | asteroids =
20 | do
21 | g <- getStdGen
22 | vrocks <- varCreate $ randomRocks g
23 | vship <- varCreate $ div width 2
24 |
25 | -- Using a window causes segfault...
26 | --w <- window objectNull [area := rect (pt 0 0) (sz width height)]
27 | f <- frame [ area := rect (pt 0 0) (sz width height)]
28 |
29 | t <- timer f [ interval := 50
30 | , on command := advance vrocks f
31 | ]
32 |
33 | set f [
34 | on paint := draw vrocks vship
35 | , on leftKey := varUpdate vship (\x -> max 0 (x - 5)) >> return ()
36 | , on rightKey := varUpdate vship (\x -> min width (x + 5)) >> return ()
37 | , on (charKey 'q') := set t [interval :~ \i -> i * 2]
38 | , on (charKey 'w') := set t [interval :~ \i -> max 10 (div i 2)]
39 | ]
40 |
41 | --advance :: (Textual w, Paint w1) => w -> Var [[a]] -> w1 -> IO ()
42 | advance :: (Paint w) => Var [[a]] -> w -> IO ()
43 | advance vrocks f =
44 | do
45 | (r : rs) <- varGet vrocks
46 | varSet vrocks rs
47 | repaint f
48 |
49 | randomRocks :: RandomGen g => g -> [[Point]]
50 | randomRocks g = flatten [] (map fresh (randoms g))
51 |
52 | flatten :: [[a]] -> [[[a]]] -> [[a]]
53 | flatten rocks (t : ts) =
54 | let now = map head rocks
55 | later = filter (not . null) (map tail rocks)
56 | in now : flatten (t ++ later) ts
57 | flatten rocks [] = error "Empty rocks list not expected in function flatten"
58 |
59 | fresh :: Double -> [[Point2 Int]]
60 | fresh r
61 | | r > chance = []
62 | | otherwise = [track (floor (fromIntegral width * r / chance))]
63 |
64 | track :: Int -> [Point2 Int]
65 | track x = [point x (y - diameter) | y <- [0, 6 .. height + 2 * diameter]]
66 |
67 | --draw :: Var [[Point2 Int]] -> Var Int -> DC a -> b -> IO ()
68 | draw :: Var [[Point2 Int]] -> Var Int -> DC a -> b -> IO ()
69 | draw vrocks vship dc _view =
70 | do
71 | rocks <- varGet vrocks
72 | x <- varGet vship
73 | let
74 | shipLocation = point x (height - 2 * diameter)
75 | positions = head rocks
76 | collisions = map (collide shipLocation) positions
77 |
78 | drawShip dc shipLocation
79 | mapM (drawRock dc) (zip positions collisions)
80 | --when (or collisions) (play explode)
81 | when (or collisions) (return ())
82 |
83 | collide :: Point2 Int -> Point2 Int -> Bool
84 | collide pos0 pos1 =
85 | let distance = vecLength (vecBetween pos0 pos1)
86 | in distance <= fromIntegral diameter
87 |
88 | --drawShip :: DC a -> Point -> IO ()
89 | drawShip :: DC a -> Point -> IO ()
90 | drawShip dc pos = drawBitmap dc ship pos True []
91 |
92 | --drawRock :: DC a -> (Point, Bool) -> IO ()
93 | drawRock :: DC a -> (Point, Bool) -> IO ()
94 | drawRock dc (pos, collides)=
95 | let rockPicture = if collides then burning else rock
96 | in do drawBitmap dc rockPicture pos True []
97 |
98 | rock :: Bitmap ()
99 | rock = bitmap "resources/rock.ico"
100 |
101 | burning :: Bitmap ()
102 | burning = bitmap "resources/burning.ico"
103 |
104 | ship :: Bitmap ()
105 | ship = bitmap "resources/ship.ico"
106 |
107 | main :: IO ()
108 | main = start asteroids
109 |
110 |
--------------------------------------------------------------------------------
/lightoo/src/Examples/ReturnSelfShapeExt.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE CPP, MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances, DeriveDataTypeable, StandaloneDeriving, FlexibleContexts, ExistentialQuantification #-}
2 | {-# OPTIONS -pgmP cpp #-}
3 | module Examples.ReturnSelfShapeExt where
4 |
5 | #ifdef __UHC__
6 | #include "../LightOOUHC.h"
7 | #include "Typeable.h"
8 | #else
9 | #include "../LightOO.h"
10 | #endif
11 |
12 | import LightOO
13 | import Examples.Print
14 | import Data.Typeable
15 | import Data.IORef
16 |
17 | data IShape a = IShape {
18 | getX :: IO Int
19 | , getY :: IO Int
20 | , setX :: Int -> IO ()
21 | , setY :: Int -> IO ()
22 | , moveTo :: Int -> Int -> IO ()
23 | , rMoveTo :: Int -> Int -> IO ()
24 | , draw :: IO ()
25 | , meShape :: ShapeExt
26 | , _shapeTail :: Record a
27 | }
28 | DefineClass(Shape,IShape,shapeTail,,1)
29 |
30 | #ifdef __UHC__
31 | INSTANCE_TYPEABLE1(IShape,shapeTc,"Shape")
32 | #endif
33 |
34 | shape newx newy concreteDraw =
35 | clazz $ \tail self -> do
36 | x <- newIORef newx
37 | y <- newIORef newy
38 | return IShape {
39 | getX = readIORef x
40 | , getY = readIORef y
41 | , setX = writeIORef x
42 | , setY = writeIORef y
43 | , moveTo = \newx newy -> do
44 | self # setX $ newx
45 | self # setY $ newy
46 | , rMoveTo = \deltax deltay -> do
47 | x <- self # getX
48 | y <- self # getY
49 | (self # moveTo) (x + deltax) (y + deltay)
50 | , draw = concreteDraw self
51 | , meShape = ShapeExt $ return self
52 | , _shapeTail = tail
53 | }
54 |
55 | data ShapeExt = forall t. (Sub (Shape_ t) Shape) => ShapeExt (IO (Shape_ t))
56 |
57 | data IRectangle a = IRectangle {
58 | _getWidth :: IO Int
59 | ,_getHeight :: IO Int
60 | ,_setWidth :: Int -> IO ()
61 | ,_setHeight :: Int -> IO ()
62 | ,_meRect :: RectExt
63 | ,_rectangleTail :: Record a
64 | }
65 | DefineSubClass(Rectangle,Shape,IRectangle,rectangleTail,,,,1,)
66 |
67 | #ifdef __UHC__
68 | INSTANCE_TYPEABLE1(IRectangle,rectangleTc,"Rectangle")
69 | #endif
70 |
71 | data RectExt = forall t. (Sub (Rectangle_ t) Rectangle) => RectExt (IO (Rectangle_ t))
72 |
73 | rectangleMethods = unRecord . get_Shape_Tail
74 | getWidth = _getWidth . rectangleMethods
75 | getHeight = _getHeight . rectangleMethods
76 | setWidth = _getWidth . rectangleMethods
77 | setHeight = _getHeight . rectangleMethods
78 | meRect = _meRect . rectangleMethods
79 |
80 | rectangle x y width height =
81 | (wrapper `extends` shape x y draw) noOverride set_Shape_Tail
82 | where
83 | wrapper tail super self = do
84 | w <- newIORef width
85 | h <- newIORef height
86 | return IRectangle {
87 | _getWidth = readIORef w
88 | , _getHeight = readIORef h
89 | , _setWidth = writeIORef w
90 | , _setHeight = writeIORef h
91 | , _meRect = RectExt $ return self
92 | , _rectangleTail = tail
93 | }
94 |
95 | draw self = printLn ("Drawing a Rectangle at:(" <<
96 | self # getX << ", " << self # getY <<
97 | "), width " << self # getWidth <<
98 | ", height " << self # getHeight)
99 |
100 | mySelf = do
101 | s1 <- new $ rectangle 10 20 5 6
102 | let m = s1 # meShape
103 | case m of
104 | ShapeExt m -> do s1 <- m
105 | s1 # draw
106 | let shape = upcast s1 :: Shape
107 | let Just s1 = downcast shape :: Maybe Rectangle
108 | s1 # getWidth >>= putStrLn . show
109 |
110 |
111 |
--------------------------------------------------------------------------------
/wxasteroids/contravariant-0.1.2/Data/Functor/Contravariant.hs:
--------------------------------------------------------------------------------
1 | -----------------------------------------------------------------------------
2 | -- |
3 | -- Module : Data.Functor.Contravariant
4 | -- Copyright : (C) 2007-2011 Edward Kmett
5 | -- License : BSD-style (see the file LICENSE)
6 | --
7 | -- Maintainer : Edward Kmett
8 | -- Stability : provisional
9 | -- Portability : portable
10 | --
11 | -- 'Contravariant' functors, sometimes referred to colloquially as @Cofunctor@,
12 | -- even though the dual of a 'Functor' is just a 'Functor'. As with 'Functor'
13 | -- the definition of 'Contravariant' for a given ADT is unambiguous.
14 | ----------------------------------------------------------------------------
15 |
16 | module Data.Functor.Contravariant (
17 | -- * Contravariant Functors
18 | Contravariant(..)
19 | {-
20 | -- * Predicates
21 | , Predicate(..)
22 |
23 | -- * Comparisons
24 | , Comparison(..)
25 | , defaultComparison
26 |
27 | -- * Equivalence Relations
28 | , Equivalence(..)
29 | , defaultEquivalence
30 |
31 | -- * Dual arrows
32 | , Op(..)
33 | -}
34 | ) where
35 |
36 | import Control.Applicative
37 | {-
38 | import Data.Functor.Product
39 | import Data.Functor.Constant
40 | -}
41 | -- | Any instance should be subject to the following laws:
42 | --
43 | -- > contramap id = id
44 | -- > contramap f . contramap g = contramap (g . f)
45 | --
46 | -- Note, that the second law follows from the free theorem of the type of
47 | -- 'contramap' and the first law, so you need only check that the former
48 | -- condition holds.
49 |
50 | class Contravariant f where
51 | contramap :: (a -> b) -> f b -> f a
52 |
53 |
54 | {-
55 | newtype Predicate a = Predicate { getPredicate :: a -> Bool }
56 | -- | A 'Predicate' is a 'Contravariant' 'Functor', because 'contramap' can
57 | -- apply its function argument to the input of the predicate.
58 | instance Contravariant Predicate where
59 | contramap f g = Predicate $ getPredicate g . f
60 |
61 |
62 |
63 | -- | Defines a total ordering on a type as per 'compare'
64 | newtype Comparison a = Comparison { getComparison :: a -> a -> Ordering }
65 |
66 | -- | A 'Comparison' is a 'Contravariant' 'Functor', because 'contramap' can
67 | -- apply its function argument to each input to each input to the
68 | -- comparison function.
69 | instance Contravariant Comparison where
70 | contramap f g = Comparison $ \a b -> getComparison g (f a) (f b)
71 |
72 | -- | Compare using 'compare'
73 | defaultComparison :: Ord a => Comparison a
74 | defaultComparison = Comparison compare
75 |
76 |
77 |
78 | -- | Define an equivalence relation
79 | newtype Equivalence a = Equivalence { getEquivalence :: a -> a -> Bool }
80 | -- | Equivalence relations are 'Contravariant', because you can
81 | -- apply the contramapped function to each input to the equivalence
82 | -- relation.
83 | instance Contravariant Equivalence where
84 | contramap f g = Equivalence $ \a b -> getEquivalence g (f a) (f b)
85 |
86 | -- | Check for equivalence with '=='
87 | defaultEquivalence :: Eq a => Equivalence a
88 | defaultEquivalence = Equivalence (==)
89 |
90 | -- | Dual function arrows.
91 | newtype Op a b = Op { getOp :: b -> a }
92 |
93 | instance Contravariant (Op a) where
94 | contramap f g = Op (getOp g . f)
95 |
96 | -- | Data.Functor.Product
97 | instance (Contravariant f, Contravariant g) => Contravariant (Product f g) where
98 | contramap f (Pair a b) = Pair (contramap f a) (contramap f b)
99 |
100 | -- | Data.Functor.Constant
101 | instance Contravariant (Constant a) where
102 | contramap _ (Constant a) = Constant a
103 |
104 | -- | Control.Applicative.Const
105 | instance Contravariant (Const a) where
106 | contramap _ (Const a) = Const a
107 | -}
--------------------------------------------------------------------------------
/uhc-js/uhc-js/src/Language/UHC/JS/Backbone/Collection.hs:
--------------------------------------------------------------------------------
1 | module Language.UHC.JS.Backbone.Collection where
2 |
3 | import Language.UHC.JS.Backbone.Model
4 | import Language.UHC.JS.ECMA.Array
5 | import Language.UHC.JS.ECMA.String
6 | import Language.UHC.JS.Primitives
7 | import Language.UHC.JS.Types
8 | import Language.UHC.JS.Marshal
9 | import Language.UHC.JS.Prelude
10 |
11 | data BBCollectionPtr a
12 | type BBCollection a = JSObject_ (BBCollectionPtr a)
13 |
14 | foreign import js "Backbone.Collection.extend(%*)"
15 | extend :: JSObject_ a -> IO (JSFunction_ b)
16 |
17 | foreign import js "Backbone.Collection.extend(%*)"
18 | extend' :: JSObject_ a -> JSObject_ b -> IO (JSFunction_ b)
19 |
20 | model :: JSFunction_ b -> BBCollection a -> IO (BBCollection a)
21 | model = setAttr "model"
22 |
23 | models :: BBCollection a -> IO (JSArray (BBModel b))
24 | models = getAttr "models"
25 |
26 | foreign import js "%1.toJSON()"
27 | toJSON :: BBCollection a -> IO (JSArray b)
28 |
29 | -- TODO: Underscore methods
30 |
31 | foreign import js "%1.add(%*)"
32 | add :: BBCollection a -> BBModel b -> IO ()
33 |
34 | foreign import js "%1.add(%*)"
35 | add' :: BBCollection a -> BBModel b -> JSObject_ c -> IO ()
36 |
37 | foreign import js "%1.add(%*)"
38 | addA :: BBCollection a -> JSArray (BBModel b) -> IO ()
39 |
40 | foreign import js "%1.add(%*)"
41 | addA' :: BBCollection a -> JSArray (BBModel b) -> JSObject_ c -> IO ()
42 |
43 | foreign import js "%1.remove(%*)"
44 | remove :: BBCollection a -> BBModel b -> IO ()
45 |
46 | foreign import js "%1.remove(%*)"
47 | remove' :: BBCollection a -> BBModel b -> JSObject_ c -> IO ()
48 |
49 | foreign import js "%1.remove(%*)"
50 | removeA :: BBCollection a -> JSArray (BBModel b) -> IO ()
51 |
52 | foreign import js "%1.remove(%*)"
53 | removeA' :: BBCollection a -> JSArray (BBModel b) -> JSObject_ c -> IO ()
54 |
55 | foreign import js "%1.get(%*)"
56 | get :: BBCollection a -> Int -> IO (BBModel b)
57 |
58 |
59 | getByCid :: String -> BBCollection a -> IO (BBModel b)
60 | getByCid s c = _getByCid (toJS s) c
61 |
62 | foreign import js "%1.getByCid(%*)"
63 | _getByCid :: JSString -> BBCollection a -> IO (BBModel b)
64 |
65 |
66 | foreign import js "%1.at(%*)"
67 | at :: Int -> IO (BBModel a)
68 |
69 | clength :: BBCollection a -> IO Int
70 | clength = getAttr "length"
71 |
72 | setComperator :: JSFunction_ a -> BBCollection b -> IO (BBCollection b)
73 | setComperator = setAttr "comparator"
74 |
75 |
76 | foreign import js "%1.sort()"
77 | sort :: BBCollection a -> IO ()
78 |
79 | foreign import js "%1.sort(%*)"
80 | sort' :: BBCollection a -> JSFunction_ b -> IO ()
81 |
82 | pluck :: BBCollection a -> String -> IO (JSArray b)
83 | pluck c s = _pluck c (toJS s)
84 |
85 | foreign import js "%1.pluck(%*)"
86 | _pluck :: BBCollection a -> JSString -> IO (JSArray b)
87 |
88 | setUrl :: String -> BBCollection a -> IO (BBCollection a)
89 | setUrl s m = setAttr "url" s' m
90 | where s' :: JSString
91 | s' = toJS s
92 |
93 | setUrl' :: JSFunction_ b -> BBCollection a -> IO (BBCollection a)
94 | setUrl' = setAttr "url"
95 |
96 | -- TODO: parse
97 |
98 | foreign import js "%1.fetch()"
99 | fetch :: BBCollection a -> IO ()
100 |
101 | foreign import js "%1.fetch(%*)"
102 | fetch' :: BBCollection a -> JSFunction_ b -> IO ()
103 |
104 | foreign import js "%1.reset(%*)"
105 | reset :: BBCollection a -> JSArray (BBModel b) -> IO ()
106 |
107 | foreign import js "%1.reset(%*)"
108 | reset' :: BBCollection a -> JSArray (BBModel b) -> JSFunction_ c -> IO ()
109 |
110 | foreign import js "%1.create(%*)"
111 | create :: BBCollection a -> JSArray (BBModel b) -> IO ()
112 |
113 | foreign import js "%1.create(%*)"
114 | create' :: BBCollection a -> JSArray (BBModel b) -> JSFunction_ c -> IO ()
115 |
--------------------------------------------------------------------------------
/uhc-js/uhc-js/src/Language/UHC/JS/HTML5/Node.hs:
--------------------------------------------------------------------------------
1 | {-
2 | interface Node : EventTarget {
3 | const unsigned short ELEMENT_NODE = 1;
4 | const unsigned short ATTRIBUTE_NODE = 2; // historical
5 | const unsigned short TEXT_NODE = 3;
6 | const unsigned short CDATA_SECTION_NODE = 4; // historical
7 | const unsigned short ENTITY_REFERENCE_NODE = 5; // historical
8 | const unsigned short ENTITY_NODE = 6; // historical
9 | const unsigned short PROCESSING_INSTRUCTION_NODE = 7;
10 | const unsigned short COMMENT_NODE = 8;
11 | const unsigned short DOCUMENT_NODE = 9;
12 | const unsigned short DOCUMENT_TYPE_NODE = 10;
13 | const unsigned short DOCUMENT_FRAGMENT_NODE = 11;
14 | const unsigned short NOTATION_NODE = 12; // historical
15 | readonly attribute unsigned short nodeType;
16 | readonly attribute DOMString nodeName;
17 |
18 | readonly attribute DOMString? baseURI;
19 |
20 | readonly attribute Document? ownerDocument;
21 | readonly attribute Node? parentNode;
22 | readonly attribute Element? parentElement;
23 | boolean hasChildNodes();
24 | readonly attribute NodeList childNodes;
25 | readonly attribute Node? firstChild;
26 | readonly attribute Node? lastChild;
27 | readonly attribute Node? previousSibling;
28 | readonly attribute Node? nextSibling;
29 |
30 | const unsigned short DOCUMENT_POSITION_DISCONNECTED = 0x01;
31 | const unsigned short DOCUMENT_POSITION_PRECEDING = 0x02;
32 | const unsigned short DOCUMENT_POSITION_FOLLOWING = 0x04;
33 | const unsigned short DOCUMENT_POSITION_CONTAINS = 0x08;
34 | const unsigned short DOCUMENT_POSITION_CONTAINED_BY = 0x10;
35 | const unsigned short DOCUMENT_POSITION_IMPLEMENTATION_SPECIFIC = 0x20; // historical
36 | unsigned short compareDocumentPosition(Node other);
37 | boolean contains(Node? other);
38 |
39 | attribute DOMString? nodeValue;
40 | attribute DOMString? textContent;
41 | Node insertBefore(Node node, Node? child);
42 | Node_ appendChild(Node node);
43 | Node replaceChild(Node node, Node child);
44 | Node removeChild(Node child);
45 | void normalize();
46 |
47 |
48 | Node cloneNode(optional boolean deep = true);
49 | boolean isEqualNode(Node? node);
50 |
51 | DOMString lookupPrefix(DOMString? namespace);
52 | DOMString lookupNamespaceURI(DOMString? prefix);
53 | boolean isDefaultNamespace(DOMString? namespace);
54 | };
55 | -}
56 | module Language.UHC.JS.HTML5.Node where
57 |
58 | import Language.UHC.JS.HTML5.Types
59 | import Language.UHC.JS.Types
60 |
61 | foreign import js "%1.nodeType"
62 | nodeType :: Node_ a -> IO Int
63 |
64 | foreign import js "%1.ownerDocument"
65 | ownerDocument :: Node_ a -> IO HTMLDocument
66 |
67 | foreign import js "%1.parentNode"
68 | parentNode :: Node_ a -> IO Node
69 |
70 | foreign import js "%1.parentElement"
71 | parentElement :: Node_ a -> IO Element
72 |
73 | foreign import js "%1.hasChildNodes()"
74 | hasChildNodes :: Node_ a -> IO JSBool
75 |
76 | foreign import js "%1.firstChild"
77 | firstChild :: Node_ a -> IO Node
78 |
79 | foreign import js "%1.lastChild"
80 | lastChild :: Node_ a -> IO Node
81 |
82 | foreign import js "%1.previousSibling"
83 | previousSibling :: Node_ a -> IO Node
84 |
85 | foreign import js "%1.nextSibling"
86 | nextSibling :: Node_ a -> IO Node
87 |
88 | foreign import js "%1.contains(%*)"
89 | contains :: Node_ a -> IO JSBool
90 |
91 | foreign import js "%1.nodeValue"
92 | nodeValue :: Node_ a -> IO JSString
93 |
94 | foreign import js "%1.textContent"
95 | textContent :: Node_ a -> IO JSString
96 |
97 | foreign import js "%1.insertBefore(%*)"
98 | insertBefore :: Node_ a -> Node_ b -> Node_ c -> IO Node
99 |
100 | foreign import js "%1.appendChild(%*)"
101 | appendChild :: Node_ a -> Node_ b -> IO Node
102 |
103 | foreign import js "%1.replaceChild(%*)"
104 | replaceChild :: Node_ a -> Node_ n -> Node_ c -> IO Node
105 |
106 | foreign import js "%1.removeChild(%*)"
107 | removeChild :: Node_ a -> Node b -> IO Node
--------------------------------------------------------------------------------
/lightoo/src/Examples/Triplet.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE CPP, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, UndecidableInstances, ScopedTypeVariables, StandaloneDeriving, DeriveDataTypeable #-}
2 | {-# OPTIONS -pgmP cpp #-}
3 | module Examples.Triplet where
4 |
5 | #ifdef __UHC__
6 | #include "../LightOOUHC.h"
7 | #include "Typeable.h"
8 | #else
9 | #include "../LightOO.h"
10 | #endif
11 |
12 | import LightOO
13 | import Data.Typeable
14 |
15 | data IPair a b t = IPair {
16 | _pairGetFirst :: IO a
17 | ,_pairGetSecond :: IO b
18 | ,_pairTail :: Record t
19 | }
20 |
21 | DefineSubClass(Pair,Object,IPair,pairTail,a b,,a b,3,(Typeable a, Typeable b))
22 |
23 | #ifdef __UHC__
24 | INSTANCE_TYPEABLE3(IPair,pairTc,"Pair")
25 | #endif
26 |
27 | pairMethods = unRecord . get_Object_Tail
28 | pairGetFirst = _pairGetFirst . pairMethods
29 | pairGetSecond = _pairGetSecond . pairMethods
30 |
31 | pair a b =
32 | (pair' `extends` object) noOverride set_Object_Tail
33 | where
34 | pair' tail super self =
35 | return IPair {
36 | _pairGetFirst = return a
37 | ,_pairGetSecond = return b
38 | ,_pairTail = tail
39 | }
40 |
41 | data ITriplet a b c t = ITriplet {
42 | _tripletGetThird :: IO c
43 | ,_tripletSwap :: IO (Triplet b a c)
44 | ,_tripletTail :: Record t
45 | }
46 |
47 | DefineSubClass(Triplet,Pair,ITriplet,tripletTail,a b c,a b,a b c,4,(Typeable a, Typeable b, Typeable c))
48 |
49 | #ifdef __UHC__
50 | INSTANCE_TYPEABLE4(ITriplet,tripletTc,"Triplet")
51 | #endif
52 |
53 | tripletGetThird = _tripletGetThird . unRecord . get_Pair_Tail
54 | tripletSwap = _tripletSwap . unRecord . get_Pair_Tail
55 |
56 | triplet
57 | :: a
58 | -> b
59 | -> c
60 | -> OpenClass (Record tail) self (Pair_ a b (ITriplet a b c tail))
61 | triplet a b c =
62 | (triplet' `extends` pair a b) noOverride set_Pair_Tail
63 | where
64 | triplet' tail super self =
65 | return ITriplet {
66 | _tripletGetThird = return c
67 | ,_tripletSwap = new $ triplet b a c
68 | ,_tripletTail = tail
69 | }
70 |
71 | myOOPair = do
72 | p <- new $ pair (0 :: Int) (3.0 :: Double)
73 | let o = upcast p :: Object
74 | let Just p = downcast o :: Maybe (Pair Int Double)
75 | p # pairGetFirst >>= putStrLn . show
76 | t <- new $ triplet (0 :: Int) (1 :: Int) (2 :: Int)
77 | return ()
78 |
79 | projectPair :: Pair (Pair a b) c -> IO (Pair a b)
80 | projectPair p = p # pairGetFirst
81 |
82 | test :: Triplet a b String -> IO ()
83 | test o = o # tripletGetThird >>= putStrLn
84 |
85 | myOOTriplet' = do
86 | p <- new $ pair (0 :: Int) (3.0 :: Double)
87 | t <- new $ triplet (0 :: Int) (4.0 :: Double) "Hi"
88 |
89 | let pairs :: [Pair Int Double]
90 | pairs = consUb t (consUb p nilUb)
91 |
92 | sequence_ $ map (\p -> p # pairGetFirst >>= print) pairs
93 |
94 | t' <- t # tripletSwap
95 | t' # pairGetFirst >>= print
96 |
97 | myOOTriplet = do
98 | p <- new $ pair (0 :: Int) (3.0 :: Double)
99 | p # pairGetFirst >>= print
100 | nestedPair <- new $ pair p "Hi"
101 | nestedPair # pairGetSecond >>= putStrLn
102 |
103 | (p `sameObject` p) >>= print
104 | (p `sameObject` nestedPair) >>= print
105 |
106 | let o = upcast p :: Object
107 |
108 | let Just p' = downcast o :: Maybe (Pair Int Double)
109 | p' # pairGetFirst >>= print
110 |
111 | t <- new $ triplet (0 :: Int) (4.0 :: Double) "Hi"
112 | let tp = upcast t :: Pair Int Double
113 | let o = upcast t :: Object
114 |
115 | let t' = downcast o :: Maybe (Pair Int Double)
116 | let Just t'' = downcast o :: Maybe (Triplet Int Double String)
117 | t'' # tripletGetThird >>= putStrLn
118 |
119 | let xs :: [Pair Int Double]
120 | xs = consUb t'' (consUb p nilUb)
121 |
122 | sequence_ $ map (\p -> p # pairGetFirst >>= print) xs
123 | test t''
124 |
125 | --let sillydown = downcast t'' :: Maybe Object
126 |
127 | t'' # tripletSwap
128 |
--------------------------------------------------------------------------------
/lightoo/src/Examples/ListSimpleSelf.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE CPP, MultiParamTypeClasses, FlexibleInstances, DeriveDataTypeable, StandaloneDeriving, FlexibleContexts, ScopedTypeVariables, NoMonomorphismRestriction #-}
2 | {-# OPTIONS -pgmP cpp #-}
3 | module Examples.ListSimpleSelf where
4 | import LightOO
5 | import Data.Dynamic
6 | import Data.IORef
7 |
8 | #ifdef __UHC__
9 | #include "../LightOOUHC.h"
10 | #include "Typeable.h"
11 | #else
12 | #include "../LightOO.h"
13 | #endif
14 |
15 | data IList a = IList
16 | { _listIsEmpty :: IO Bool
17 | , _listGetHead :: IO String
18 | , _listGetTail :: IO List
19 | , _listSetHead :: String -> IO ()
20 | , _listInsHead :: String -> IO List
21 | , _listTail :: Record a
22 | }
23 |
24 | DefineClass(List,IList,listTail,,1)
25 |
26 | #ifdef __UHC__
27 | INSTANCE_TYPEABLE1(IList,listTc,"List")
28 | #endif
29 |
30 | listIsEmpty = _listIsEmpty
31 | listGetHead = _listGetHead
32 | listGetTail = _listGetTail
33 | listSetHead = _listSetHead
34 | listInsHead = _listInsHead
35 |
36 | nilList = clazz $ \tail self -> do
37 | return IList {
38 | _listIsEmpty = return True
39 | ,_listGetHead = fail "no head"
40 | ,_listGetTail = self # listIsEmpty >> fail "no tail"
41 | ,_listSetHead = const (fail "no head")
42 | ,_listInsHead = reusableInsHead self
43 | ,_listTail = tail
44 | }
45 |
46 | reusableInsHead :: (Sub (IList a) List) => IList a -> String -> IO List
47 | reusableInsHead list head = do
48 | newCons <- new $ consList head (upcast list :: List)
49 | return newCons
50 | {-
51 | consList :: (ListClass a :<: List) =>
52 | String -> List -> IO (ListClass a -> Record b) -> ListClass a -> IO (IList b)
53 | -}
54 | consList head t = clazz $ \tail self -> do
55 | hRef <- newIORef head
56 | return IList {
57 | _listIsEmpty = return False
58 | ,_listGetHead = readIORef hRef
59 | ,_listGetTail = return t
60 | ,_listSetHead = writeIORef hRef
61 | ,_listInsHead = reusableInsHead self
62 | ,_listTail = tail
63 | }
64 |
65 | data IReverseList a = IReverseList {
66 | _reverseListEcho :: IO ()
67 | ,_reverseListTail :: Record a
68 | }
69 | DefineSubClass(ReverseList,List,IReverseList,reverseListTail,,,,1,)
70 |
71 | #ifdef __UHC__
72 | INSTANCE_TYPEABLE1(IReverseList,reverseListTc,"ReverseList")
73 | #endif
74 |
75 | {-
76 | nilReverseList :: (ReverseList_ a :<: List) =>
77 | IO (ReverseList_ a -> Record b) -> ReverseList_ a -> IO (ReverseList_ b)
78 | -}
79 | nilReverseList =
80 | (wrapper `extends` nilList) noOverride set_List_Tail
81 | where
82 | wrapper tail super self =
83 | return IReverseList {
84 | _reverseListEcho = putStrLn "I'm a reverse cons"
85 | ,_reverseListTail = tail
86 | }
87 |
88 | reverseListEcho = _reverseListEcho . unRecord . _listTail
89 |
90 | {-
91 | consReverseList :: (ReverseList_ a :<: List) =>
92 | String -> ReverseList -> IO (ReverseList_ a -> Record b) -> ReverseList_ a -> IO (ReverseList_ b) -}
93 | consReverseList head tail =
94 | (wrapper `extends` consList (reverse head) (upcast tail :: List)) noOverride set_List_Tail
95 | where
96 | wrapper tail super self =
97 | return IReverseList {
98 | _reverseListEcho = putStrLn "I'm a reverse cons"
99 | ,_reverseListTail = tail
100 | }
101 |
102 | hiList' = do
103 | l <- new nilReverseList
104 | l <- new $ consReverseList "dlrow" l
105 | l <- new $ consReverseList "olleh" l
106 | return l
107 |
108 | hiList = do
109 | l <- new nilList
110 | l <- new $ consList "2" l
111 | l <- new $ consList "4" l
112 | return l
113 |
114 | sayHi ls = do
115 | l <- ls
116 | printList (upcast l :: List)
117 |
118 | printList aList = do
119 | empty <- aList # listIsEmpty
120 | if empty
121 | then putStrLn ""
122 | else do
123 | head <- aList # listGetHead
124 | putStr $ head
125 | tail <- aList # listGetTail
126 | putStr " "
127 | printList tail
128 |
129 |
--------------------------------------------------------------------------------
/wxasteroids/src/Graphics/UI/WX/Media.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
2 | --------------------------------------------------------------------------------
3 | {-| Module : Media
4 | Copyright : (c) Daan Leijen 2003
5 | (c) shelarcy 2007
6 | License : wxWindows
7 |
8 | Maintainer : wxhaskell-devel@lists.sourceforge.net
9 | Stability : provisional
10 | Portability : portable
11 |
12 | Images, Media, Sounds, and action!
13 | -}
14 | --------------------------------------------------------------------------------
15 | module Graphics.UI.WX.Media where
16 |
17 | import System.IO.Unsafe( unsafePerformIO )
18 | import LightOO
19 | import qualified Graphics.UI.WXCore.GraphicsBitmap as B
20 | --import Graphics.UI.WX.Types( Var, varGet, varSet, varCreate )
21 | --import Graphics.UI.WX.Attributes
22 | --import Graphics.UI.WX.Classes
23 |
24 | {--------------------------------------------------------------------
25 | Bitmaps
26 | --------------------------------------------------------------------}
27 | -- | Return a managed bitmap object. Bitmaps are abstract images used
28 | -- for drawing to a device context. The file path should point to
29 | -- a valid bitmap file, normally a @.ico@, @.bmp@, @.xpm@, or @.png@,
30 | -- but any file format supported by |Image| is correctly loaded.
31 | --
32 | -- Instances: 'Sized'.
33 | --bitmap :: FilePath -> Bitmap
34 | --bitmap :: String -> Bitmap
35 | bitmap :: String -> B.GraphicsBitmap
36 | bitmap fname = unsafePerformIO (new $ B.bitmap fname)
37 | --bitmap fname
38 | -- = unsafePerformIO $ bitmapCreateFromFile fname
39 |
40 | --instance Sized (Bitmap a) where
41 | --size = newAttr "size" bitmapGetSize bitmapSetSize
42 |
43 | -- | Create a bitmap from an image with the same color depth.
44 | --bitmapFromImage :: Image_ a -> IO Bitmap
45 | --bitmapFromImage = error "bitmapFromImage not implemented"
46 | --bitmapFromImage image
47 | -- = bitmapCreateFromImage image (-1)
48 |
49 | {--------------------------------------------------------------------
50 | Images
51 | --------------------------------------------------------------------}
52 | -- | Return a managed image. Images are platform independent representations
53 | -- of pictures, using an array of rgb pixels. See "Graphics.UI.WXCore.Image" for
54 | -- lowlevel pixel manipulation. The file path should point to
55 | -- a valid image file, like @.jpg@, @.bmp@, @.xpm@, or @.png@, for example.
56 | --
57 | -- Instances: 'Sized'.
58 | --image :: FilePath -> Image
59 | --image = error "image not implemented"
60 | --image fname
61 | -- = unsafePerformIO $ imageCreateFromFile fname
62 |
63 | --instance Sized (Image a) where
64 | -- size = newAttr "size" imageGetSize imageRescale
65 |
66 | {--------------------------------------------------------------------
67 | Media
68 | --------------------------------------------------------------------}
69 | -- | Abstract layer between 'MediaCtrl' and 'Sound'. This class intends to
70 | -- avoid breaking backward-compatibility.
71 | --class Media w where
72 | -- -- | If use this method with 'Sound', play a sound fragment asynchronously.
73 | -- -- If use this method with 'MediaCtrl', play media that is loaded by
74 | -- -- 'mediaCtrlLoad'.
75 | -- play :: w -> IO ()
76 | -- stop :: w -> IO ()
77 |
78 | {--------------------------------------------------------------------
79 | Sounds
80 | --------------------------------------------------------------------}
81 | -- | Return a managed sound object. The file path points to
82 | -- a valid sound file, normally a @.wav@.
83 | --sound :: FilePath -> Sound ()
84 | --sound fname
85 | -- = unsafePerformIO $ soundCreate fname False
86 |
87 | --instance Media (Sound a) where
88 | -- play sound = unitIO (soundPlay sound wxSOUND_ASYNC)
89 | -- stop = soundStop
90 |
91 | ---- | Play a sound fragment repeatedly (and asynchronously).
92 | --playLoop :: Sound a -> IO ()
93 | --playLoop sound
94 | -- = unitIO (soundPlay sound $ wxSOUND_ASYNC .+. wxSOUND_LOOP)
95 |
96 | ---- | Play a sound fragment synchronously (i.e. wait till completion).
97 | --playWait :: Sound a -> IO ()
98 | --playWait sound
99 | -- = unitIO (soundPlay sound wxSOUND_SYNC)
100 |
101 |
--------------------------------------------------------------------------------
/wxasteroids/src/Asteroids.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE CPP #-}
2 | {-# OPTIONS -pgmP cpp #-}
3 | module Asteroids where
4 |
5 | import Graphics.UI.WX
6 | import Graphics.UI.WXCore hiding (window,bitmap)
7 | import Control.Monad
8 | #ifdef __UHC__
9 | import Language.UHC.JS.Marshal
10 | import Language.UHC.JS.Types
11 | import Language.UHC.JS.Prelude
12 |
13 | foreign import js "Math.random()"
14 | random :: IO Double
15 | #else
16 | random = undefined
17 | _trace = undefined
18 | str = undefined
19 | #endif
20 |
21 | rand _ = unsafePerformIO random
22 |
23 | randoms :: [Double]
24 | randoms =
25 | let inf = undefined : inf
26 | in map rand inf
27 |
28 | height :: Int
29 | height = 300
30 |
31 | width :: Int
32 | width = 300
33 |
34 | diameter :: Int
35 | diameter = 24
36 |
37 | chance :: Double
38 | chance = 0.1
39 |
40 | asteroids :: IO ()
41 | asteroids =
42 | do
43 | vrocks <- varCreate randomRocks
44 | vship <- varCreate $ div width 2
45 |
46 | w <- window Nothing [area := rect (pt 0 0) (sz width height)]
47 |
48 | t <- timer w [ interval := 50
49 | , on command := advance vrocks w
50 | ]
51 |
52 | set w [
53 | on paint := draw vrocks vship
54 | , on leftKey := varUpdate vship (\x -> max 0 (x - 5)) >> return ()
55 | , on rightKey := varUpdate vship (\x -> min width (x + 5)) >> return ()
56 | , on (charKey 'q') := set t [interval :~ \i -> i * 2]
57 | , on (charKey 'w') := (_trace (str "slowdown") >> set t [interval :~ \i -> max 10 (div i 2)])
58 | ]
59 |
60 | --advance :: (Textual w, Paint w1) => w -> Var [[a]] -> w1 -> IO ()
61 | advance :: (Paint w) => Var [[a]] -> w -> IO ()
62 | advance vrocks f =
63 | do
64 | (r : rs) <- varGet vrocks
65 | varSet vrocks rs
66 | repaint f
67 |
68 | randomRocks = flatten [] (map fresh randoms)
69 |
70 | flatten :: [[a]] -> [[[a]]] -> [[a]]
71 | flatten rocks (t : ts) =
72 | let now = map head rocks
73 | later = filter (not . null) (map tail rocks)
74 | in now : flatten (t ++ later) ts
75 | flatten rocks [] = error "Empty rocks list not expected in function flatten"
76 |
77 | fresh :: Double -> [[Point2 Int]]
78 | fresh r
79 | | r > chance = []
80 | | otherwise = [track (floor (fromIntegral width * r / chance))]
81 |
82 | track :: Int -> [Point2 Int]
83 | track x = [point x (y - diameter) | y <- [0, 6 .. height + 2 * diameter]]
84 |
85 | --draw :: Var [[Point2 Int]] -> Var Int -> DC a -> b -> IO ()
86 | draw :: Var [[Point2 Int]] -> Var Int -> GraphicsContext -> b -> IO ()
87 | draw vrocks vship dc _view =
88 | do
89 | rocks <- varGet vrocks
90 | x <- varGet vship
91 | let
92 | shipLocation = point x (height - 2 * diameter)
93 | positions = head rocks
94 | collisions = map (collide shipLocation) positions
95 |
96 | drawShip dc shipLocation
97 | mapM (drawRock dc) (zip positions collisions)
98 | --when (or collisions) (play explode)
99 | when (or collisions) (return ())
100 |
101 | collide :: Point2 Int -> Point2 Int -> Bool
102 | collide pos0 pos1 =
103 | let distance = vecLength (vecBetween pos0 pos1)
104 | in distance <= fromIntegral diameter
105 |
106 | --drawShip :: DC a -> Point -> IO ()
107 | drawShip :: GraphicsContext_ a -> Point -> IO ()
108 | drawShip dc pos = drawBitmap dc ship pos True []
109 |
110 | --drawRock :: DC a -> (Point, Bool) -> IO ()
111 | drawRock :: GraphicsContext_ a -> (Point, Bool) -> IO ()
112 | drawRock dc (pos, collides)=
113 | let rockPicture = if collides then burning else rock
114 | in do --consoleLog (str (show (pointX pos) ++ "," ++ show (pointY pos)))
115 | drawBitmap dc rockPicture pos True []
116 |
117 | rock :: GraphicsBitmap
118 | rock = bitmap "../resources/rock.ico"
119 |
120 | burning :: GraphicsBitmap
121 | burning = bitmap "../resources/burning.ico"
122 |
123 | ship :: GraphicsBitmap
124 | ship = bitmap "../resources/ship.ico"
125 |
126 | main :: IO ()
127 | main = start asteroids
128 |
129 |
--------------------------------------------------------------------------------
/wxasteroids/src/Graphics/UI/WXCore/EvtHandler.hs:
--------------------------------------------------------------------------------
1 | module Graphics.UI.WXCore.EvtHandler (
2 | module Graphics.UI.WXCore.EvtHandlerClass
3 | ,evthandler
4 | ) where
5 |
6 | import Graphics.UI.WXCore.EventClass
7 | import Graphics.UI.WXCore.EvtHandlerClass
8 | import Graphics.UI.WXCore.Types
9 | import LightOO
10 | import Data.IORef
11 |
12 | a `onlyIf` b = do
13 | a' <- a
14 | if a' then b else return False
15 |
16 | lookupEntryByEventType t = filter $ (t ==) . dynamicEventTableEntryEventType
17 |
18 | evthandler =
19 | (evthandler' `extends` object) noOverride set_Object_Tail
20 | where
21 | evthandler' tail super self = do
22 | handlers <- newIORef []
23 | return EvtHandlerClass {
24 | _evtHandlerAddPendingEvent = error "_evtHandlerAddPendingEvent not implemented"
25 | , _evtHandlerBind = \evtty f id lastId -> do
26 | let entry = DynamicEventTableEntry {
27 | dynamicEventTableEntryEventType = evtty
28 | ,dynamicEventTableEntryId = id
29 | ,dynamicEventTableEntryLastId = lastId
30 | ,dynamicEventTableEntryFunc = f
31 | ,dynamicEventTableEntryUserData = error "dynamicEventTableEntryUserData not implemented"
32 | }
33 | modifyIORef handlers (entry :)
34 |
35 | , _evtGetHandler = \evtty id lid ->
36 | let findHandler entry =
37 | let eid = dynamicEventTableEntryId entry
38 | elid = dynamicEventTableEntryLastId entry
39 | eevtty = dynamicEventTableEntryEventType entry
40 | in eid == id && (elid == lid || lid == wxID_ANY) && (eevtty == evtty)
41 |
42 | maybeHead [] = Nothing
43 | maybeHead (entry:_) = Just (dynamicEventTableEntryFunc entry)
44 |
45 | in readIORef handlers >>= return . maybeHead . filter findHandler
46 |
47 | , _evtHandlerUnBind = \evtty id lid ->
48 | let doUnbind entry =
49 | let eid = dynamicEventTableEntryId entry
50 | elid = dynamicEventTableEntryLastId entry
51 | eevtty = dynamicEventTableEntryEventType entry
52 | in not $ (eid == id && (elid == lid || lid == wxID_ANY) && (eevtty == evtty))
53 | in modifyIORef handlers (filter doUnbind)
54 |
55 | , _evtHandlerDeletePendingEvents = error "_evtHandlerDeletePendingEvents not implemented"
56 | , _evtHandlerGetEvtHandlerEnabled = error "_evtHandlerGetEvtHandlerEnabled not implemented"
57 | , _evtHandlerGetNextHandler = error "_evtHandlerGetNextHandler not implemented"
58 | , _evtHandlerGetPreviousHandler = error "_evtHandlerGetPreviousHandler not implemented"
59 | , _evtHandlerIsUnlinked = error "_evtHandlerIsUnlinked not implemented"
60 | , _evtHandlerProcessEvent = \evt ->
61 | let before = return True
62 | processLocally = self # evtHandlerProcessEventLocally $ evt
63 | after = return True
64 | in before `onlyIf` processLocally `onlyIf` after
65 |
66 | , _evtHandlerProcessEventLocally = \evt ->
67 | let processEventIfMatchesId entry = do
68 | let id = dynamicEventTableEntryId entry
69 | lid = dynamicEventTableEntryLastId entry
70 | eid <- evt # eventGetId
71 | if ((id == wxID_ANY) || (lid == wxID_ANY && id == eid) || (lid /= wxID_ANY && (eid >= id && eid <= lid)))
72 | then do evt # eventSkip $ False
73 | -- set callback data
74 | (dynamicEventTableEntryFunc entry) evt
75 | return True
76 | else return True
77 |
78 | in do entries <- readIORef handlers
79 | eventType <- evt # eventGetType
80 | let matchingHandlers = lookupEntryByEventType eventType entries
81 | mapM_ processEventIfMatchesId matchingHandlers
82 | return True
83 |
84 | , _evtHandlerProcessPendingEvents = error "_evtHandlerProcessPendingEvents not implemented"
85 | , _evtHandlerQueueEvent = error "_evtHandlerQueueEvent not implemented"
86 | , _evtHandlerSetEvtHandlerEnabled = error "_evtHandlerSetEvtHandlerEnabled not implemented"
87 | , _evtHandlerSetNextHandler = error "_evtHandlerSetNextHandler not implemented"
88 | , _evtHandlerSetPreviousHandler = error "_evtHandlerSetPreviousHandler not implemented"
89 | , _evtHandlerTryAfter = error "_evtHandlerTryAfter not implemented"
90 | , _evtHandlerTryBefore = error "_evtHandlerTryBefore not implemented"
91 | , _evtHandlerTryThis = error "_evtHandlerTryThis not implemented"
92 | , _evtHandlerUnlink = error "_evtHandlerUnlink not implemented"
93 | , _evtHandlerTail = tail
94 | }
--------------------------------------------------------------------------------
/wxasteroids/src/Graphics/UI/WXCore/EvtHandlerClass.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE CPP, StandaloneDeriving, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable #-}
2 | {-# OPTIONS -pgmP cpp #-}
3 | module Graphics.UI.WXCore.EvtHandlerClass where
4 |
5 | import Graphics.UI.WXCore.Types
6 | import Graphics.UI.WXCore.EventClass
7 | import LightOO
8 | import Data.Typeable
9 | import Data.IORef
10 |
11 | #ifdef __UHC__
12 | #include "Typeable.h"
13 | #include "LightOOUHC.h"
14 | #else
15 | #include "LightOO.h"
16 | #endif
17 |
18 | --eVT_MOTION :: EventType
19 | --wxEVT_MOTION = MOUSEMOVE
20 |
21 | --wxEVT_ENTER_WINDOW :: EventType
22 | --wxEVT_ENTER_WINDOW = MOUSEOVER
23 |
24 | --wxEVT_LEAVE_WINDOW :: EventType
25 | --wxEVT_LEAVE_WINDOW = MOUSEOUT
26 |
27 | --wxEVT_LEFT_DOWN :: EventType
28 | --wxEVT_LEFT_DOWN = CLICK
29 |
30 | --type Point = (Int,Int)
31 |
32 | --data EventMouse
33 | -- = MouseMotion !Point !Modifiers -- ^ Mouse was moved over the client area of the window
34 | -- | MouseEnter !Point !Modifiers -- ^ Mouse enters in the client area of the window
35 | -- | MouseLeave !Point !Modifiers -- ^ Mouse leaves the client area of the window
36 | -- | MouseLeftDown !Point !Modifiers -- ^ Mouse left button goes down
37 | -- | MouseLeftUp !Point !Modifiers -- ^ Mouse left button goes up
38 | -- | MouseLeftDClick !Point !Modifiers -- ^ Mouse left button double click
39 | -- | MouseLeftDrag !Point !Modifiers -- ^ Mouse left button drag
40 | -- | MouseRightDown !Point !Modifiers -- ^ Mouse right button goes down
41 | -- | MouseRightUp !Point !Modifiers -- ^ Mouse right button goes up
42 | -- | MouseRightDClick !Point !Modifiers -- ^ Mouse right button double click
43 | -- | MouseRightDrag !Point !Modifiers -- ^ Mouse right button drag (unsupported on most platforms)
44 | -- | MouseMiddleDown !Point !Modifiers -- ^ Mouse middle button goes down
45 | -- | MouseMiddleUp !Point !Modifiers -- ^ Mouse middle button goes up
46 | -- | MouseMiddleDClick !Point !Modifiers -- ^ Mouse middle button double click
47 | -- | MouseMiddleDrag !Point !Modifiers -- ^ Mouse middle button drag (unsupported on most platforms)
48 | -- | MouseWheel !Bool !Point !Modifiers -- ^ Mouse wheel rotation. (Bool is True for a downward rotation)
49 | -- deriving (Eq) -- ,Show)
50 |
51 | --- code in src/common/event.cpp
52 |
53 | data EvtHandlerClass a = EvtHandlerClass {
54 | _evtHandlerAddPendingEvent :: Event -> IO ()
55 | , _evtHandlerBind :: EventType -> (Event -> IO ()) -> Id -> Id -> IO ()
56 | , _evtGetHandler :: EventType -> Id -> Id -> IO (Maybe (Event -> IO ()))
57 | -- not sure what this object user data thing is useful for
58 | --, _evtHandlerBind :: forall b c. EventTag -> (Event b -> IO ()) -> Id -> Id -> Object b -> IO ()
59 | -- weird functor matching functionality
60 | --, _evtHandlerUnbind :: EventType -> (Event -> IO ()) -> Id -> Id -> IO ()
61 | , _evtHandlerUnBind :: EventType -> Id -> Id -> IO ()
62 | , _evtHandlerDeletePendingEvents :: IO ()
63 | , _evtHandlerGetEvtHandlerEnabled :: IO Bool
64 | , _evtHandlerGetNextHandler :: IO EvtHandler
65 | , _evtHandlerGetPreviousHandler :: IO EvtHandler
66 | , _evtHandlerIsUnlinked :: IO Bool
67 | , _evtHandlerProcessEvent :: Event -> IO Bool
68 | , _evtHandlerProcessEventLocally :: Event -> IO Bool
69 | , _evtHandlerProcessPendingEvents :: IO ()
70 | , _evtHandlerQueueEvent :: Event -> IO ()
71 |
72 | , _evtHandlerSetEvtHandlerEnabled :: Bool -> IO ()
73 | , _evtHandlerSetNextHandler :: EvtHandler -> IO ()
74 | , _evtHandlerSetPreviousHandler :: EvtHandler -> IO ()
75 | , _evtHandlerTryAfter :: Event -> IO ()
76 | , _evtHandlerTryBefore :: Event -> IO ()
77 | , _evtHandlerTryThis :: Event -> IO ()
78 | , _evtHandlerUnlink :: IO ()
79 | , _evtHandlerTail :: Record a
80 | }
81 | DefineSubClass(EvtHandler,Object,EvtHandlerClass,evtHandlerTail,,,,1,)
82 |
83 | #ifdef __UHC__
84 | INSTANCE_TYPEABLE1(EvtHandlerClass,evtHandlerTc,"EvtHandler")
85 | #endif
86 |
87 | evtHandler_Methods = unRecord . get_Object_Tail
88 | evtHandlerProcessEventLocally = _evtHandlerProcessEventLocally . evtHandler_Methods
89 | evtHandlerBind = _evtHandlerBind . evtHandler_Methods
90 | evtHandlerProcessEvent = _evtHandlerProcessEvent . evtHandler_Methods
91 | evtHandlerGetHandler = _evtGetHandler . evtHandler_Methods
92 | evtHandlerUnBind = _evtHandlerUnBind . evtHandler_Methods
93 | -- static functions
94 | --, _evtHandlerRemoveFilter(eventFilter* filter
95 | --_evtHandlerAddFilter(eventFilter* filter
96 |
97 |
98 | type DynamicEventTable = [DynamicEventTableEntry]
99 |
100 | data DynamicEventTableEntry = DynamicEventTableEntry {
101 | dynamicEventTableEntryEventType :: EventType
102 | ,dynamicEventTableEntryId :: Id
103 | ,dynamicEventTableEntryLastId :: Id
104 | ,dynamicEventTableEntryFunc :: Event -> IO ()
105 | ,dynamicEventTableEntryUserData :: Object
106 | }
--------------------------------------------------------------------------------