├── README.md ├── lightoo ├── .gitignore ├── Makefile ├── README.md └── src │ ├── Examples │ ├── ListSimpleSelf.hs │ ├── Print.hs │ ├── ReturnSelfShape.hs │ ├── ReturnSelfShapeExt.hs │ ├── Shapes.hs │ ├── Triplet.hs │ └── Vector.hs │ ├── LightOO.h │ ├── LightOO.hs │ ├── LightOO │ └── Core.hs │ └── LightOOUHC.h ├── msc-thesis ├── Makefile ├── README.md ├── chapters │ ├── appendix.lhs │ ├── architecture.lhs │ ├── background.lhs │ ├── conclusion.lhs │ ├── implementation.lhs │ ├── introduction.lhs │ ├── jsffi.lhs │ └── oo.lhs ├── haskell.fmt ├── resources │ ├── GUIstack.png │ ├── Some_X_windows.png │ ├── WxAsteroids.png │ ├── WxWidgets.svg │ ├── asteroidsbg.png │ ├── bg.png │ ├── browser_helloworld.png │ ├── browser_wxasteroids.png │ ├── circlerectangle.png │ ├── classwx_evt_handler__inherit__graph.png │ ├── html5.png │ ├── inhcomb.png │ ├── inhcomb.xcf │ ├── inheritance.png │ ├── mapping.graphml │ ├── mapping.png │ ├── oodiagram.png │ ├── pointext.dia │ ├── pointext.png │ ├── pointext.svg │ ├── self.png │ ├── shapes.dia │ ├── shapes.png │ ├── ubuntu_wxasteroids.png │ ├── uhc_pipeline.graphml │ ├── uhc_pipeline.png │ ├── uhclogo.png │ ├── unintented_helloworld.png │ ├── uniontypemapping.png │ ├── uniontypemapping.xcf │ ├── uulogo.jpg │ ├── uulogo.png │ ├── wxhaskell-layers.graphml │ ├── wxhaskell-layers.png │ ├── wxhaskell_web.graphml │ ├── wxhaskell_web.png │ ├── wxweb.graphml │ ├── wxweb.png │ ├── wxweb_question.graphml │ ├── wxweb_question.png │ ├── xlib_helloworld.cc │ └── xlib_helloworld.png ├── slides.lhs ├── slides.pdf ├── thesis ├── thesis.bib ├── thesis.fmt ├── thesis.lhs └── thesis.pdf ├── thesis-snippets ├── .gitignore ├── JS │ ├── Cast.hs │ ├── Export.hs │ ├── GlobalState.hs │ ├── HOF.hs │ ├── JSFFITestSuite.hs │ ├── UnionDynamic.hs │ ├── UnionEither.hs │ ├── UnionExt.hs │ └── rts.js └── OO │ ├── FirstClassClasses.hs │ ├── HomoList.hs │ ├── HomoListUHC.hs │ ├── InheritanceSimple.hs │ ├── InheritanceWithComb.hs │ ├── InheritanceWithOverride.hs │ ├── InheritanceWithOverrideAndSuperRef.hs │ ├── NestedObject.hs │ ├── OrphanMethods.hs │ ├── ParaPoint.hs │ ├── ParaPointBounded.hs │ ├── SelfReference.hs │ ├── SelfReturnJava.java │ ├── SelfReturnJavaGeneric.java │ ├── SimplePoint.hs │ ├── SimplePointTyExt.hs │ ├── Substitution.hs │ └── Triplet.java ├── uhc-js ├── .gitignore ├── README.md ├── tests │ ├── Makefile │ ├── in-progress │ │ ├── ho_import │ │ │ ├── Makefile │ │ │ ├── PROBLEMS │ │ │ └── ho_import.hs │ │ ├── import_dynamic │ │ │ ├── Makefile │ │ │ └── import_dynamic.hs │ │ ├── import_wrapper │ │ │ ├── Makefile │ │ │ └── import_wrapper.hs │ │ └── jquery │ │ │ ├── Makefile │ │ │ └── jquery.hs │ └── works │ │ ├── alert │ │ ├── Makefile │ │ └── alert.hs │ │ ├── data_export_plain │ │ ├── Makefile │ │ └── data_export_plain.hs │ │ ├── fold-param │ │ ├── Makefile │ │ └── fold.hs │ │ ├── js_oo │ │ ├── Makefile │ │ └── js_oo.hs │ │ ├── lenses │ │ ├── Makefile │ │ └── lenses.hs │ │ ├── nargs │ │ ├── Makefile │ │ └── nargs.hs │ │ └── var_ty_args │ │ ├── Makefile │ │ ├── NOTES │ │ └── var_ty_args.hs └── uhc-js │ ├── LICENSE │ ├── Makefile │ ├── Setup.hs │ ├── clean │ ├── make │ ├── src │ ├── Language │ │ └── UHC │ │ │ └── JS │ │ │ ├── Backbone.hs │ │ │ ├── Backbone │ │ │ ├── Collection.hs │ │ │ ├── Events.hs │ │ │ ├── History.hs │ │ │ ├── Model.hs │ │ │ ├── Router.hs │ │ │ ├── Sync.hs │ │ │ ├── Utility.hs │ │ │ └── View.hs │ │ │ ├── ECMA.hs │ │ │ ├── ECMA │ │ │ ├── Array.hs │ │ │ └── String.hs │ │ │ ├── HTML5 │ │ │ ├── CSSStyleDeclaration.hs │ │ │ ├── CanvasRenderingContext2D.hs │ │ │ ├── HTMLCanvasElement.hs │ │ │ ├── HTMLDocument.hs │ │ │ ├── HTMLElement.hs │ │ │ ├── HTMLImageElement.hs │ │ │ ├── Node.hs │ │ │ ├── Types.hs │ │ │ └── Window.hs │ │ │ ├── JQuery │ │ │ ├── Ajax.hs │ │ │ ├── AjaxQueue.hs │ │ │ ├── Deferred.hs │ │ │ ├── Draggable.hs │ │ │ ├── Droppable.hs │ │ │ └── JQuery.hs │ │ │ ├── JSON2 │ │ │ └── JSON2.hs │ │ │ ├── JSRef.hs │ │ │ ├── Marshal.hs │ │ │ ├── Prelude.hs │ │ │ ├── Primitives.hs │ │ │ ├── Types.hs │ │ │ ├── W3C │ │ │ └── HTML5.hs │ │ │ └── WebWorker.hs │ └── Main.hs │ └── uhc-js.cabal └── wxasteroids ├── .gitignore ├── AsteroidsDesktop.hs ├── Makefile ├── README.md ├── build ├── Asteroids.html ├── Asteroids.js ├── burning.ico ├── rock.ico └── ship.ico ├── contravariant-0.1.2 ├── Data │ └── Functor │ │ ├── Contravariant.hs │ │ └── Contravariant │ │ └── Compose.hs ├── LICENSE ├── Setup.lhs └── contravariant.cabal ├── resources ├── burning.ico ├── rock.ico └── ship.ico └── src ├── Asteroids.hs └── Graphics └── UI ├── WX.hs ├── WX ├── Attributes.hs ├── Classes.hs ├── Draw.hs ├── Events.hs ├── Media.hs ├── Timer.hs ├── Types.hs ├── Variable.hs └── Window.hs ├── WXCore.hs └── WXCore ├── Draw.hs ├── Event.hs ├── EventClass.hs ├── Events.hs ├── EvtHandler.hs ├── EvtHandlerClass.hs ├── GraphicsBitmap.hs ├── GraphicsBitmapClass.hs ├── GraphicsContext.hs ├── GraphicsContextClass.hs ├── GraphicsObject.hs ├── GraphicsObjectClass.hs ├── GraphicsRenderer.hs ├── GraphicsRendererClass.hs ├── KeyEvent.hs ├── KeyEventClass.hs ├── PaintEvent.hs ├── PaintEventClass.hs ├── Timer.hs ├── TimerClass.hs ├── Types.hs ├── WebWindow.hs ├── Window.hs └── WindowClass.hs /README.md: -------------------------------------------------------------------------------- 1 | JS Asteroids 2 | ============ 3 | 4 | An implementation of wxAsteroids in Javascript using UHC (Utrecht Haskell Compiler). 5 | See the [github page](http://uu-computerscience.github.com/js-asteroids/) for a short 6 | intro. 7 | 8 | Navigate into the following directories for more elaborate information: 9 | 10 | * msc-thesis : Master thesis 11 | * lightoo : A lightweight DSL for OO programming in Haskell 12 | * uhc-js : A helper library for accessing browser functionality using Haskell 13 | * wxasteroids : A port of wxAsteroids to the web browser 14 | * thesis-snippets: The code snippets contained in the thesis 15 | 16 | 17 | -------------------------------------------------------------------------------- /lightoo/.gitignore: -------------------------------------------------------------------------------- 1 | *.c 2 | *.o 3 | *.class 4 | *.core 5 | *.hi 6 | *.grin 7 | *.swp 8 | *-cpp.hs 9 | *.hs-cpp 10 | *~ 11 | *.mjs 12 | -------------------------------------------------------------------------------- /lightoo/Makefile: -------------------------------------------------------------------------------- 1 | UHC-OPT= 2 | MAIN=src/Examples/Shapes 3 | 4 | default: all 5 | 6 | all: 7 | ${UHC} ${UHC-OPT} --import-path="src" ${MAIN} 8 | 9 | ghci: 10 | ghci ${MAIN} -isrc 11 | 12 | clean: 13 | find . -type f \( -name "*.grin" -o -name "*.c" -o -name "*.o" -o -name "*.hs-cpp" -o -name "*-cpp.hs" -o -name "*.hi" -o -name "*.core" -o -name "*.mjs" -o -name "*.js" -o -name "*.html" \) | xargs --no-run-if-empty rm 14 | 15 | .PHONY: clean, tests 16 | 17 | -------------------------------------------------------------------------------- /lightoo/README.md: -------------------------------------------------------------------------------- 1 | LightOO 2 | ======= 3 | 4 | A lightweight Object-Oriented programming library for Haskell. 5 | 6 | The library is based on the ["Mutable Objects, with tail-polymorphism"][1] approach initially described by the authors of OOHaskell and it extends it with: 7 | 8 | * Generic up and downcasts using dynamic typing 9 | * An inheritance combinator [W. Cook][2] 10 | * Parameterized classes 11 | * CPP macros for deriving parts of the boilerplate 12 | 13 | The OO programming techniques offered by the library were used to implement a subset of the [wxWidgets design in Haskell][3]. 14 | Please look inside the `src/Examples` directory for additional examples. 15 | 16 | Usage GHC 17 | ------- 18 | 19 | make ghci 20 | 21 | or 22 | 23 | make ghci MAIN=src/Examples/{One of the examples} 24 | 25 | Usage UHC 26 | --------- 27 | 28 | Make sure the UHC environment variable points to your local UHC installation. 29 | 30 | make 31 | 32 | or 33 | 34 | make MAIN=src/Examples/{One of the examples} 35 | 36 | [1]: http://homepages.cwi.nl/~ralf/OOHaskell/ 37 | [2]: http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.11.8792 38 | [3]: https://github.com/rubendg/msc-thesis 39 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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/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/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 -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /msc-thesis/Makefile: -------------------------------------------------------------------------------- 1 | default: all 2 | 3 | clean: 4 | find . -type f \( -name "*.snm" -o -name "*.vrb" -o -name "*.nav" -o -name "*.aux" -o -name "*.blg" -o -name "*.ptb" -o -name "*.toc" -o -name "*.bbl" -o -name "*.out" -o -name "*.log" \) | xargs --no-run-if-empty rm 5 | 6 | slides: 7 | lhs2TeX slides.lhs -o slides 8 | pdflatex slides 9 | rm slides 10 | 11 | all: 12 | lhs2TeX thesis.lhs -o thesis 13 | pdflatex thesis 14 | bibtex thesis 15 | pdflatex thesis 16 | pdflatex thesis 17 | 18 | .PHONY: clean 19 | -------------------------------------------------------------------------------- /msc-thesis/README.md: -------------------------------------------------------------------------------- 1 | wxHaskell for the web: substituting C++ with Haskell and JavaScript 2 | ========== 3 | 4 | University Utrecht Master Thesis. 5 | 6 | To build the thesis run: 7 | 8 | make 9 | 10 | To build the slides run: 11 | 12 | make slides 13 | 14 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /msc-thesis/resources/GUIstack.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/UU-ComputerScience/js-asteroids/b7015d8ad4aa57ff30f2631e0945462f6e1ef47a/msc-thesis/resources/GUIstack.png -------------------------------------------------------------------------------- /msc-thesis/resources/Some_X_windows.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/UU-ComputerScience/js-asteroids/b7015d8ad4aa57ff30f2631e0945462f6e1ef47a/msc-thesis/resources/Some_X_windows.png -------------------------------------------------------------------------------- /msc-thesis/resources/WxAsteroids.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/UU-ComputerScience/js-asteroids/b7015d8ad4aa57ff30f2631e0945462f6e1ef47a/msc-thesis/resources/WxAsteroids.png -------------------------------------------------------------------------------- /msc-thesis/resources/asteroidsbg.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/UU-ComputerScience/js-asteroids/b7015d8ad4aa57ff30f2631e0945462f6e1ef47a/msc-thesis/resources/asteroidsbg.png -------------------------------------------------------------------------------- /msc-thesis/resources/bg.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/UU-ComputerScience/js-asteroids/b7015d8ad4aa57ff30f2631e0945462f6e1ef47a/msc-thesis/resources/bg.png -------------------------------------------------------------------------------- /msc-thesis/resources/browser_helloworld.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/UU-ComputerScience/js-asteroids/b7015d8ad4aa57ff30f2631e0945462f6e1ef47a/msc-thesis/resources/browser_helloworld.png -------------------------------------------------------------------------------- /msc-thesis/resources/browser_wxasteroids.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/UU-ComputerScience/js-asteroids/b7015d8ad4aa57ff30f2631e0945462f6e1ef47a/msc-thesis/resources/browser_wxasteroids.png -------------------------------------------------------------------------------- /msc-thesis/resources/circlerectangle.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/UU-ComputerScience/js-asteroids/b7015d8ad4aa57ff30f2631e0945462f6e1ef47a/msc-thesis/resources/circlerectangle.png -------------------------------------------------------------------------------- /msc-thesis/resources/classwx_evt_handler__inherit__graph.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/UU-ComputerScience/js-asteroids/b7015d8ad4aa57ff30f2631e0945462f6e1ef47a/msc-thesis/resources/classwx_evt_handler__inherit__graph.png -------------------------------------------------------------------------------- /msc-thesis/resources/html5.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/UU-ComputerScience/js-asteroids/b7015d8ad4aa57ff30f2631e0945462f6e1ef47a/msc-thesis/resources/html5.png -------------------------------------------------------------------------------- /msc-thesis/resources/inhcomb.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/UU-ComputerScience/js-asteroids/b7015d8ad4aa57ff30f2631e0945462f6e1ef47a/msc-thesis/resources/inhcomb.png -------------------------------------------------------------------------------- /msc-thesis/resources/inhcomb.xcf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/UU-ComputerScience/js-asteroids/b7015d8ad4aa57ff30f2631e0945462f6e1ef47a/msc-thesis/resources/inhcomb.xcf -------------------------------------------------------------------------------- /msc-thesis/resources/inheritance.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/UU-ComputerScience/js-asteroids/b7015d8ad4aa57ff30f2631e0945462f6e1ef47a/msc-thesis/resources/inheritance.png -------------------------------------------------------------------------------- /msc-thesis/resources/mapping.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/UU-ComputerScience/js-asteroids/b7015d8ad4aa57ff30f2631e0945462f6e1ef47a/msc-thesis/resources/mapping.png -------------------------------------------------------------------------------- /msc-thesis/resources/oodiagram.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/UU-ComputerScience/js-asteroids/b7015d8ad4aa57ff30f2631e0945462f6e1ef47a/msc-thesis/resources/oodiagram.png -------------------------------------------------------------------------------- /msc-thesis/resources/pointext.dia: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/UU-ComputerScience/js-asteroids/b7015d8ad4aa57ff30f2631e0945462f6e1ef47a/msc-thesis/resources/pointext.dia -------------------------------------------------------------------------------- /msc-thesis/resources/pointext.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/UU-ComputerScience/js-asteroids/b7015d8ad4aa57ff30f2631e0945462f6e1ef47a/msc-thesis/resources/pointext.png -------------------------------------------------------------------------------- /msc-thesis/resources/self.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/UU-ComputerScience/js-asteroids/b7015d8ad4aa57ff30f2631e0945462f6e1ef47a/msc-thesis/resources/self.png -------------------------------------------------------------------------------- /msc-thesis/resources/shapes.dia: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/UU-ComputerScience/js-asteroids/b7015d8ad4aa57ff30f2631e0945462f6e1ef47a/msc-thesis/resources/shapes.dia -------------------------------------------------------------------------------- /msc-thesis/resources/shapes.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/UU-ComputerScience/js-asteroids/b7015d8ad4aa57ff30f2631e0945462f6e1ef47a/msc-thesis/resources/shapes.png -------------------------------------------------------------------------------- /msc-thesis/resources/ubuntu_wxasteroids.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/UU-ComputerScience/js-asteroids/b7015d8ad4aa57ff30f2631e0945462f6e1ef47a/msc-thesis/resources/ubuntu_wxasteroids.png -------------------------------------------------------------------------------- /msc-thesis/resources/uhc_pipeline.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/UU-ComputerScience/js-asteroids/b7015d8ad4aa57ff30f2631e0945462f6e1ef47a/msc-thesis/resources/uhc_pipeline.png -------------------------------------------------------------------------------- /msc-thesis/resources/uhclogo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/UU-ComputerScience/js-asteroids/b7015d8ad4aa57ff30f2631e0945462f6e1ef47a/msc-thesis/resources/uhclogo.png -------------------------------------------------------------------------------- /msc-thesis/resources/unintented_helloworld.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/UU-ComputerScience/js-asteroids/b7015d8ad4aa57ff30f2631e0945462f6e1ef47a/msc-thesis/resources/unintented_helloworld.png -------------------------------------------------------------------------------- /msc-thesis/resources/uniontypemapping.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/UU-ComputerScience/js-asteroids/b7015d8ad4aa57ff30f2631e0945462f6e1ef47a/msc-thesis/resources/uniontypemapping.png -------------------------------------------------------------------------------- /msc-thesis/resources/uniontypemapping.xcf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/UU-ComputerScience/js-asteroids/b7015d8ad4aa57ff30f2631e0945462f6e1ef47a/msc-thesis/resources/uniontypemapping.xcf -------------------------------------------------------------------------------- /msc-thesis/resources/uulogo.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/UU-ComputerScience/js-asteroids/b7015d8ad4aa57ff30f2631e0945462f6e1ef47a/msc-thesis/resources/uulogo.jpg -------------------------------------------------------------------------------- /msc-thesis/resources/uulogo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/UU-ComputerScience/js-asteroids/b7015d8ad4aa57ff30f2631e0945462f6e1ef47a/msc-thesis/resources/uulogo.png -------------------------------------------------------------------------------- /msc-thesis/resources/wxhaskell-layers.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/UU-ComputerScience/js-asteroids/b7015d8ad4aa57ff30f2631e0945462f6e1ef47a/msc-thesis/resources/wxhaskell-layers.png -------------------------------------------------------------------------------- /msc-thesis/resources/wxhaskell_web.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/UU-ComputerScience/js-asteroids/b7015d8ad4aa57ff30f2631e0945462f6e1ef47a/msc-thesis/resources/wxhaskell_web.png -------------------------------------------------------------------------------- /msc-thesis/resources/wxweb.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/UU-ComputerScience/js-asteroids/b7015d8ad4aa57ff30f2631e0945462f6e1ef47a/msc-thesis/resources/wxweb.png -------------------------------------------------------------------------------- /msc-thesis/resources/wxweb_question.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/UU-ComputerScience/js-asteroids/b7015d8ad4aa57ff30f2631e0945462f6e1ef47a/msc-thesis/resources/wxweb_question.png -------------------------------------------------------------------------------- /msc-thesis/resources/xlib_helloworld.cc: -------------------------------------------------------------------------------- 1 | #include 2 | #include 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 | -------------------------------------------------------------------------------- /msc-thesis/resources/xlib_helloworld.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/UU-ComputerScience/js-asteroids/b7015d8ad4aa57ff30f2631e0945462f6e1ef47a/msc-thesis/resources/xlib_helloworld.png -------------------------------------------------------------------------------- /msc-thesis/slides.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/UU-ComputerScience/js-asteroids/b7015d8ad4aa57ff30f2631e0945462f6e1ef47a/msc-thesis/slides.pdf -------------------------------------------------------------------------------- /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" -------------------------------------------------------------------------------- /msc-thesis/thesis.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/UU-ComputerScience/js-asteroids/b7015d8ad4aa57ff30f2631e0945462f6e1ef47a/msc-thesis/thesis.pdf -------------------------------------------------------------------------------- /thesis-snippets/.gitignore: -------------------------------------------------------------------------------- 1 | *.c 2 | *.o 3 | *.class 4 | *.core 5 | *.hi 6 | *.grin 7 | *.swp 8 | *-cpp.hs 9 | *.hs-cpp 10 | *~ 11 | *.mjs 12 | -------------------------------------------------------------------------------- /thesis-snippets/JS/Cast.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables, TypeSynonymInstances, FlexibleInstances #-} 2 | module Cast where 3 | import Unsafe.Coerce 4 | 5 | class GetObjectRef a where 6 | getObjectRef :: a -> b 7 | 8 | data JSObject_ a 9 | 10 | data Node_ a 11 | data Element_ a 12 | 13 | type Node a = JSObject_ (Node_ a) 14 | type Element a = JSObject_ (Element_ a) 15 | 16 | instance GetObjectRef (Node ()) where 17 | getObjectRef = undefined 18 | 19 | instance GetObjectRef (Element ()) where 20 | getObjectRef = undefined 21 | 22 | instance GetObjectRef (JSObject_ ()) where 23 | getObjectRef = undefined 24 | 25 | cast :: forall a b. GetObjectRef b => a -> Maybe b 26 | cast a = 27 | if instanceOf a (getObjectRef (undefined :: b)) 28 | then Just (unsafeCoerce a) 29 | else Nothing 30 | 31 | instanceOf :: a -> b -> Bool 32 | instanceOf = undefined 33 | 34 | -------------------------------------------------------------------------------- /thesis-snippets/JS/Export.hs: -------------------------------------------------------------------------------- 1 | module Export where 2 | 3 | minus :: Int -> Int -> Int 4 | minus x y = x - y 5 | 6 | foreign export js "minus" 7 | minus :: Int -> Int -> Int 8 | -------------------------------------------------------------------------------- /thesis-snippets/JS/GlobalState.hs: -------------------------------------------------------------------------------- 1 | module GlobalState where 2 | 3 | import Data.IORef 4 | 5 | foreign import js "x" 6 | varX :: IO a 7 | 8 | foreign import js "mutX()" 9 | mutX :: IO () 10 | 11 | foreign import js "document.write(%*)" 12 | documentWrite :: a -> IO () 13 | 14 | data Lens a = Lens (IO a) (a -> IO ()) 15 | newtype JSRef t a = JSRef (Lens a) 16 | 17 | data Read 18 | data ReadWrite 19 | 20 | newReadOnlyJSRef :: IO a -> JSRef Read a 21 | newReadOnlyJSRef r = unsafeCoerce $ newJSRef r undefined 22 | 23 | newJSRef :: IO a -> (a -> IO ()) -> JSRef ReadWrite a 24 | newJSRef r w = JSRef (Lens r w) 25 | 26 | readJSRef :: JSRef t a -> IO a 27 | readJSRef (JSRef (Lens r _)) = r 28 | 29 | writeJSRef :: JSRef ReadWrite a -> a -> IO () 30 | writeJSRef (JSRef (Lens _ w)) = w 31 | 32 | foreign import js "window.x" 33 | readVarX :: IO a 34 | 35 | foreign import js "primSetAttr('x',%1,window)" 36 | writeVarX :: a -> IO () 37 | 38 | jsX = newJSRef readVarX writeVarX 39 | 40 | main = do 41 | x <- readJSRef jsX 42 | documentWrite x 43 | mutX 44 | x <- readJSRef jsX 45 | documentWrite x 46 | writeJSRef jsX 4 47 | readJSRef jsX >>= documentWrite -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /thesis-snippets/JS/UnionEither.hs: -------------------------------------------------------------------------------- 1 | module UnionEither where 2 | 3 | data JSString 4 | data JSBool 5 | 6 | -- todo fix to real functions once these are in the rts 7 | foreign import js "primIsString(%*)" 8 | isString :: a -> Bool 9 | 10 | foreign import js "primIsBool(%*)" 11 | isBool :: a -> Bool 12 | 13 | foo :: a -> Either JSString JSBool 14 | foo a = 15 | let ret r | isString r = Left (unsafeCoerce r) 16 | | isBool r = Right (unsafeCoerce r) 17 | in ret (_foo a) 18 | 19 | foreign import js "foo(%1)" 20 | _foo :: a -> b -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /thesis-snippets/OO/HomoList.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification, FlexibleInstances #-} 2 | module HomoList where 3 | 4 | data Shape a 5 | data Rectangle a 6 | data Circle a 7 | 8 | rect = undefined :: Shape (Rectangle ()) 9 | 10 | circ = undefined :: Shape (Circle ()) 11 | 12 | -- Ty error 13 | --test = [rect, circ] :: [Shape a] 14 | 15 | -- Existentials 16 | 17 | data ShapeExt = forall a. ShapeExt (Shape a) 18 | 19 | --homoExt :: [exists a. Shape a] 20 | --homoExt = [rect, circ] 21 | 22 | homoExt = [ShapeExt rect, ShapeExt circ] :: [ShapeExt] 23 | 24 | -- Either 25 | 26 | homoEither = [Left rect, Right circ] 27 | -------------------------------------------------------------------------------- /thesis-snippets/OO/HomoListUHC.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification #-} 2 | module HomoList where 3 | 4 | data Shape a 5 | data Rectangle a 6 | data Circle a 7 | 8 | rect = undefined :: Shape (Rectangle ()) 9 | 10 | circ = undefined :: Shape (Circle ()) 11 | 12 | -- doesn't work 13 | --homoExt = [rect, circ] :: [exists a. Shape a] 14 | 15 | homoExt' :: [exists a. Shape a] 16 | homoExt' = [rect, circ] 17 | 18 | foo :: Shape a -> Bool 19 | foo _ = True 20 | 21 | test = map foo homoExt' 22 | -------------------------------------------------------------------------------- /thesis-snippets/OO/InheritanceSimple.hs: -------------------------------------------------------------------------------- 1 | module InheritanceSimple where 2 | import Data.IORef 3 | import Prelude 4 | import Control.Monad.Fix (mfix) 5 | 6 | o # f = f o 7 | 8 | data PointClass a = PointClass { 9 | getX :: IO Int 10 | ,moveX :: Int -> IO () 11 | ,_pointTail :: a 12 | } 13 | 14 | point x_init cons self = do 15 | varX <- newIORef x_init 16 | tail <- cons 17 | return PointClass { 18 | getX = readIORef varX 19 | ,moveX = \d -> modifyIORef varX (+d) 20 | ,_pointTail = tail self 21 | } 22 | 23 | data ColoredPointClass a = ColoredPointClass { 24 | _getColor :: IO String 25 | ,_coloredPointTail :: a 26 | } 27 | 28 | colored_point x color cons self = 29 | point x colored_point' self 30 | where 31 | colored_point' = do 32 | tail <- cons 33 | return $ \self -> ColoredPointClass { 34 | _getColor = return color 35 | ,_coloredPointTail = tail self 36 | } 37 | 38 | getColor = _getColor . _pointTail 39 | 40 | nilRecord = () 41 | 42 | emptyRecord = return $ const nilRecord 43 | 44 | new :: (IO (a -> ()) -> a -> IO a) -> IO a 45 | new oo = mfix $ oo emptyRecord 46 | 47 | myColoredOOP = do 48 | p <- new $ colored_point 3 "red" 49 | x <- p # getX 50 | c <- p # getColor 51 | print (x, c) 52 | 53 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /thesis-snippets/OO/NestedObject.hs: -------------------------------------------------------------------------------- 1 | module NestedObject where 2 | import Data.IORef 3 | 4 | nilRecord = () 5 | emptyRecord :: IO () 6 | emptyRecord = return nilRecord 7 | 8 | o # f = f o 9 | 10 | data PointClass t = PointClass { 11 | getX :: IO Int 12 | ,moveX :: Int -> IO () 13 | ,_pointTail :: t 14 | } 15 | 16 | incrementing_point = do 17 | x0 <- newIORef 0 18 | return $ \cons -> do 19 | tail <- cons 20 | modifyIORef x0 (+1) 21 | varX <- readIORef x0 >>= newIORef 22 | return PointClass { 23 | getX = readIORef varX 24 | ,moveX = \d -> modifyIORef varX (+d) 25 | ,_pointTail = tail 26 | } 27 | 28 | makeIncrementingPointClass = incrementing_point 29 | 30 | myNestedOOP = do 31 | localClass <- makeIncrementingPointClass 32 | localClass emptyRecord >>= (# getX) >>= print 33 | localClass emptyRecord >>= (# getX) >>= print 34 | -------------------------------------------------------------------------------- /thesis-snippets/OO/OrphanMethods.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeSynonymInstances, FlexibleInstances, OverlappingInstances #-} 2 | module OrphanMethods where 3 | import Prelude as Prelude 4 | import Data.IORef 5 | 6 | o # f = f o 7 | 8 | class HasGetX o where 9 | callGetX :: o -> IO Int 10 | 11 | type Foo a = PrintablePointClass (Foo_ a) 12 | data Foo_ a 13 | 14 | instance HasGetX (Foo a) where 15 | callGetX = undefined 16 | 17 | instance HasGetX (PrintablePointClass t) where 18 | callGetX = getX 19 | 20 | data PrintablePointClass a = PrintablePointClass { 21 | varX :: IORef Int 22 | ,getX :: IO Int 23 | ,moveX :: Int -> IO () 24 | ,print :: IO () 25 | ,printablePointTail :: a 26 | } 27 | 28 | printable_point x_init cons self = do 29 | x <- newIORef x_init 30 | tail <- cons 31 | return PrintablePointClass { 32 | varX = x 33 | ,getX = readIORef x 34 | ,moveX = \d -> modifyIORef x ((+) d) 35 | ,OrphanMethods.print = print_getX self 36 | ,printablePointTail = tail self 37 | } 38 | 39 | print_getX self = (self # callGetX) >>= Prelude.print 40 | -------------------------------------------------------------------------------- /thesis-snippets/OO/ParaPoint.hs: -------------------------------------------------------------------------------- 1 | module ParaPoint where 2 | import Data.IORef 3 | 4 | data ParaPointClass = ParaPointClass { 5 | varX :: IORef Int 6 | ,getX :: IO Int 7 | ,moveX :: Int -> IO () 8 | ,getOffset :: IO Int 9 | } 10 | 11 | para_point x_init = do 12 | x <- newIORef x_init 13 | return ParaPointClass { 14 | varX = x 15 | ,getX = readIORef x 16 | ,moveX = \d -> modifyIORef x ((+) d) 17 | ,getOffset = readIORef x >>= \x -> return (x - x_init) 18 | } 19 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /thesis-snippets/OO/SelfReference.hs: -------------------------------------------------------------------------------- 1 | module SelfReference where 2 | import Data.IORef 3 | import Prelude hiding (print) 4 | import Control.Monad.Fix (mfix) 5 | 6 | nilRecord = () 7 | emptyRecord :: IO () 8 | emptyRecord = return nilRecord 9 | 10 | o # f = f o 11 | 12 | data PrintablePointClass t = PrintablePointClass { 13 | getX :: IO Int 14 | ,moveX :: Int -> IO () 15 | ,print :: IO () 16 | ,_printablePointTail :: t 17 | } 18 | 19 | printable_point x_init cons self = do 20 | tail <- cons 21 | varX <- newIORef x_init 22 | return PrintablePointClass { 23 | getX = readIORef varX 24 | ,moveX = \d -> modifyIORef varX ((+) d) 25 | ,print = (self # getX) >>= putStr . show 26 | ,_printablePointTail = tail 27 | } 28 | 29 | mySelfishOOP = do 30 | p <- mfix $ printable_point 3 emptyRecord 31 | p # moveX $ 2 32 | p # print 33 | 34 | printable_point' x_init cons self = do 35 | p <- printable_point x_init cons self 36 | p # moveX $ 2 37 | return p 38 | 39 | mySelfishOOP' = do 40 | p <- mfix $ printable_point' 3 emptyRecord 41 | p # moveX $ 2 42 | p # print 43 | 44 | 45 | -------------------------------------------------------------------------------- /thesis-snippets/OO/SelfReturnJava.java: -------------------------------------------------------------------------------- 1 | class A { 2 | public A foo() { 3 | return this; 4 | } 5 | } 6 | 7 | class B extends A { 8 | public B bar() { 9 | return this; 10 | } 11 | } 12 | 13 | class Main { 14 | public static void main(String[] args) { 15 | B b = new B(); 16 | b.bar().foo().bar(); 17 | //((B) b.bar().foo()).bar(); 18 | } 19 | } 20 | -------------------------------------------------------------------------------- /thesis-snippets/OO/SelfReturnJavaGeneric.java: -------------------------------------------------------------------------------- 1 | abstract class A> { 2 | public T foo() { 3 | return (T) getThis(); 4 | } 5 | public abstract T getThis(); 6 | } 7 | 8 | class B extends A { 9 | public B bar() { 10 | return this; 11 | } 12 | public B getThis() { 13 | return this; 14 | } 15 | } 16 | 17 | class Main { 18 | public static void main(String[] args) { 19 | B b = new B(); 20 | b.bar().foo().bar(); 21 | } 22 | } 23 | -------------------------------------------------------------------------------- /thesis-snippets/OO/SimplePoint.hs: -------------------------------------------------------------------------------- 1 | module SimplePoint where 2 | 3 | import Data.IORef 4 | 5 | data PointClass = PointClass { 6 | varX :: IORef Int 7 | ,getX :: IO Int 8 | ,moveX :: Int -> IO () 9 | } 10 | 11 | o # f = f o 12 | 13 | point = do 14 | x <- newIORef 0 15 | return PointClass { 16 | varX = x 17 | ,getX = readIORef x 18 | ,moveX = \d -> modifyIORef x ((+) d) 19 | } 20 | 21 | myFirstOOP = do 22 | p <- point 23 | p # getX >>= print 24 | p # moveX $ 3 25 | p # getX >>= print 26 | -------------------------------------------------------------------------------- /thesis-snippets/OO/SimplePointTyExt.hs: -------------------------------------------------------------------------------- 1 | module SimplePoinTyExt where 2 | 3 | import Data.IORef 4 | 5 | data PointClass a = PointClass { 6 | varX :: IORef Int 7 | ,getX :: IO Int 8 | ,moveX :: Int -> IO () 9 | ,pointTail :: a 10 | } 11 | 12 | data Point2DClass a = Point2DClass { 13 | _getY :: IO Int 14 | ,_point2DTail :: a 15 | } 16 | 17 | o # f = f o 18 | 19 | nilRecord = () 20 | emptyRecord :: IO () 21 | emptyRecord = return nilRecord 22 | 23 | point cons = do 24 | x <- newIORef 0 25 | tail <- cons 26 | return PointClass { 27 | varX = x 28 | ,getX = readIORef x 29 | ,moveX = \d -> modifyIORef x ((+) d) 30 | ,pointTail = tail 31 | } 32 | 33 | point2d cons = do 34 | point point2d' 35 | where 36 | point2d' = do 37 | y <- newIORef 0 38 | tail <- cons 39 | return Point2DClass { 40 | _getY = readIORef y 41 | ,_point2DTail = tail 42 | } 43 | 44 | getY = _getY . pointTail 45 | 46 | myFirstOOP = do 47 | p <- point emptyRecord 48 | p # getX >>= print 49 | p # moveX $ 3 50 | p # getX >>= print 51 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /thesis-snippets/OO/Triplet.java: -------------------------------------------------------------------------------- 1 | class Pair { 2 | private final A a; 3 | private final B b; 4 | 5 | public Pair(A a, B b) { 6 | this.a = a; 7 | this.b = b; 8 | } 9 | 10 | public A getFirst() { 11 | return a; 12 | } 13 | 14 | public B getSecond() { 15 | return b; 16 | } 17 | /* 18 | public Pair swap() { 19 | return new Pair(b,a); 20 | } 21 | */ 22 | } 23 | 24 | class Triplet extends Pair { 25 | private final C c; 26 | 27 | public Triplet(A a, B b, C c) { 28 | super(a,b); 29 | this.c = c; 30 | } 31 | 32 | public C getThird() { 33 | return c; 34 | } 35 | 36 | public Triplet swap() { 37 | return new Triplet(getSecond(),getFirst(),c); 38 | } 39 | } 40 | 41 | class Main { 42 | 43 | public static void main(String[] args) { 44 | Pair p = new Triplet(0,0.0,"hi"); 45 | } 46 | } 47 | 48 | -------------------------------------------------------------------------------- /uhc-js/.gitignore: -------------------------------------------------------------------------------- 1 | .DS_Store 2 | EHC 3 | *.core* 4 | *.hi 5 | *.html 6 | *.js 7 | *.mjs 8 | haskell-jscript-libraries/ 9 | *.tex 10 | *.xml 11 | *.ptb 12 | *.pdf 13 | *.out 14 | *.log 15 | *.bcf 16 | *.bbl 17 | *.blg 18 | *.aux* 19 | -------------------------------------------------------------------------------- /uhc-js/README.md: -------------------------------------------------------------------------------- 1 | # UHC JavaScript libraries 2 | 3 | These libraries have been written to work with the UHC JavaScript 4 | backend to introduce some conventions and eliminate some boilerplate 5 | code. 6 | -------------------------------------------------------------------------------- /uhc-js/tests/Makefile: -------------------------------------------------------------------------------- 1 | # FLAGS = -tjscript --dump-core-stages=1 --dump-grin-stages=1 -O1,2 --gen-trace=1 --import-path=../../../uhc-jscript/src 2 | FLAGS = -tjscript --dump-core-stages=1 --dump-grin-stages=1 --gen-trace=1 --import-path=../../../uhc-jscript/src --no-hi-check 3 | 4 | ifndef PROJECT 5 | PROJECT = $(patsubst %.hs, %, $(wildcard *.hs)) 6 | endif 7 | 8 | default: $(PROJECT).js 9 | 10 | $(PROJECT).js: $(PROJECT).hs 11 | $(UHC) $(PROJECT).hs $(FLAGS) 12 | 13 | clean: 14 | rm *.core* *.full.core *.hi $(PROJECT).js $(PROJECT).html *.mjs 15 | 16 | .PHONY : clean strip 17 | -------------------------------------------------------------------------------- /uhc-js/tests/in-progress/ho_import/Makefile: -------------------------------------------------------------------------------- 1 | include ../../Makefile 2 | -------------------------------------------------------------------------------- /uhc-js/tests/in-progress/ho_import/PROBLEMS: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/UU-ComputerScience/js-asteroids/b7015d8ad4aa57ff30f2631e0945462f6e1ef47a/uhc-js/tests/in-progress/ho_import/PROBLEMS -------------------------------------------------------------------------------- /uhc-js/tests/in-progress/ho_import/ho_import.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = do 3 | putStrLn "ho_import" 4 | let res = foldjs (*) 1 [1..10] 5 | putStrLn $ show res 6 | 7 | 8 | foreign import jscript "foldjs(%*)" foldjs :: (a -> b -> b) -> b -> [a] -> b 9 | -------------------------------------------------------------------------------- /uhc-js/tests/in-progress/import_dynamic/Makefile: -------------------------------------------------------------------------------- 1 | include ../../Makefile 2 | -------------------------------------------------------------------------------- /uhc-js/tests/in-progress/import_dynamic/import_dynamic.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 | import UHC.Ptr 6 | 7 | 8 | foreign import jscript "getJSFun(%1)" 9 | getJSFun :: Int -> IO (FunPtr (Int -> Int)) 10 | 11 | foreign import jscript "dynamic" 12 | mkDyn :: FunPtr (Int -> Int) -> (Int -> Int) 13 | 14 | main :: IO () 15 | main = do 16 | putStrLn "import_dynamic" 17 | jfn <- getJSFun 2 18 | print $ (mkDyn jfn) 3 19 | 20 | -------------------------------------------------------------------------------- /uhc-js/tests/in-progress/import_wrapper/Makefile: -------------------------------------------------------------------------------- 1 | include ../../Makefile 2 | -------------------------------------------------------------------------------- /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/in-progress/jquery/Makefile: -------------------------------------------------------------------------------- 1 | include ../../Makefile 2 | -------------------------------------------------------------------------------- /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/tests/works/alert/Makefile: -------------------------------------------------------------------------------- 1 | include ../../Makefile 2 | -------------------------------------------------------------------------------- /uhc-js/tests/works/alert/alert.hs: -------------------------------------------------------------------------------- 1 | main = do 2 | putStrLn "alert" 3 | alert 123 4 | 5 | 6 | foreign import jscript "alert" 7 | alert :: Int -> IO () 8 | -------------------------------------------------------------------------------- /uhc-js/tests/works/data_export_plain/Makefile: -------------------------------------------------------------------------------- 1 | include ../../Makefile 2 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /uhc-js/tests/works/fold-param/Makefile: -------------------------------------------------------------------------------- 1 | include ../../Makefile 2 | -------------------------------------------------------------------------------- /uhc-js/tests/works/fold-param/fold.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = do 3 | answ <- fldToN (f 3) 10 4 | putStrLn $ show answ 5 | 6 | f :: Int -> Int -> Int -> Int 7 | f n x xs = n + x + xs 8 | 9 | fldToN :: (Int -> Int -> Int) -> Int -> IO Int 10 | fldToN f n = return $ foldr f 0 [1..n] 11 | 12 | foreign export jscript "fldToN" 13 | fldToN :: (Int -> Int -> Int) -> Int -> IO Int 14 | -------------------------------------------------------------------------------- /uhc-js/tests/works/js_oo/Makefile: -------------------------------------------------------------------------------- 1 | include ../../Makefile 2 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /uhc-js/tests/works/lenses/Makefile: -------------------------------------------------------------------------------- 1 | include ../../Makefile 2 | -------------------------------------------------------------------------------- /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/nargs/Makefile: -------------------------------------------------------------------------------- 1 | include ../../Makefile 2 | -------------------------------------------------------------------------------- /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/tests/works/var_ty_args/Makefile: -------------------------------------------------------------------------------- 1 | include ../../Makefile 2 | -------------------------------------------------------------------------------- /uhc-js/tests/works/var_ty_args/NOTES: -------------------------------------------------------------------------------- 1 | Type information seems to be lost in the conversion from HS to JS? An Int and a 2 | String should produce separate messages, but both are seen as an object, which 3 | should produce yet another message! 4 | 5 | 6 | Ah, this seems to be due to the fact that the myVar from the HS world is 7 | encapsulated by a JS object. When writing JS functions, we apparently 8 | explicitly need to ask for the value? This seems rather strange to me. How will 9 | we then interface with existing libraries? 10 | -------------------------------------------------------------------------------- /uhc-js/tests/works/var_ty_args/var_ty_args.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = do 3 | putStrLn "var_ty_args" 4 | {- varTyArgs "Foo"-} 5 | varTyArgsStr "Bar" 6 | varTyArgsInt 123 7 | 8 | {- foreign import jscript "varTyArgs(%*)" varTyArgs :: a -> IO ()-} 9 | foreign import jscript "varTyArgs(%*)" varTyArgsStr :: String -> IO () 10 | foreign import jscript "varTyArgs(%*)" varTyArgsInt :: Int -> IO () 11 | -------------------------------------------------------------------------------- /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/Makefile: -------------------------------------------------------------------------------- 1 | default: package.conf.inplace 2 | 3 | dist/setup-config: 4 | cabal configure --uhc 5 | 6 | package.conf.inplace: dist/setup-config 7 | cabal build --uhc-option="-tjs" 8 | 9 | clean: 10 | cabal clean 11 | 12 | .PHONY: clean 13 | -------------------------------------------------------------------------------- /uhc-js/uhc-js/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /uhc-js/uhc-js/clean: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | find . -iname "*.hi" -o -iname "*.js" -o -iname "*.mjs" -o -iname "*.html" -o -iname "*.core*" | xargs rm 3 | -------------------------------------------------------------------------------- /uhc-js/uhc-js/make: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | cd src && ${UHC} -tjs Main.hs 3 | -------------------------------------------------------------------------------- /uhc-js/uhc-js/src/Language/UHC/JS/Backbone.hs: -------------------------------------------------------------------------------- 1 | module Language.UHC.JS.Backbone where 2 | 3 | import Language.UHC.JS.Backbone.Collection 4 | import Language.UHC.JS.Backbone.Events 5 | import Language.UHC.JS.Backbone.Model 6 | import Language.UHC.JS.Backbone.Router 7 | import Language.UHC.JS.Backbone.History 8 | import Language.UHC.JS.Backbone.Sync 9 | import Language.UHC.JS.Backbone.View 10 | import Language.UHC.JS.Backbone.Utility 11 | -------------------------------------------------------------------------------- /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/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 | -------------------------------------------------------------------------------- /uhc-js/uhc-js/src/Language/UHC/JS/Backbone/History.hs: -------------------------------------------------------------------------------- 1 | module Language.UHC.JS.Backbone.History where 2 | 3 | import Language.UHC.JS.Primitives 4 | import Language.UHC.JS.Types 5 | 6 | foreign import js "Backbone.history.start()" 7 | start :: IO () 8 | 9 | foreign import js "Backbone.history.start(%*)" 10 | start' :: JSObject_ a -> IO () 11 | -------------------------------------------------------------------------------- /uhc-js/uhc-js/src/Language/UHC/JS/Backbone/Router.hs: -------------------------------------------------------------------------------- 1 | module Language.UHC.JS.Backbone.Router where 2 | 3 | import Language.UHC.JS.Primitives 4 | import Language.UHC.JS.ECMA.String 5 | import Language.UHC.JS.Types 6 | import Language.UHC.JS.Marshal 7 | import Language.UHC.JS.Prelude 8 | 9 | data BBRouterPtr 10 | type BBRouter = JSObject_ BBRouterPtr 11 | 12 | foreign import js "Backbone.Router.extend(%*)" 13 | extend :: JSObject_ a -> IO (JSFunction_ b) 14 | 15 | foreign import js "Backbone.Router.extend(%*)" 16 | extend' :: JSObject_ a -> JSObject_ b -> IO (JSFunction_ b) 17 | 18 | getRoutes :: BBRouter -> IO JSObject 19 | getRoutes = getAttr "routes" 20 | 21 | setRoutes :: JSObject_ a -> BBRouter -> IO BBRouter 22 | setRoutes = setAttr "routes" 23 | 24 | route :: BBRouter -> String -> String -> JSFunction_ a -> IO () 25 | route r s1 s2 f = _route r (toJS s1) (toJS s2) f 26 | 27 | foreign import js "%1.route(%*)" 28 | _route :: BBRouter -> JSString -> JSString -> JSFunction_ a -> IO () 29 | 30 | navigate :: String -> IO () 31 | navigate = _navigate . toJS 32 | 33 | foreign import js "%1.navigate(%*)" 34 | _navigate :: JSString -> IO () 35 | 36 | navigate' :: String -> Bool -> IO () 37 | navigate' s b = _navigate' (toJS s) b 38 | 39 | foreign import js "%1.navigate(%*)" 40 | _navigate' :: JSString -> Bool -> IO () 41 | 42 | -------------------------------------------------------------------------------- /uhc-js/uhc-js/src/Language/UHC/JS/Backbone/Sync.hs: -------------------------------------------------------------------------------- 1 | module Language.UHC.JS.Backbone.Sync where 2 | 3 | import Language.UHC.JS.Backbone.Model 4 | import Language.UHC.JS.Primitives 5 | import Language.UHC.JS.ECMA.String 6 | import Language.UHC.JS.Types 7 | import Language.UHC.JS.Marshal 8 | 9 | sync :: String -> BBModel a -> IO () 10 | sync s = _sync (toJS s) 11 | 12 | foreign import js "Backbone.sync(%*)" 13 | _sync :: JSString -> BBModel a -> IO () 14 | 15 | sync' :: String -> BBModel a -> JSObject_ b -> IO () 16 | sync' s = _sync' (toJS s) 17 | 18 | foreign import js "Backbone.sync(%*)" 19 | _sync' :: JSString -> BBModel a -> JSObject_ b -> IO () 20 | 21 | -- TODO: emulateHTTP 22 | -- TODO: emulateJSON 23 | -------------------------------------------------------------------------------- /uhc-js/uhc-js/src/Language/UHC/JS/Backbone/Utility.hs: -------------------------------------------------------------------------------- 1 | module Language.UHC.JS.Backbone.Utility where 2 | 3 | import Language.UHC.JS.Primitives 4 | import Language.UHC.JS.Types 5 | 6 | data BackbonePtr 7 | type Backbone = JSObject_ BackbonePtr 8 | 9 | foreign import js "Backbone.noConflict()" 10 | noConflict :: Backbone 11 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /uhc-js/uhc-js/src/Language/UHC/JS/ECMA.hs: -------------------------------------------------------------------------------- 1 | module Language.UHC.JS.ECMA where 2 | 3 | import Language.UHC.JS.ECMA.Array 4 | import Language.UHC.JS.ECMA.String 5 | 6 | -------------------------------------------------------------------------------- /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 -------------------------------------------------------------------------------- /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 | -} -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /uhc-js/uhc-js/src/Language/UHC/JS/HTML5/HTMLElement.hs: -------------------------------------------------------------------------------- 1 | module Language.UHC.JS.HTML5.HTMLElement 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.HTML5.Types 7 | import Language.UHC.JS.Prelude 8 | import Language.UHC.JS.JSRef 9 | 10 | onkeydown :: JSObject_ a -> JSRef ReadWrite (Event -> IO ()) 11 | onkeydown e = 12 | let g = do 13 | f <- getAttr "onkeydown" e 14 | if _primIsNull f 15 | then return $ const (return ()) 16 | else unwrapFunc1 (unsafeCoerce f) 17 | s f = wrapFunc1 f >>= \f -> setAttr_ "onkeydown" f e 18 | in newJSRef g s -------------------------------------------------------------------------------- /uhc-js/uhc-js/src/Language/UHC/JS/HTML5/HTMLImageElement.hs: -------------------------------------------------------------------------------- 1 | module Language.UHC.JS.HTML5.HTMLImageElement where 2 | 3 | import Language.UHC.JS.Prelude 4 | import Language.UHC.JS.Marshal 5 | import Language.UHC.JS.HTML5.Types 6 | 7 | foreign import js "new Image()" 8 | newImage :: IO HTMLImageElement 9 | 10 | src :: HTMLImageElement -> String -> IO () 11 | src e s = setAttr_ "src" (str s) e 12 | 13 | width :: HTMLImageElement -> Double -> IO () 14 | width e d = setAttr_ "width" d e 15 | 16 | getWidth :: HTMLImageElement -> IO Double 17 | getWidth e = getAttr "width" e 18 | 19 | height :: HTMLImageElement -> Double -> IO () 20 | height e d = setAttr_ "height" d e 21 | 22 | getHeight :: HTMLImageElement -> IO Double 23 | getHeight e = getAttr "height" e -------------------------------------------------------------------------------- /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 -------------------------------------------------------------------------------- /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_ -------------------------------------------------------------------------------- /uhc-js/uhc-js/src/Language/UHC/JS/HTML5/Window.hs: -------------------------------------------------------------------------------- 1 | module Language.UHC.JS.HTML5.Window where 2 | 3 | import Language.UHC.JS.HTML5.Types 4 | import Language.UHC.JS.Types 5 | import Language.UHC.JS.Marshal 6 | import Language.UHC.JS.Prelude 7 | 8 | foreign import js "window" 9 | window :: IO Window 10 | 11 | foreign import js "%1.setInterval(%*)" 12 | _setInterval :: Window -> JSFunction_ (IO ()) -> Int -> IO Int 13 | 14 | foreign import js "%1.alert(%*)" 15 | _alert :: Window -> JSString -> IO () 16 | 17 | setInterval :: Window -> IO () -> Int -> IO Int 18 | setInterval w f mils = do 19 | f' <- wrapFunc f 20 | _setInterval w f' mils 21 | 22 | alert :: Window -> String -> IO () 23 | alert w = _alert w . toJS 24 | 25 | foreign import js "%1.clearInterval(%*)" 26 | clearInterval :: Window -> Int -> IO () -------------------------------------------------------------------------------- /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 () -------------------------------------------------------------------------------- /uhc-js/uhc-js/src/Language/UHC/JS/JQuery/AjaxQueue.hs: -------------------------------------------------------------------------------- 1 | -- | Binding for the jquery-ajaxq library by Oleg Podolsky. 2 | -- It can be found at: http://code.google.com/p/jquery-ajaxq/ 3 | module Language.UHC.JS.JQuery.AjaxQueue (ajaxQ) where 4 | 5 | import Language.UHC.JS.Types 6 | import Language.UHC.JS.Marshal 7 | import Language.UHC.JS.JQuery.Ajax 8 | 9 | -- | Partial application of the backend for use with the AjaxQueue library 10 | ajaxQ :: String -> AjaxOptions a -> v -> AjaxCallback r -> AjaxCallback r -> IO () 11 | ajaxQ queuename = ajaxBackend (_ajaxQ $ toJS queuename) 12 | 13 | foreign import js "$.ajaxq(%*)" 14 | _ajaxQ :: JSString -> JSAny a -> IO () -------------------------------------------------------------------------------- /uhc-js/uhc-js/src/Language/UHC/JS/JQuery/Deferred.hs: -------------------------------------------------------------------------------- 1 | module Language.UHC.JS.JQuery.Deferred where 2 | 3 | import Language.UHC.JS.Prelude 4 | import Language.UHC.JS.Types 5 | 6 | boundExecution :: IO a -> IO a -> Int -> (a -> IO b) -> (a -> IO b) -> IO () 7 | boundExecution calc fallback timeout onCalc onFallback = do 8 | calc' <- wrapFunc calc 9 | fallback' <- wrapFunc fallback 10 | onCalc' <- wrapFunc1 onCalc 11 | onFallback' <- wrapFunc1 onFallback 12 | _boundExecution calc' fallback' timeout onCalc' onFallback' 13 | 14 | foreign import js "boundExecution(%*)" 15 | _boundExecution :: JSFunction_ (IO a) -> JSFunction_ (IO a) -> Int -> JSFunction_ (a -> IO b) -> JSFunction_ (a -> IO b) -> IO () -------------------------------------------------------------------------------- /uhc-js/uhc-js/src/Language/UHC/JS/JQuery/Draggable.hs: -------------------------------------------------------------------------------- 1 | module Language.UHC.JS.JQuery.Draggable where 2 | 3 | import Language.UHC.JS.Prelude 4 | import Language.UHC.JS.Types 5 | import Language.UHC.JS.JQuery.JQuery 6 | 7 | data Draggable = Draggable { scroll :: JSBool, containment :: JSString, 8 | revert :: JSBool, revertDuration :: Int, 9 | scrollSensitivity :: Int, 10 | start :: JUIEventHandler} 11 | 12 | data JSDraggablePtr 13 | type JSDraggable = JSObject_ JSDraggablePtr 14 | 15 | draggable :: JQuery -> Draggable -> IO () 16 | draggable jq drag = 17 | do jsdrag <- mkJSDraggable drag 18 | _draggable jq jsdrag 19 | 20 | foreign import js "{}" 21 | mkJSDraggable :: Draggable -> IO JSDraggable 22 | 23 | foreign import js "%1.draggable(%2)" 24 | _draggable :: JQuery -> JSDraggable -> IO () 25 | -------------------------------------------------------------------------------- /uhc-js/uhc-js/src/Language/UHC/JS/JQuery/Droppable.hs: -------------------------------------------------------------------------------- 1 | module Language.UHC.JS.JQuery.Droppable where 2 | 3 | import Language.UHC.JS.Prelude 4 | import Language.UHC.JS.Types 5 | import Language.UHC.JS.JQuery.JQuery 6 | 7 | data Droppable = Droppable { hoverClass :: JSString, 8 | drop :: JUIEventHandler} 9 | 10 | data JSDroppablePtr 11 | type JSDroppable = JSObject_ JSDroppablePtr 12 | 13 | droppable :: JQuery -> Droppable -> IO () 14 | droppable jq drop = 15 | do jsdrop <- mkObj drop 16 | _droppable jq jsdrop 17 | 18 | foreign import js "%1.droppable(%2)" 19 | _droppable :: JQuery -> JSDroppable -> IO () -------------------------------------------------------------------------------- /uhc-js/uhc-js/src/Language/UHC/JS/JSON2/JSON2.hs: -------------------------------------------------------------------------------- 1 | module Language.UHC.JS.JSON2.JSON2 where 2 | 3 | -- | Wrapper for json2.js, as found at http://documentcloud.github.com/backbone 4 | 5 | import Language.UHC.JS.ECMA.Array 6 | import Language.UHC.JS.ECMA.String 7 | import Language.UHC.JS.Primitives 8 | import Language.UHC.JS.Types 9 | import Language.UHC.JS.Marshal 10 | 11 | 12 | data JSONPtr 13 | type JSON = JSObject_ JSONPtr 14 | 15 | stringify :: JSAny a -> IO String 16 | stringify = liftFromJS_ . _stringify 17 | 18 | foreign import js "JSON.stringify(%*)" 19 | _stringify :: JSAny a -> IO JSString 20 | 21 | stringify' :: JSArray a -> IO String 22 | stringify' = liftFromJS_ . _stringify' 23 | 24 | foreign import js "JSON.stringify(%*)" 25 | _stringify' :: JSArray a -> IO JSString 26 | 27 | -- TODO: All permutations for stringify 28 | 29 | parse :: String -> IO (JSAny a) 30 | parse = _parse . toJS 31 | 32 | parse' :: String -> IO () -> IO (JSAny a) 33 | parse' s c = _parse' (toJS s) c 34 | 35 | foreign import js "JSON.parse(%*)" 36 | _parse :: JSString -> IO (JSAny a) 37 | 38 | foreign import js "JSON.parse(%*)" 39 | _parse' :: JSString -> IO () -> IO (JSAny a) 40 | -------------------------------------------------------------------------------- /uhc-js/uhc-js/src/Language/UHC/JS/JSRef.hs: -------------------------------------------------------------------------------- 1 | module Language.UHC.JS.JSRef ( 2 | JSRef 3 | , newReadOnlyJSRef 4 | , newJSRef 5 | , readJSRef 6 | , writeJSRef 7 | , ReadWrite 8 | , Read 9 | ) where 10 | 11 | import Language.UHC.JS.Types 12 | 13 | data Lens a = Lens (IO a) (a -> IO ()) 14 | newtype JSRef t a = JSRef (Lens a) 15 | 16 | data Read 17 | data ReadWrite 18 | 19 | newReadOnlyJSRef :: IO a -> JSRef Read a 20 | newReadOnlyJSRef r = unsafeCoerce $ newJSRef r (error "read only ref") 21 | 22 | newJSRef :: IO a -> (a -> IO ()) -> JSRef ReadWrite a 23 | newJSRef r w = JSRef (Lens r w) 24 | 25 | readJSRef :: JSRef t a -> IO a 26 | readJSRef (JSRef (Lens r _)) = r 27 | 28 | writeJSRef :: JSRef ReadWrite a -> a -> IO () 29 | writeJSRef (JSRef (Lens _ w)) = w -------------------------------------------------------------------------------- /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/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 | -------------------------------------------------------------------------------- /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/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | module Language.UHC.JS.Types where 3 | 4 | import Control.Monad 5 | import UHC.BoxArray (BoxArray) 6 | 7 | data JSAny a 8 | 9 | data JSUndefined_ 10 | type JSUndefined = JSAny JSUndefined_ 11 | 12 | data JSNull_ 13 | type JSNull = JSAny JSNull_ 14 | 15 | data CJSObject_ a 16 | type JSObject_ a = JSAny (CJSObject_ a) 17 | type JSObject = JSObject_ () 18 | 19 | data JSBool_ 20 | type JSBool = JSObject_ JSBool_ 21 | 22 | type JSString = JSObject_ PackedString 23 | 24 | data CJSFunction_ a 25 | type JSFunction_ a = JSObject_ (CJSFunction_ a) 26 | 27 | data JSRegex_ 28 | type JSRegex = JSObject_ JSRegex_ 29 | 30 | type JSArray v = JSObject_ (BoxArray v) 31 | 32 | foreign import js "null" 33 | _null :: JSNull 34 | 35 | foreign import js "undefined" 36 | _undefined :: JSUndefined 37 | 38 | foreign import js "true" 39 | _true :: JSBool 40 | 41 | foreign import js "false" 42 | _false :: JSBool 43 | 44 | foreign import js "''" 45 | _string :: JSString 46 | 47 | foreign import js "new Array()" 48 | _array :: JSArray k a -------------------------------------------------------------------------------- /uhc-js/uhc-js/src/Language/UHC/JS/WebWorker.hs: -------------------------------------------------------------------------------- 1 | module Language.UHC.JS.WebWorker where 2 | 3 | import Language.UHC.JS.Prelude 4 | 5 | data WebWorkerPtr 6 | type WebWorker = JSPtr WebWorkerPtr 7 | 8 | newWorker :: String -> IO WebWorker 9 | newWorker = _newWorker . toJS 10 | 11 | foreign import js "newWorker(%1)" 12 | _newWorker :: JSString -> IO WebWorker 13 | 14 | setOnMessage :: WebWorker -> (JSPtr a -> IO ()) -> IO () 15 | setOnMessage self f = do 16 | f' <- wrapJSPtraIO f 17 | setAttr "onmessage" f' self 18 | return () 19 | 20 | foreign import js "JSON.stringify(%1)" 21 | jsonStringify :: a -> JSString 22 | 23 | foreign import js "JSON.parse(%1)" 24 | jsonParse :: JSString -> IO a 25 | 26 | postMessage :: WebWorker -> a -> IO () 27 | postMessage = _postMessage 28 | 29 | foreign import js "%1.postMessage(%2)" 30 | _postMessage :: WebWorker -> a -> IO () 31 | 32 | foreign import js "self" 33 | getSelf :: IO WebWorker -------------------------------------------------------------------------------- /uhc-js/uhc-js/src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Language.UHC.JS.Backbone 4 | import Language.UHC.JS.ECMA 5 | import Language.UHC.JS.JSRef 6 | import Language.UHC.JS.JQuery.JQuery 7 | import Language.UHC.JS.JQuery.Ajax 8 | import Language.UHC.JS.JQuery.AjaxQueue 9 | import Language.UHC.JS.JQuery.Deferred 10 | import Language.UHC.JS.JQuery.Draggable 11 | import Language.UHC.JS.JQuery.Droppable 12 | import Language.UHC.JS.JSON2.JSON2 13 | import Language.UHC.JS.Types 14 | import Language.UHC.JS.HTML5.HTMLCanvasElement 15 | import Language.UHC.JS.HTML5.CanvasRenderingContext2D 16 | import Language.UHC.JS.HTML5.Window 17 | import Language.UHC.JS.HTML5.HTMLElement 18 | import Language.UHC.JS.W3C.HTML5 19 | 20 | main :: IO () 21 | main = undefined 22 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /wxasteroids/.gitignore: -------------------------------------------------------------------------------- 1 | *.c 2 | *.o 3 | *.class 4 | *.core 5 | *.hi 6 | *.grin 7 | *.swp 8 | *-cpp.hs 9 | *.hs-cpp 10 | *~ 11 | *.mjs 12 | *sublime* 13 | src/Asteroids.html 14 | src/Asteroids.js 15 | deps 16 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /wxasteroids/Makefile: -------------------------------------------------------------------------------- 1 | CPPHS=cpphs 2 | UHC-OPT=--pgmP=${CPPHS} --optP=--noline --optP=--hashes 3 | TARGET=js 4 | MAIN=Asteroids.hs 5 | OOLight=../../lightoo/src 6 | JSPRELUDE=../../uhc-js/uhc-js/src 7 | 8 | default: all 9 | 10 | all: 11 | cd src && ${UHC} ${UHC-OPT} -t${TARGET} --import-path="../" --import-path="../contravariant-0.1.2" --import-path="${OOLight}" --import-path="${JSPRELUDE}" ${MAIN} 12 | cd ../ 13 | 14 | ghci: 15 | cd src && ghci -I${OOLight} -i${OOLight} -isrc ${MAIN} 16 | cd ../ 17 | 18 | clean: 19 | find . -type f \( -name "*.grin" -o -name "*.c" -o -name "*.o" -o -name "*.hs-cpp" -o -name "*.hi" -o -name "*.core" -o -name "*.mjs" -o -name "*.html" \) | xargs --no-run-if-empty rm 20 | 21 | .PHONY: clean, tests 22 | -------------------------------------------------------------------------------- /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 | ![wxAsteroids in the browser](https://raw.github.com/UU-ComputerScience/js-asteroids/master/msc-thesis/resources/browser_wxasteroids.png) 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/build/Asteroids.html: -------------------------------------------------------------------------------- 1 | Asteroids 2 | 3 | 4 | 5 | 8 | 9 | 10 | -------------------------------------------------------------------------------- /wxasteroids/build/burning.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/UU-ComputerScience/js-asteroids/b7015d8ad4aa57ff30f2631e0945462f6e1ef47a/wxasteroids/build/burning.ico -------------------------------------------------------------------------------- /wxasteroids/build/rock.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/UU-ComputerScience/js-asteroids/b7015d8ad4aa57ff30f2631e0945462f6e1ef47a/wxasteroids/build/rock.ico -------------------------------------------------------------------------------- /wxasteroids/build/ship.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/UU-ComputerScience/js-asteroids/b7015d8ad4aa57ff30f2631e0945462f6e1ef47a/wxasteroids/build/ship.ico -------------------------------------------------------------------------------- /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 | -} -------------------------------------------------------------------------------- /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/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 | -------------------------------------------------------------------------------- /wxasteroids/contravariant-0.1.2/Setup.lhs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/runhaskell 2 | > module Main (main) where 3 | 4 | > import Distribution.Simple 5 | 6 | > main :: IO () 7 | > main = defaultMain 8 | -------------------------------------------------------------------------------- /wxasteroids/contravariant-0.1.2/contravariant.cabal: -------------------------------------------------------------------------------- 1 | name: contravariant 2 | category: Control, Data 3 | version: 0.1.2 4 | license: BSD3 5 | cabal-version: >= 1.6 6 | license-file: LICENSE 7 | author: Edward A. Kmett 8 | maintainer: Edward A. Kmett 9 | stability: provisional 10 | homepage: http://github.com/ekmett/contravariant/ 11 | copyright: Copyright (C) 2007-2011 Edward A. Kmett 12 | synopsis: Haskell 98 contravariant functors 13 | description: Haskell 98 contravariant functors 14 | build-type: Simple 15 | 16 | source-repository head 17 | type: git 18 | location: git://github.com/ekmett/contravariant.git 19 | 20 | library 21 | build-depends: 22 | base < 4.5, 23 | transformers >= 0.2.2 && < 0.3 24 | exposed-modules: 25 | Data.Functor.Contravariant 26 | Data.Functor.Contravariant.Compose 27 | ghc-options: -Wall 28 | -------------------------------------------------------------------------------- /wxasteroids/resources/burning.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/UU-ComputerScience/js-asteroids/b7015d8ad4aa57ff30f2631e0945462f6e1ef47a/wxasteroids/resources/burning.ico -------------------------------------------------------------------------------- /wxasteroids/resources/rock.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/UU-ComputerScience/js-asteroids/b7015d8ad4aa57ff30f2631e0945462f6e1ef47a/wxasteroids/resources/rock.ico -------------------------------------------------------------------------------- /wxasteroids/resources/ship.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/UU-ComputerScience/js-asteroids/b7015d8ad4aa57ff30f2631e0945462f6e1ef47a/wxasteroids/resources/ship.ico -------------------------------------------------------------------------------- /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/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) -------------------------------------------------------------------------------- /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/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 -------------------------------------------------------------------------------- /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/WX/Variable.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | {-| Module : Variable 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 | Mutable variables. 11 | -} 12 | -------------------------------------------------------------------------------- 13 | module Graphics.UI.WX.Variable where 14 | 15 | --import Control.Concurrent.STM.TVar 16 | import Graphics.UI.WX.Types( Var, varGet, varSet, varCreate, varUpdate ) 17 | import Graphics.UI.WX.Attributes 18 | import Graphics.UI.WX.Classes 19 | 20 | {-------------------------------------------------------------------- 21 | 22 | --------------------------------------------------------------------} 23 | --instance Valued TVar where 24 | -- value = makeAttr "value" varGet varSet varUpdate 25 | 26 | -- | Create a mutable variable. Change the value using the |value| attribute. 27 | variable :: [Prop (Var a)] -> IO (Var a) 28 | variable props 29 | = do v <- varCreate (error "Graphics.UI.WX.Variable: uninitialized variable, use the 'value' attribute at creation") 30 | set v props 31 | return v 32 | -------------------------------------------------------------------------------- /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 -------------------------------------------------------------------------------- /wxasteroids/src/Graphics/UI/WXCore/Event.hs: -------------------------------------------------------------------------------- 1 | module Graphics.UI.WXCore.Event ( 2 | module Graphics.UI.WXCore.EventClass 3 | ,event 4 | ) where 5 | 6 | import LightOO 7 | import Graphics.UI.WXCore.EventClass 8 | import Data.IORef 9 | 10 | event id eventType = 11 | (event' `extends` object) noOverride set_Object_Tail 12 | where 13 | event' tail super self = do 14 | source <- newIORef Nothing 15 | return EventClass { 16 | _eventGetType = return eventType 17 | ,_eventGetId = return id 18 | ,_eventGetSkipped = return False 19 | ,_eventGetEventObject = readIORef source 20 | ,_eventSetEventObject = writeIORef source . Just 21 | ,_eventSkip = \_ -> return () 22 | ,_eventStopPropagation = return () 23 | ,_eventTail = tail 24 | } -------------------------------------------------------------------------------- /wxasteroids/src/Graphics/UI/WXCore/EventClass.hs: -------------------------------------------------------------------------------- 1 | {- 2 | http://docs.wxwidgets.org/trunk/classwx_event.html 3 | -} 4 | {-# LANGUAGE CPP, StandaloneDeriving, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable #-} 5 | {-# OPTIONS -pgmP cpp #-} 6 | module Graphics.UI.WXCore.EventClass where 7 | 8 | import LightOO 9 | import Data.Typeable 10 | import Graphics.UI.WXCore.Types 11 | 12 | #ifdef __UHC__ 13 | #include "Typeable.h" 14 | #include "LightOOUHC.h" 15 | #else 16 | #include "LightOO.h" 17 | #endif 18 | 19 | data EventClass a = EventClass { 20 | _eventGetType :: IO EventType 21 | ,_eventGetId :: IO Id 22 | ,_eventGetSkipped :: IO Bool 23 | ,_eventGetEventObject :: IO (Maybe Object) 24 | ,_eventSetEventObject :: Object -> IO () 25 | ,_eventSkip :: Bool -> IO () 26 | ,_eventStopPropagation :: IO () 27 | ,_eventTail :: Record a 28 | } 29 | DefineSubClass(Event,Object,EventClass,eventTail,,,,1,) 30 | 31 | #ifdef __UHC__ 32 | INSTANCE_TYPEABLE1(EventClass,eventTc,"Event") 33 | #endif 34 | 35 | event_Methods = unRecord . get_Object_Tail 36 | eventGetType = _eventGetType . event_Methods 37 | eventGetId = _eventGetId . event_Methods 38 | eventSkip = _eventSkip . event_Methods 39 | eventGetEventObject = _eventGetEventObject . event_Methods 40 | eventSetEventObject = _eventSetEventObject . event_Methods -------------------------------------------------------------------------------- /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 | } -------------------------------------------------------------------------------- /wxasteroids/src/Graphics/UI/WXCore/GraphicsBitmap.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, StandaloneDeriving, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable #-} 2 | {-# OPTIONS -pgmP cpp #-} 3 | module Graphics.UI.WXCore.GraphicsBitmap ( 4 | module Graphics.UI.WXCore.GraphicsBitmapClass 5 | , bitmap 6 | ) where 7 | 8 | import LightOO 9 | import Data.Typeable 10 | import Graphics.UI.WXCore.Types 11 | import Graphics.UI.WXCore.GraphicsBitmapClass 12 | import Graphics.UI.WXCore.GraphicsObject 13 | #ifdef __UHC__ 14 | import Language.UHC.JS.HTML5.HTMLImageElement 15 | #else 16 | newImage = undefined 17 | src = undefined 18 | #endif 19 | 20 | bitmap source = 21 | (bitmap' `extends` graphicsObject) noOverride set_GraphicsObject_Tail 22 | where 23 | bitmap' tail super self = do 24 | return GraphicsBitmapClass { 25 | _graphicsBitmapGetNativeBitmap = do 26 | img <- newImage 27 | src img source 28 | return img 29 | , _graphicsBitmapTail = tail 30 | } -------------------------------------------------------------------------------- /wxasteroids/src/Graphics/UI/WXCore/GraphicsBitmapClass.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, StandaloneDeriving, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable #-} 2 | {-# OPTIONS -pgmP cpp #-} 3 | module Graphics.UI.WXCore.GraphicsBitmapClass where 4 | 5 | #ifdef __UHC__ 6 | #include "Typeable.h" 7 | #include "LightOOUHC.h" 8 | #else 9 | #include "LightOO.h" 10 | #endif 11 | 12 | import LightOO 13 | import Data.Typeable 14 | import Graphics.UI.WXCore.Types 15 | import Graphics.UI.WXCore.GraphicsObjectClass 16 | #ifdef __UHC__ 17 | import Language.UHC.JS.HTML5.HTMLImageElement 18 | import Language.UHC.JS.HTML5.Types 19 | #else 20 | data HTMLImageElement 21 | #endif 22 | 23 | data GraphicsBitmapClass t = GraphicsBitmapClass { 24 | _graphicsBitmapGetNativeBitmap :: IO HTMLImageElement 25 | , _graphicsBitmapTail :: Record t 26 | } 27 | 28 | DefineSubClass(GraphicsBitmap,GraphicsObject,GraphicsBitmapClass,graphicsBitmapTail,,,,1,) 29 | 30 | #ifdef __UHC__ 31 | INSTANCE_TYPEABLE1(GraphicsBitmapClass,graphicsBitmapTc,"GraphicsBitmap") 32 | #endif 33 | 34 | graphicsBitmap_Methods = unRecord . get_GraphicsObject_Tail 35 | 36 | graphicsBitmapGetNativeBitmap = _graphicsBitmapGetNativeBitmap . graphicsBitmap_Methods 37 | -------------------------------------------------------------------------------- /wxasteroids/src/Graphics/UI/WXCore/GraphicsObject.hs: -------------------------------------------------------------------------------- 1 | module Graphics.UI.WXCore.GraphicsObject ( 2 | module Graphics.UI.WXCore.GraphicsObjectClass 3 | ,graphicsObject 4 | ) where 5 | 6 | import LightOO 7 | import Graphics.UI.WXCore.GraphicsObjectClass 8 | 9 | graphicsObject = 10 | (graphicsObject' `extends` object) noOverride set_Object_Tail 11 | where 12 | graphicsObject' tail super self = 13 | return GraphicsObjectClass { 14 | _graphicsObjectTail = tail 15 | } -------------------------------------------------------------------------------- /wxasteroids/src/Graphics/UI/WXCore/GraphicsObjectClass.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, StandaloneDeriving, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable #-} 2 | {-# OPTIONS -pgmP cpp #-} 3 | module Graphics.UI.WXCore.GraphicsObjectClass where 4 | 5 | #ifdef __UHC__ 6 | #include "Typeable.h" 7 | #include "LightOOUHC.h" 8 | #else 9 | #include "LightOO.h" 10 | #endif 11 | 12 | import LightOO 13 | import Data.Typeable 14 | import Graphics.UI.WXCore.Types 15 | --import Graphics.UI.WXCore.GraphicsRendererClass 16 | 17 | data GraphicsObjectClass a = GraphicsObjectClass { 18 | -- commented out because it causes a cycle in modules deps 19 | -- _graphicsObjectGetRenderer :: IO GraphicsRenderer 20 | _graphicsObjectTail :: Record a 21 | } 22 | DefineSubClass(GraphicsObject,Object,GraphicsObjectClass,graphicsObjectTail,,,,1,) 23 | 24 | #ifdef __UHC__ 25 | INSTANCE_TYPEABLE1(GraphicsObjectClass,graphicsObjectTc,"GraphicsObject") 26 | #endif 27 | 28 | graphicsObject_Methods = unRecord . get_Object_Tail -------------------------------------------------------------------------------- /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 -------------------------------------------------------------------------------- /wxasteroids/src/Graphics/UI/WXCore/GraphicsRendererClass.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, StandaloneDeriving, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable #-} 2 | {-# OPTIONS -pgmP cpp #-} 3 | module Graphics.UI.WXCore.GraphicsRendererClass where 4 | 5 | #ifdef __UHC__ 6 | #include "Typeable.h" 7 | #include "LightOOUHC.h" 8 | #else 9 | #include "LightOO.h" 10 | #endif 11 | 12 | import LightOO 13 | import Data.Typeable 14 | import Graphics.UI.WXCore.Types 15 | import Graphics.UI.WXCore.WindowClass 16 | import Graphics.UI.WXCore.GraphicsContextClass 17 | 18 | data GraphicsRendererClass a = GraphicsRendererClass { 19 | _graphicsRendererCreateContextFromWindow :: Window -> IO GraphicsContext 20 | ,_graphicsRendererTail :: Record a 21 | } 22 | DefineSubClass(GraphicsRenderer,Object,GraphicsRendererClass,graphicsRendererTail,,,,1,) 23 | 24 | graphicsRendererCreateContextFromWindow = _graphicsRendererCreateContextFromWindow . unRecord . get_Object_Tail 25 | 26 | #ifdef __UHC__ 27 | INSTANCE_TYPEABLE1(GraphicsRendererClass,graphicsRendererTc,"GraphicsRenderer") 28 | #endif 29 | 30 | -------------------------------------------------------------------------------- /wxasteroids/src/Graphics/UI/WXCore/KeyEvent.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE StandaloneDeriving, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable #-} 2 | module Graphics.UI.WXCore.KeyEvent ( 3 | module Graphics.UI.WXCore.KeyEventClass 4 | ,keyEvent 5 | ) where 6 | 7 | import LightOO 8 | import Graphics.UI.WXCore.Types 9 | import Graphics.UI.WXCore.KeyEventClass 10 | import Graphics.UI.WXCore.Event 11 | 12 | keyEvent id x y keyCode unicode = 13 | (keyEvent' `extends` event id wxEVT_CHAR) noOverride set_Event_Tail 14 | where 15 | keyEvent' tail super self = 16 | return KeyEventClass { 17 | _keyEventGetKeyCode = return keyCode 18 | ,_keyEventGetX = return x 19 | ,_keyEventGetY = return y 20 | ,_keyEventGetUnicodeKey = return unicode 21 | ,_keyEventTail = tail 22 | } 23 | -------------------------------------------------------------------------------- /wxasteroids/src/Graphics/UI/WXCore/KeyEventClass.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, StandaloneDeriving, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable #-} 2 | {-# OPTIONS -pgmP cpp #-} 3 | module Graphics.UI.WXCore.KeyEventClass where 4 | 5 | import LightOO 6 | import Data.Typeable 7 | import Data.IORef 8 | import Graphics.UI.WXCore.Types 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 KeyEventClass a = KeyEventClass { 19 | -- only used for modifiers 20 | --_keyboardState :: KeyboardState 21 | _keyEventGetKeyCode :: IO Int 22 | ,_keyEventGetX :: IO Int 23 | ,_keyEventGetY :: IO Int 24 | ,_keyEventGetUnicodeKey :: IO String 25 | ,_keyEventTail :: Record a 26 | } 27 | 28 | DefineSubClass(KeyEvent,Event,KeyEventClass,keyEventTail,,,,1,) 29 | 30 | #ifdef __UHC__ 31 | INSTANCE_TYPEABLE1(KeyEventClass,keyEventTc,"KeyEvent") 32 | #endif 33 | 34 | keyEvent_methods = unRecord . get_Event_Tail 35 | keyEventGetKeyCode = _keyEventGetKeyCode . keyEvent_methods 36 | keyEventGetX = _keyEventGetX . keyEvent_methods 37 | keyEventGetY = _keyEventGetY . keyEvent_methods 38 | keyEventGetUnicodeKey = _keyEventGetUnicodeKey . keyEvent_methods -------------------------------------------------------------------------------- /wxasteroids/src/Graphics/UI/WXCore/PaintEvent.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE StandaloneDeriving, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable #-} 2 | module Graphics.UI.WXCore.PaintEvent ( 3 | module Graphics.UI.WXCore.PaintEventClass 4 | ,paintEvent 5 | ) where 6 | 7 | import LightOO 8 | import Graphics.UI.WXCore.Types 9 | import Graphics.UI.WXCore.PaintEventClass 10 | import Graphics.UI.WXCore.Event 11 | 12 | paintEvent id = 13 | (paintEvent' `extends` event id wxEVT_PAINT) noOverride set_Event_Tail 14 | where 15 | paintEvent' tail super self = 16 | return PaintEventClass { 17 | _paintEventTail = tail 18 | } 19 | -------------------------------------------------------------------------------- /wxasteroids/src/Graphics/UI/WXCore/PaintEventClass.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, StandaloneDeriving, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable #-} 2 | {-# OPTIONS -pgmP cpp #-} 3 | module Graphics.UI.WXCore.PaintEventClass where 4 | 5 | import LightOO 6 | import Data.Typeable 7 | import Data.IORef 8 | import Graphics.UI.WXCore.Types 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 PaintEventClass a = PaintEventClass { 19 | _paintEventTail :: Record a 20 | } 21 | 22 | DefineSubClass(PaintEvent,Event,PaintEventClass,paintEventTail,,,,1,) 23 | 24 | #ifdef __UHC__ 25 | INSTANCE_TYPEABLE1(PaintEventClass,paintEventTc,"PaintEvent") 26 | #endif -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 --------------------------------------------------------------------------------