twentefp-eventloop-graphics 0.1.0.0 → 0.1.0.4
raw patch · 17 files changed
Files
- src/EventLoop.hs +16/−0
- src/EventLoop/CommonTypes.hs +26/−8
- src/EventLoop/Config.hs +17/−2
- src/EventLoop/EventProcessor.hs +66/−46
- src/EventLoop/Input/InputEvent.hs +21/−3
- src/EventLoop/Input/Keyboard.hs +15/−5
- src/EventLoop/Input/Mouse.hs +26/−15
- src/EventLoop/Input/SystemMessage.hs +20/−4
- src/EventLoop/Json.hs +57/−24
- src/EventLoop/Main.hs +18/−2
- src/EventLoop/Output.hs +1/−0
- src/EventLoop/Output/Graphical/Graphical.hs +93/−61
- src/EventLoop/Output/OutputEvent.hs +18/−1
- src/EventLoop/Output/Single.hs +63/−26
- src/EventLoop/Output/SystemMessage.hs +35/−9
- src/FPPrac/Graphics/NormalizeNumber.hs +49/−0
- twentefp-eventloop-graphics.cabal +7/−6
src/EventLoop.hs view
@@ -1,3 +1,19 @@+{-| +Module : EventLoop +Description : Complete import of all the exposed features of this library. +Copyright : (c) Sebastiaan la Fleur, 2014 +License : BSD3 +Maintainer : sebastiaan.la.fleur@gmail.com +Stability : experimental +Portability : All + +Complete import of all the exposed features of this library. +The Eventloop package is used to express the communication between a Haskell server and a program modelling an \'IO Device'. +This package contains an example implementation of how such a server would like when a browser is used as a graphical IO device also containing a mouse and keyboard. +The 'EventLoop.Input.InputEvents.InputEvent' models the possible mouse and keyboard events. The 'EventLoop.Output.OutputEvents.OutputEvent' models the possible graphical +output events. There are also input and output systemmessages to communicate metadata between the Haskell server and the graphical IO browser. +The starting point for this example implementation is 'EventLoop.Main.start'. +-} module EventLoop( start, Pos,
src/EventLoop/CommonTypes.hs view
@@ -1,11 +1,29 @@-module EventLoop.CommonTypes( - Pos, - Dimension, - Element -) where +{-| +Module : EventLoop.CommonTypes +Description : All common types throughout the "EventLoop" module +Copyright : (c) Sebastiaan la Fleur, 2014 +License : BSD3 +Maintainer : sebastiaan.la.fleur@gmail.com +Stability : experimental +Portability : All -import FPPrac +All common types throughout the "EventLoop" module +-} +module EventLoop.CommonTypes + ( Pos + , Dimension + , Element + ) where -type Pos = (Number, Number) -- (x, y) -type Dimension = (Number, Number) -- (h, w) +{-| + Type to express a position on the screen. + It uses the format (x,y). + As Canvas is used in the example implementation, remember that the lefttop corner is (0,0) and the leftbottom corner is (0, height of screen). +-} +type Pos = (Float,Float) + +-- | Type to express the dimension of an element. It uses the format (w,h). +type Dimension = (Float, Float) + +-- | The name of a graphical element. It is used for 'EventLoop.Input.Mouse' to express the name of which element is clicked on. type Element = [Char]
src/EventLoop/Config.hs view
@@ -1,11 +1,23 @@+{-| +Module : EventLoop.Config +Description : All string literals used through the "EventLoop" module +Copyright : (c) Sebastiaan la Fleur, 2014 +License : BSD3 +Maintainer : sebastiaan.la.fleur@gmail.com +Stability : experimental +Portability : All + +All string literals used through the "EventLoop" module +-} module EventLoop.Config where import FPPrac ------------------ --- Server Settings +-- | The server listening address used. It is set to localhost (127.0.0.1). ipadres = "127.0.0.1" -port = 9161 :: Number +-- | The server port number used. It is set to 9161. +port = 9161 :: Int ----------- -- Response modes @@ -17,6 +29,7 @@ moveelementS = "moveelement" removegroupS = "removegroup" removeelementS = "removeelement" +clearallS = "clearall" gobjectS = "gobject" nameS = "name" @@ -93,7 +106,9 @@ canvassetupS = "canvassetup" dimensionS = "dimension" timerS = "timer" +timedataS = "timedata" useS = "use" +iS = "i" closeS = "close"
src/EventLoop/EventProcessor.hs view
@@ -1,7 +1,23 @@+{-| +Module : EventLoop.EventProcessor +Description : Low-level eventloop framework. Uses 'IOMessage's to communicate. +Copyright : (c) Sebastiaan la Fleur, 2014 +License : BSD3 +Maintainer : sebastiaan.la.fleur@gmail.com +Stability : experimental +Portability : All + +Low-level eventloop framework. Uses 'IOMessage's to communicate. +This module can be used to express your own 'EventLoop.Input.InputEvent's and 'EventLoop.Output.OutputEvent's. +For instance, we have a keyboard and mouse 'EventLoop.Input.InputEvent' example included in this module\'s implementation. +But it might be that you want to define your own 'EventLoop.Input.InputEvent' structure. In that case, you can define your own +'FromJSON' class to express how the literal 'IOMessage' should be parsed into your own 'EventLoop.Input.InputEvent' datatype. +The same goes for 'EventLoop.Output.OutputEvent' of course. An 'IOMessage' is a 'String' literal that the client sends. The accompanied +standard webpage uses JSON as a protocol to express these 'String' literals. +-} module EventLoop.EventProcessor(eventloop, IOMessage, readRequest, sendResponse) where import qualified Network.WebSockets as WS -import Control.Exception (handle, fromException, AsyncException(..), onException) import qualified Data.Text as T import Data.String (String) import Data.Char (isLower, isDigit) @@ -10,54 +26,58 @@ import EventLoop.Json import EventLoop.Config -import Debug.Trace - +-- | Type of the message that is used to communicate with the IO device. In this example implementation a webbrowser is used and the messages use JSON encoding. type IOMessage = JSONMessage --- Start connection -eventloop :: (a -> IOMessage -> ([IOMessage], a)) -> a -> IO () -eventloop eh beginState = WS.runServer ipadres (fromIntegral port) $ application eh beginState - -application :: (a -> IOMessage -> ([IOMessage], a)) -> a -> WS.PendingConnection -> IO () -application eh beginState pending = do - conn <- WS.acceptRequest pending - onException (doEvents eh beginState conn) (putStrLn "text1") - --handle (catchUserInterrupt conn) $ handle (catchDisconnect conn) $ doEvents eh beginState conn - return () - --- Connection functions -catchDisconnect :: WS.Connection -> WS.ConnectionException -> IO () -catchDisconnect conn e = case e of - WS.ConnectionClosed -> putStrLn "Connection closed!" - WS.CloseRequest code reason -> putStrLn "test1" - --- User Interrupt -catchUserInterrupt :: WS.Connection -> AsyncException -> IO() -catchUserInterrupt conn e = case e of - UserInterrupt -> putStrLn "test2" - ThreadKilled -> putStrLn "test3" +{- | + Low-level function to call when dealing with IOMessages directly. + If you want to use the example implementation using the 'EventLoop.Input.InputEvent' and 'EventLoop.Output.OutputEvent' + , you should use the 'EventLoop.Main.start' function. +-} +eventloop :: (a -> IOMessage -> ([IOMessage], a)) -- ^ The eventhandler eh that maps incoming 'IOMessage's to outgoing 'IOMessage's. It uses a variable of type a to store information in between calls to the event handler. + -> a -- ^ The begin store. It should be changed in the eventhandler function. + -> IO () +eventloop eh beginState = WS.server ipadres port $ doEvents eh beginState --- Event Loop -doEvents :: (a -> IOMessage -> ([IOMessage], a)) -> a -> WS.Connection -> IO () -doEvents eh state conn = do - request <- readRequest conn +{- | + This function maps all incoming messages over the eventhandler and sends off the resulting output messages. + Uses the connection to communicate with the IO device. Uses the Standard Output Mutex to print information + to stdout in a safe multi-threaded way as each connection starts a thread that uses the 'doEvents' + function. +-} +doEvents :: (a -> IOMessage -> ([IOMessage], a)) -- ^ The eventhandler eh that maps incoming 'IOMessage's to outgoing 'IOMessage's. It uses a variable of type a to store information in between calls to the event handler. + -> a -- ^ The begin store. It should be changed in the eventhandler function. + -> WS.Connection -- ^ Connection to the IO device. + -> WS.StdOutMutex -- ^ Standard Output Mutex for printing information in a safe multi-threaded way to the standard out. + -> WS.ConnectionSendMutex -- ^ Connection Send Mutex for sending 'IOMessage's to the IO device in a safe multi-threaded way. + -> IO () +doEvents eh state conn stdoutM connSendM = do + request <- readRequest conn stdoutM let (resp, state') = eh state request - sendActions = map (sendResponse conn) resp + sendActions = map (sendResponse connSendM conn stdoutM) resp sequence sendActions - doEvents eh state' conn - -readRequest :: WS.Connection -> IO IOMessage -readRequest conn = do - msg <- WS.receiveData conn - let - string = T.unpack msg - request = stringToJsonObject string - return request - -sendResponse :: WS.Connection -> IOMessage -> IO () -sendResponse conn response = do - let - string = show response - text = T.pack string - WS.sendTextData conn text + doEvents eh state' conn stdoutM connSendM + +{- | + This functions reads a request from the 'WS.Connection' and parses it into an 'IOMessage'. +-} +readRequest :: WS.Connection -> WS.StdOutMutex -> IO IOMessage +readRequest conn stdoutM = do + msg <- WS.receiveData conn :: IO T.Text + let + string = T.unpack msg + request = stringToJsonObject string + --WS.safePutStr stdoutM string + return request + +{- | + This function takes an 'IOMessage' and parses it into a response. Then it sends the response to the 'WS.Connection'. +-} +sendResponse :: WS.ConnectionSendMutex -> WS.Connection -> WS.StdOutMutex -> IOMessage -> IO () +sendResponse mu conn stdoutM response = do + let + string = show response + text = T.pack string + --WS.safePutStr stdoutM string + WS.safeSendText mu conn text
src/EventLoop/Input/InputEvent.hs view
@@ -1,3 +1,15 @@+{-| +Module : EventLoop.Input.InputEvent +Description : Library of all the possible 'InputEvent's in the example implementation. +Copyright : (c) Sebastiaan la Fleur, 2014 +License : BSD3 +Maintainer : sebastiaan.la.fleur@gmail.com +Stability : experimental +Portability : All + +All different 'InputEvent's are combined to a single 'InputEvent' type. +In this example implementation, the 'EventLoop.Input.Keyboard', 'EventLoop.Input.Mouse' and 'EventLoop.Input.SystemMessage' are modeled. +-} module EventLoop.Input.InputEvent where import EventLoop.Config @@ -6,10 +18,16 @@ import EventLoop.Input.Mouse import EventLoop.Input.SystemMessage -data InputEvent = InMouse Mouse - | InKeyboard Keyboard - | InSysMessage SystemMessageIn +{-| + The central 'InputEvent' type. +-} +data InputEvent = InMouse Mouse -- ^ A 'EventLoop.Input.Mouse' event. + | InKeyboard Keyboard -- ^ A 'EventLoop.Input.Keyboard' event. + | InSysMessage SystemMessageIn -- ^ A 'EventLoop.Input.SystemMessage' event. +{-| + Instance to express how a JSON formatted message can be parsed into an 'InputEvent'. +-} instance FromJSON InputEvent where fromJsonMessage obj@(JSONObject ms) | keyboardS == type' = InKeyboard (fromJsonMessage obj) | mouseS == type' = InMouse (fromJsonMessage obj)
src/EventLoop/Input/Keyboard.hs view
@@ -1,3 +1,14 @@+{-| +Module : EventLoop.Input.Keyboard +Description : Library of all the possible 'Keyboard' events in the example implementation. +Copyright : (c) Sebastiaan la Fleur, 2014 +License : BSD3 +Maintainer : sebastiaan.la.fleur@gmail.com +Stability : experimental +Portability : All + +This module expresses how the 'Keyboard' IO device is modelled in the example implementation. +-} module EventLoop.Input.Keyboard( Keyboard(..), KeyboardButton @@ -6,14 +17,13 @@ import EventLoop.Json import EventLoop.Config --- Possible messages: --- {"type": "keyboard", "button": "<kkey>"} --- <kkey> = a | b | c .. | z | shift | caps .. - --- Keyboard Messages In +-- | Datatype to express the different 'Keyboard' events. data Keyboard = KeyPress KeyboardButton + +-- | Type to express how a 'KeyboardButton' is modelled. type KeyboardButton = [Char] +-- | Instance to express how a JSON formatted 'String' can be parsed into a 'Keyboard' event. instance FromJSON Keyboard where fromJsonMessage (JSONObject ms) = KeyPress button where
src/EventLoop/Input/Mouse.hs view
@@ -1,3 +1,14 @@+{-| +Module : EventLoop.Input.Mouse +Description : Library of all the possible 'Mouse' events in the example implementation. +Copyright : (c) Sebastiaan la Fleur, 2014 +License : BSD3 +Maintainer : sebastiaan.la.fleur@gmail.com +Stability : experimental +Portability : All + +This module expresses how the 'Mouse' IO device is modelled in the example implementation. +-} module EventLoop.Input.Mouse( Mouse(..), MouseButton(..) @@ -7,35 +18,35 @@ import EventLoop.Config import EventLoop.CommonTypes - --- Possible messages: --- {"type":"mouse","button":"<mkey>","x":<number>,"y":<number>,"element":"<name>"} --- <mkey> = left | right | middle --- <name> = (a | b | c | ... | z | A | B | C ...)+ --- <numbers> = (1 | 2 | 3 | ... | 0)+ - --- Mouse Messages In -data Mouse = MouseClick MouseButton Pos Element - | MouseUp MouseButton Pos Element - | MouseDown MouseButton Pos Element +{-| + Datatype to express the different 'Mouse' events. + The 'EventLoop.CommonTypes.Pos' expresses where on the screen the event happened. + The 'Element' expresses on which top element on screen the event happened. The 'Element' value is the name of the 'EventLoop.Output.Graphical.GObject'. +-} +data Mouse = MouseClick MouseButton Pos Element -- ^ Expresses a complete 'MouseClick' consisting of a 'MouseUp' and a 'MouseDown'. + | MouseUp MouseButton Pos Element -- ^ Expresses when a 'MouseButton' moves upward. + | MouseDown MouseButton Pos Element -- ^ Expresses when a 'MouseButton' is pushed down. deriving Show - + +-- | The 'MouseButton' on the mouse. data MouseButton = MLeft | MRight | MMiddle deriving Show +-- | How to parse a 'Mouse'event from a JSON formatted 'String'. instance FromJSON Mouse where fromJsonMessage (JSONObject ms) | mouseType == mouseclickS = MouseClick button pos element | mouseType == mouseupS = MouseUp button pos element | mouseType == mousedownS = MouseDown button pos element where JSONString mouseType = retrieveError mousetypeS ms - JSONNumber x = retrieveError xS ms - JSONNumber y = retrieveError yS ms + JSONFloat x = retrieveError xS ms + JSONFloat y = retrieveError yS ms pos = (x, y) JSONString element = retrieveError elementS ms jsonButton = retrieveError buttonS ms button = fromJsonMessage jsonButton - + +-- | How to parse a 'MouseButton' from a JSON formatted 'String'. instance FromJSON MouseButton where fromJsonMessage (JSONString but) | leftS == but = MLeft | middleS == but = MMiddle
src/EventLoop/Input/SystemMessage.hs view
@@ -1,3 +1,14 @@+{-| +Module : EventLoop.Input.SystemMessage +Description : Library of all the possible input 'SystemMessage' events in the example implementation. +Copyright : (c) Sebastiaan la Fleur, 2014 +License : BSD3 +Maintainer : sebastiaan.la.fleur@gmail.com +Stability : experimental +Portability : All + +This module expresses how the incoming 'SystemMessage's are modelled in the example implementation. +-} module EventLoop.Input.SystemMessage( SystemMessageIn(..) ) where @@ -5,11 +16,16 @@ import EventLoop.Json import EventLoop.Config --- System Messages In -data SystemMessageIn = Setup - | Background - | Time +{-| + The different possible 'SystemMessageIn's. +-} +data SystemMessageIn = Setup -- ^ A request for the 'Setup'. This should be generated when the connection to a client is made. The answer should be a 'EventLoop.Output.CanvasSetup' message. + | Background -- ^ A request for the 'Background'. This should be generated when the connection to a client is made. The answer could be the background of the graphical application. + | Time -- ^ When a timer has been spawn, each \'tick\' a 'Time' is generated by the client to let the server know it is time. +{-| + Instance to express how to parse a 'SystemMessageIn' from a JSON formatted 'String'. +-} instance FromJSON SystemMessageIn where fromJsonMessage (JSONObject ms) | message == setupS = Setup | message == backgroundS = Background
src/EventLoop/Json.hs view
@@ -1,34 +1,52 @@+{-| +Module : EventLoop.Json +Description : JSON library to parse and show JSON messages. +Copyright : (c) Sebastiaan la Fleur, 2014 +License : BSD3 +Maintainer : sebastiaan.la.fleur@gmail.com +Stability : experimental +Portability : All + +This JSON library can parse JSON formatted 'String's into 'JSONMessage's. +-} module EventLoop.Json(JSONMember(..), JSONMessage(..), retrieve, retrieveError, FromJSON(..), JSONAble(..), stringToJsonObject) where import Data.Char (isDigit, isLower, isUpper) import FPPrac +-- | A row within a 'JSONObject' consisting of a field name ('[Char]'/'String') and field content ('JSONMessage'). data JSONMember = JSONMember [Char] JSONMessage -data JSONMessage = JSONNumber Number - | JSONString [Char] - | JSONBool Bool - | JSONObject [JSONMember] - | JSONArray [JSONMessage] +-- | A 'JSONMessage'. +data JSONMessage = JSONFloat Float -- ^ A 'JSONFloat' + | JSONString [Char] -- ^ A 'JSONString' + | JSONBool Bool -- ^ A 'JSONBool' + | JSONObject [JSONMember] -- ^ A 'JSONObject'. Consists of 'JSONMembers' which express the rows within the object. + | JSONArray [JSONMessage] -- ^ A 'JSONArray'. Consists of 'JSONMessage's which expresses the different elements in the array. - +-- | Retrieves the field content ('JSONMessage') associated with the field name ('[Char]') from a list of 'JSONMember's. retrieve :: [Char] -> [JSONMember] -> Maybe JSONMessage retrieve search [] = Nothing retrieve search ((JSONMember name member):list) | search == name = Just member | otherwise = retrieve search list - + +-- | Same as 'retrieve' but instead of returning a 'Maybe', it raises an error when the field name could not be found. +-- Usable in situations where you know for sure the field name is in the list of 'JSONMember's. retrieveError :: [Char] -> [JSONMember] -> JSONMessage retrieveError search members = case (retrieve search members) of Nothing -> error ("Could not find " ++ search ++ " in JSON members") Just result -> result +-- | Class expressing that type a is parsable from a 'JSONMessage'. class FromJSON a where + -- | Function to call to parse a 'JSONMessage' to type a. fromJsonMessage :: JSONMessage -> a +-- | Instance expressing how to 'Show' a 'JSONMessage' instance Show JSONMessage where - show (JSONNumber n) = show n - show (JSONString s) = "\"" ++ s ++ "\"" - show (JSONBool bool) | bool = "true" + show (JSONFloat f) = show f + show (JSONString s) = "\"" ++ escapeStringJson s ++ "\"" + show (JSONBool bool) | bool = "true" | otherwise = "false" show (JSONObject (r:rs)) = "{" ++ rows ++ "}" where @@ -38,18 +56,30 @@ where list = foldl insertComma (show x) (map show xs) +-- | Private support function insertComma :: [Char] -> [Char] -> [Char] insertComma a b = a ++ "," ++ b +-- | Instance expressing how to 'Show' a 'JSONMember'. instance Show JSONMember where show (JSONMember name m) = "\"" ++ name ++ "\": " ++ (show m) - - +-- | Function expressing which characters need to be escaped in a JSON formatted 'String'. +escapeStringJson :: [Char] -> [Char] +escapeStringJson [] = "" +escapeStringJson (c:cs) | c == '"' || c == '\\' = '\\':c:rest + | otherwise = c:rest + where + rest = escapeStringJson cs +-- | Class expressing that type a can be parsed into a 'JSONMessage'. class JSONAble a where toJsonMessage :: a -> JSONMessage +-- | Function to parse a 'JSONMessage' from a 'String'. +stringToJsonObject :: [Char] -> JSONMessage +stringToJsonObject string = snd $ parse O string (JSONObject []) + -- JSON Grammar for 1 object -- Grammar returns (Rest, JSONObject [JSONRow]) -- O: '{' R+ '}' @@ -58,15 +88,16 @@ -- N: ('1' | '2' | '3' | ... | '0')+ -- W: ('a' | 'b' | 'c' | ... | 'z') (N | W | -) +-- | Private data Grammer = O | R +-- | Private type Rest = [Char] -stringToJsonObject :: [Char] -> JSONMessage -stringToJsonObject string = snd $ parse O string (JSONObject []) - +-- | Private errorMsg :: [Char] -> [Char] -> [Char] errorMsg exp act = "Fault at parsing, expected '" ++ exp ++ "' but found '" ++ act ++ "'" +-- | Private parse :: Grammer -> Rest -> JSONMessage -> (Rest, JSONMessage) parse O [] _ = error (errorMsg "something" "premature end (start of message)") parse O (c1:cs) (JSONObject rows) | c1 == '{' = result @@ -90,25 +121,27 @@ | otherwise = error (errorMsg "',' or '}'" [r'']) -- Possibilities: --- "\"string123value\"" -> JSONString "string123value" or "12345" -> JSONInt 12345 +-- "\"string123value\"" -> JSONString "string123value" or "12345" -> JSONInt 12345 +-- | Private parseVariable :: Rest -> (Rest, JSONMessage) parseVariable [] = error (errorMsg "something" "premature end") parseVariable [c1] = error (errorMsg "longer variable" (c1:" and premature end")) -parseVariable (c1:c2:cs) | c1 == '"' && ((isLower c2) || (isUpper c2)) = (r1, JSONString word) - | isDigit c1 = (r2, JSONNumber (read number)) - | otherwise = error (errorMsg "\"" [c1]) +parseVariable (c1:cs) | c1 == '"' = (r1, JSONString word) + | isDigit c1 = (r2, JSONFloat (read number)) + | otherwise = error (errorMsg "\" or digit" [c1]) where - (r1, word) = parseWord (c2:cs) - (r2, number) = parseNumber (c1:c2:cs) + (r1, word) = parseWord (cs) + (r2, number) = parseNumber (c1:cs) +-- | Private parseWord :: Rest -> (Rest, [Char]) parseWord [] = error (errorMsg "something" "premature end") -parseWord (c1:cs) | (isLower c1) || (isDigit c1) || (isUpper c1) = (r1, c1:result') - | c1 == '"' = (cs, []) - | otherwise = error (errorMsg "letter or number" [c1]) +parseWord (c1:cs) | c1 == '"' = (cs, []) + | otherwise = (r1, c1:result') where (r1, result') = parseWord cs +-- | Private parseNumber :: Rest -> (Rest, [Char]) parseNumber [] = error (errorMsg "something" "premature end") parseNumber (c1:cs) | isDigit c1 || c1 == '.' = (r1, c1:result')
src/EventLoop/Main.hs view
@@ -1,3 +1,15 @@+{-| +Module : EventLoop.Main +Description : High-level starting point for the eventloop. Uses the example implementation. +Copyright : (c) Sebastiaan la Fleur, 2014 +License : BSD3 +Maintainer : sebastiaan.la.fleur@gmail.com +Stability : experimental +Portability : All + +High-level starting point for the eventloop. Uses the example implementation of 'EventLoop.Input.InputEvent' and 'EventLoop.Output.OutputEvent' +to model the keyboard, mouse and webbrowser. Assumes that the server connects to webbrowser which sends information in a JSON formatted String('EventLoop.EventProcessor.IOMessage'). +-} module EventLoop.Main(start) where import EventLoop.EventProcessor @@ -5,12 +17,16 @@ import EventLoop.Output.OutputEvent import EventLoop.Json -start :: (a -> InputEvent -> ([OutputEvent], a)) -> a -> IO() +-- | High-level function to start an eventloop. The eventloop takes an 'EventLoop.Input.InputEvent' and outputs an 'EventLoop.Output.OutputEvent'. +-- Starting place for the example implementation of the eventloop. It takes a variable of type a to hold information in between handler calls. +start :: (a -> InputEvent -> ([OutputEvent], a)) -- ^ Eventhandler from 'EventLoop.Input.InputEvent' to a list of 'EventLoop.Output.OutputEvent'. Also takes a variable of type a that holds the current state of information. Returns a changed variable of type a that will be called with next handler call. + -> a -- ^ The begin state of variable a. + -> IO() start handler beginstate = eventloop handler' beginstate where handler' = changeTypes handler - +-- | Low-level eventloop to High-Level eventloop converter. Changes 'IOMessage's to 'InputEvent's and 'OutputEvent's. changeTypes :: (a -> InputEvent -> ([OutputEvent], a)) -> a -> IOMessage -> ([IOMessage], a) changeTypes f state message = (map toJsonMessage oEvents, state') where
src/EventLoop/Output.hs view
@@ -1,6 +1,7 @@ module EventLoop.Output( OutputEvent(..), SystemMessageOut(..), + TimeData(..), Graphical(..), GObject(..), Primitive(..),
src/EventLoop/Output/Graphical/Graphical.hs view
@@ -1,3 +1,17 @@+{-| +Module : EventLoop.Output.Graphical.Graphical +Description : Library of all the possible output 'Graphical' events in the example implementation. +Copyright : (c) Sebastiaan la Fleur, 2014 +License : BSD3 +Maintainer : sebastiaan.la.fleur@gmail.com +Stability : experimental +Portability : All + +This module expresses how the outgoing 'Graphical' events are modelled in the example implementation. +Possible graphical events are 'Draw', 'MoveGroup', 'MoveElement', 'RemoveGroup' and 'RemoveElement'. +Respectively drawing a graphical object, moving an entire group, moving a single element, removing an entire group and removing a single element. +An element is a graphical object expressed through the name. +-} module EventLoop.Output.Graphical.Graphical( Graphical(..), GObject(..), @@ -14,20 +28,32 @@ import EventLoop.CommonTypes import FPPrac --- Options +-- | The name of a graphical object. Another synonym in the package used for this is 'EventLoop.CommonTypes.Element'. type Name = [Char] + +-- | The groupname of a set of graphical objects. type Groupname = [Char] -type Color = (Number, Number, Number) -- (r, g, b) + +-- | The color expressed in (red, green, blue) code where each value is between 0 <= 255. +type Color = (Float, Float, Float) -- (r, g, b) + +-- | The font associated with a 'Text' primitive. type Font = [Char] + +-- | A boolean expressing if an event should be carried out relative to the old situation or to the absolute situation +-- Example of this is when moving an element. Should the move be relative to the old 'EventLoop.CommonTypes.Pos' or to the +-- absolute 'EventLoop.CommonTypes.Pos' on the screen. type Relative = Bool -- Move relative to old spot or not --- Graphical Responses Out -data Graphical = Draw GObject Groupname - | MoveGroup Groupname Pos Relative - | MoveElement Name Pos Relative - | RemoveGroup Groupname - | RemoveElement Name - +-- | Graphical Responses Out +data Graphical = Draw GObject Groupname -- ^ Draw the graphical object with the given groupname. + | MoveGroup Groupname Pos Relative -- ^ Move an entire group to a new position possibly relative to the old position. + | MoveElement Name Pos Relative -- ^ Move a single element to a new position possibly relative to the old position. + | RemoveGroup Groupname -- ^ Remove a group. + | RemoveElement Name -- ^ Remove an element. + | ClearAll -- ^ Clears all from the canvas. + +-- | Instance to express how a 'Graphical' event can be parsed to a JSON formatted 'String'. instance JSONAble Graphical where toJsonMessage (Draw gObject gName) = JSONObject [(JSONMember modeS (JSONString drawS)), (JSONMember gobjectS (toJsonMessage gObject)), @@ -48,18 +74,21 @@ toJsonMessage (RemoveElement name) = JSONObject [(JSONMember modeS (JSONString removeelementS)), (JSONMember nameS (JSONString name))] + + toJsonMessage (ClearAll) = JSONObject [JSONMember modeS (JSONString clearallS)] --- Graphical Object Wrapper -data GObject = GObject { name :: Name - , prim :: Primitive - , children :: [GObject] - } - | Container { children :: [GObject] - } +-- | A general graphical object containing the common attributes of each 'Primitive'. +data GObject = GObject { name :: Name -- ^ Name of the graphical object/element + , prim :: Primitive -- ^ The graphical primitive that should be drawn + , children :: [GObject] -- ^ Children of the graphical primitive. Can be used to create composited graphical components containing multiple 'GObject's. + } -- ^ Graphical Object + | Container { children :: [GObject] -- ^ A set of 'GObject's. Can be used to create composited graphical components containing multiple 'GObject's with no real top 'GObject'. + } -- ^ A container for Graphical Objects deriving (Show) +-- | Instance to express how a 'GObject' can be parsed to a JSON formatted 'String'. instance JSONAble GObject where toJsonMessage (GObject name prim children) = JSONObject [(JSONMember typeS (JSONString gobjectS)), (JSONMember primS (toJsonMessage prim)), @@ -68,79 +97,82 @@ toJsonMessage (Container children) = JSONObject [(JSONMember childrenS (JSONArray (map toJsonMessage children)))] --- Primitive graphical structures -data Primitive = Text { edgeColor :: Color - , edgeThickness :: Number - , color :: Color - , position :: Pos - , size :: Number - , font :: Font - , text :: [Char] - , fromCenter :: Bool - } - | Line { edgeColor :: Color - , edgeThickness :: Number - , positions :: [Pos] - } - | Rect { edgeColor :: Color - , edgeThickness :: Number - , color :: Color - , position :: Pos -- Topleft corner - , dimensions :: Dimension - } - | Arc { edgeColor :: Color - , edgeThickness :: Number - , color :: Color - , position :: Pos - , radius :: Number - , startAng :: Number -- In degrees - , endAng :: Number -- In degrees - } +-- | Primitive graphical structures +data Primitive = Text { -- | 'EventLoop.CommonTypes.Color' of the edges of the text + edgeColor :: Color + , edgeThickness :: Float -- ^ The edge thickness of the text (Should be 1 most of the time) + , color :: Color -- ^ The 'EventLoop.CommonTypes.Color' of the fill of the text + , position :: Pos -- ^ The position on the screen of the text + , size :: Float -- ^ The height of the text in pixels + , font :: Font -- ^ Which font to be used + , text :: [Char] -- ^ The actual text to be displayed + , fromCenter :: Bool -- ^ Is the position the topleft corner of the text or the center of the text + } -- ^ The text graphical primitive + | Line { edgeColor :: Color -- ^ 'EventLoop.CommonTypes.Color' of the line + , edgeThickness :: Float -- ^ The thickness of the line + , positions :: [Pos] -- ^ The list of positions the line should go through. A line will be drawn from point 1 to point 2 to point... + } -- ^ The line graphical primitive + | Rect { edgeColor :: Color -- ^ 'EventLoop.CommonTypes.Color' of the edges of the rectangle + , edgeThickness :: Float -- ^ The edge thickness of the rectangle + , color :: Color -- ^ The 'EventLoop.CommonTypes.Color' of the fill of the rectangle + , position :: Pos -- ^ The topleft corner of the rectangle on the screen + , dimensions :: Dimension -- ^ The dimensions of the rectangle + } -- ^ The rectangle graphical primitive + | Arc { edgeColor :: Color -- ^ 'EventLoop.CommonTypes.Color' of the edges of the arc + , edgeThickness :: Float -- ^ The edge thickness of the arc + , color :: Color -- ^ The 'EventLoop.CommonTypes.Color' of the fill of the arc + , position :: Pos -- ^ The position of the center of the arc + , radius :: Float -- ^ The radius of the arc + , startAng :: Float -- ^ The starting angle of the arc in degrees. + , endAng :: Float -- ^ The ending angle of the arc in degrees. + } -- ^ The arc graphical primitive. This is the part of a circle. When startAng=0 and endAng=360 you get a full circle. deriving (Show, Eq) - +-- | Instance to express how a 'Primtive' can be parsed to a JSON formatted 'String'. instance JSONAble Primitive where toJsonMessage (Text ec et color position size font text fromcenter) = JSONObject [(JSONMember typeS (JSONString textS)), (JSONMember edgecolorS (colorToJsonMessage ec)), - (JSONMember edgethicknessS (JSONNumber et)), + (JSONMember edgethicknessS (JSONFloat et)), (JSONMember colorS (colorToJsonMessage color)), (JSONMember positionS (positionToJsonMessage position)), - (JSONMember sizeS (JSONNumber size)), + (JSONMember sizeS (JSONFloat size)), (JSONMember fontS (JSONString font)), (JSONMember textS (JSONString text)), (JSONMember fromcenterS (JSONBool fromcenter))] toJsonMessage (Line ec et positions) = JSONObject [(JSONMember typeS (JSONString lineS)), (JSONMember edgecolorS (colorToJsonMessage ec)), - (JSONMember edgethicknessS (JSONNumber et)), + (JSONMember edgethicknessS (JSONFloat et)), (JSONMember positionsS (JSONArray (map positionToJsonMessage positions)))] toJsonMessage (Rect ec et color position dim) = JSONObject [(JSONMember typeS (JSONString rectS)), (JSONMember edgecolorS (colorToJsonMessage ec)), - (JSONMember edgethicknessS (JSONNumber et)), + (JSONMember edgethicknessS (JSONFloat et)), (JSONMember colorS (colorToJsonMessage color)), (JSONMember positionS (positionToJsonMessage position)), (JSONMember dimensionS (dimensionToJsonMessage dim))] toJsonMessage (Arc ec et color position radius startAng endAng) = JSONObject [(JSONMember typeS (JSONString arcS)), (JSONMember edgecolorS (colorToJsonMessage ec)), - (JSONMember edgethicknessS (JSONNumber et)), + (JSONMember edgethicknessS (JSONFloat et)), (JSONMember colorS (colorToJsonMessage color)), (JSONMember positionS (positionToJsonMessage position)), - (JSONMember radiusS (JSONNumber radius)), - (JSONMember startangS (JSONNumber startAng)), - (JSONMember endangS (JSONNumber endAng))] + (JSONMember radiusS (JSONFloat radius)), + (JSONMember startangS (JSONFloat startAng)), + (JSONMember endangS (JSONFloat endAng))] --- Support Functions +-- | Private colorToJsonMessage :: Color -> JSONMessage -colorToJsonMessage (r, g, b) = JSONObject [(JSONMember rS (JSONNumber r)), - (JSONMember gS (JSONNumber g)), - (JSONMember bS (JSONNumber b))] +colorToJsonMessage (r, g, b) = JSONObject [(JSONMember rS (JSONFloat r)), + (JSONMember gS (JSONFloat g)), + (JSONMember bS (JSONFloat b))] +-- | Private positionToJsonMessage :: Pos -> JSONMessage -positionToJsonMessage (x, y) = JSONObject [(JSONMember xS (JSONNumber x)), - (JSONMember yS (JSONNumber y))] +positionToJsonMessage (x, y) = JSONObject [(JSONMember xS (JSONFloat x)), + (JSONMember yS (JSONFloat y))] +-- | Private dimensionToJsonMessage :: Dimension -> JSONMessage -dimensionToJsonMessage (h, w) = JSONObject [(JSONMember heightS (JSONNumber h)), - (JSONMember widthS (JSONNumber w))] +dimensionToJsonMessage (w, h) = JSONObject [(JSONMember heightS (JSONFloat h)), + (JSONMember widthS (JSONFloat w))]
src/EventLoop/Output/OutputEvent.hs view
@@ -1,3 +1,15 @@+{-| +Module : EventLoop.Output.OutputEvent +Description : Library of all the possible 'OutputEvent's in the example implementation. +Copyright : (c) Sebastiaan la Fleur, 2014 +License : BSD3 +Maintainer : sebastiaan.la.fleur@gmail.com +Stability : experimental +Portability : All + +All different 'OutputEvent's are combined to a single 'OutputEvent' type. +In this example implementation, the 'EventLoop.Output.Graphical.Graphical' and 'EventLoop.Output.SystemMessage.SystemMessageOut' are modeled. +-} module EventLoop.Output.OutputEvent where import EventLoop.Output.Graphical.Graphical @@ -5,10 +17,15 @@ import EventLoop.Config import EventLoop.Json +{-| + The central 'OutputEvent' type. +-} data OutputEvent = OutGraphical Graphical | OutSysMessage [SystemMessageOut] - +{-| + Instance to express how an 'OutputEvent' can be parsed into a JSON formatted message. +-} instance JSONAble OutputEvent where toJsonMessage (OutGraphical graph) = JSONObject [(JSONMember modeS (JSONString graphicalS)), (JSONMember commandS (toJsonMessage graph))] toJsonMessage (OutSysMessage ms) = JSONObject [(JSONMember modeS (JSONString sysmessageanswersS)), (JSONMember answersS (JSONArray (map toJsonMessage ms)))]
src/EventLoop/Output/Single.hs view
@@ -1,10 +1,22 @@+{-| +Module : EventLoop.Output.Single +Description : Makeshift server to output a single 'EventLoop.Output.OutputEvent' to the client. +Copyright : (c) Sebastiaan la Fleur, 2014 +License : BSD3 +Maintainer : sebastiaan.la.fleur@gmail.com +Stability : experimental +Portability : All + +Makeshift server to output a single 'EventLoop.Output.OutputEvent' to the client. The function 'outSingle' is the heart of this module. +-} module EventLoop.Output.Single (outSingle) where import qualified Network.Socket as S import qualified Network.WebSockets as WS import qualified Data.Text as T +import Control.Exception (catch, SomeException, throw) -import EventLoop.EventProcessor (sendResponse, IOMessage) +import EventLoop.EventProcessor (IOMessage) import EventLoop.Output.OutputEvent import EventLoop.Output.Graphical import EventLoop.Output.SystemMessage @@ -12,56 +24,81 @@ import EventLoop.Json import EventLoop.CommonTypes +{-| + Outputs a single 'EventLoop.Output.OutputEvent'. Right now only 'EventLoop.Output.Draw' events are implemented. + The server automatically determines the maximum 'EventLoop.CommonTypes.Dimension's of the picture and sends a 'EventLoop.Output.Setup' containing those 'EventLoop.CommonTypes.Dimension's. +-} outSingle :: OutputEvent -> IO () outSingle out = S.withSocketsDo $ do sock <- WS.makeSocket ipadres (fromIntegral port) pendingConn <- WS.makePendingConnection sock conn <- WS.acceptRequest pendingConn - sendResponse conn setup - sendResponse conn out' - sendResponse conn close - WS.sendClose conn (T.pack "") - WS.closeSocket sock - return () + let + close = catched sock conn + func = do + sendResponse conn setup + sendResponse conn out' + sendResponse conn closeMsg + WS.sendClose conn (T.pack "") + WS.closeSocket sock + catch func close where setup = toIOMessage (setupMessage out) out' = toIOMessage out - close = toIOMessage closeMessage - + closeMsg = toIOMessage closeMessage + +-- | Private +catched :: S.Socket -> WS.Connection -> SomeException -> IO () +catched sock conn e = do + WS.sendClose conn (T.pack "") + WS.closeSocket sock + throw e + +-- | Private setupMessage :: OutputEvent -> OutputEvent setupMessage (OutGraphical (Draw g _)) = OutSysMessage [CanvasSetup dim] where dim = maxDimensions g setupMessage _ = OutSysMessage [CanvasSetup (512, 512)] +-- | Private closeMessage :: OutputEvent closeMessage = OutSysMessage [Close] - + +-- | Private toIOMessage :: OutputEvent -> IOMessage toIOMessage = toJsonMessage +-- | Private +sendResponse :: WS.Connection -> IOMessage -> IO () +sendResponse conn response = do + let + string = show response + text = T.pack string + WS.sendTextData conn text + +-- | Private maxDimensions :: GObject -> Dimension maxDimensions (GObject _ prim []) = maxDimensionsPrim prim -maxDimensions (GObject n prim (c:cs)) = (max h h', max w w') +maxDimensions (GObject n prim (c:cs)) = (max w w', max h h') where - (h, w) = maxDimensions c - (h', w') = maxDimensions (GObject n prim cs) + (w, h) = maxDimensions c + (w', h') = maxDimensions (GObject n prim cs) maxDimensions (Container []) = (0, 0) -maxDimensions (Container (c:cs)) = (max h h', max w w') +maxDimensions (Container (c:cs)) = (max w w', max h h') where - (h, w) = maxDimensions c - (h', w') = maxDimensions (Container cs) + (w, h) = maxDimensions c + (w', h') = maxDimensions (Container cs) +-- | Private maxDimensionsPrim :: Primitive -> Dimension -maxDimensionsPrim (Text _ _ _ (x, y) size _ str fromCenter) | fromCenter = (y + size / 2, x + (fromIntegral $ length str * 10) / 2) - | otherwise = (y + size, x + (fromIntegral $ length str * 10)) +maxDimensionsPrim (Text _ _ _ (x, y) size _ str fromCenter) | fromCenter = (x + (fromIntegral $ length str * 10) / 2, y + size / 2) + | otherwise = (x + (fromIntegral $ length str * 10), y + size) maxDimensionsPrim (Line _ _ []) = (0, 0) -maxDimensionsPrim (Line _ _ [(x, y)]) = (y, x) -maxDimensionsPrim (Line ec et ((x, y):xs)) = (max y y', max x x') +maxDimensionsPrim (Line _ _ [(x, y)]) = (x, y) +maxDimensionsPrim (Line ec et ((x, y):xs)) = (max x x', max y y') where - (y', x') = maxDimensionsPrim (Line ec et xs) -maxDimensionsPrim (Rect _ _ _ (x, y) (h, w)) = (y + h / 2, x + w / 2) -maxDimensionsPrim (Arc _ _ _ (x, y) r _ _) = (y + r, x + r) - - - + (x', y') = maxDimensionsPrim (Line ec et xs) + +maxDimensionsPrim (Rect _ _ _ (x, y) (w, h)) = (x + w / 2, y + h / 2) +maxDimensionsPrim (Arc _ _ _ (x, y) r _ _) = (x + r, y + r)
src/EventLoop/Output/SystemMessage.hs view
@@ -1,19 +1,45 @@-module EventLoop.Output.SystemMessage(SystemMessageOut(..)) where +{-| +Module : EventLoop.Output.SystemMessage +Description : Library of all the possible output 'SystemMessage' events in the example implementation. +Copyright : (c) Sebastiaan la Fleur, 2014 +License : BSD3 +Maintainer : sebastiaan.la.fleur@gmail.com +Stability : experimental +Portability : All +This module expresses how the outgoing 'SystemMessage's are modelled in the example implementation. +-} +module EventLoop.Output.SystemMessage(SystemMessageOut(..), TimeData(..)) where + import EventLoop.Json import EventLoop.Config import EventLoop.CommonTypes --- System Messages Out -data SystemMessageOut = CanvasSetup Dimension - | Timer Bool - | Close - +{-| + The different possible 'SystemMessageOut's. +-} +data SystemMessageOut = CanvasSetup Dimension -- ^ Answer to the 'EventLoop.Input.SystemMessage.Setup' containing the dimensions of the canvas that will be used. + | Timer TimeData -- ^ Request to create a timer at the clientside that will generate a 'EventLoop.Input.SystemMessage.Time' message each \'tick\'. + | Close -- ^ A request for the client to completely close the connection to the server. + +data TimeData = On Int -- ^ Tells that the timer should be on with the time in ms + | Off -- ^ Tells that the timer should be off + +{-| + Instance to express how to parse a 'SystemMessageIn' to a JSON formatted 'String'. +-} instance JSONAble SystemMessageOut where toJsonMessage (CanvasSetup dim) = JSONObject [(JSONMember sysmessageanswerS (JSONString canvassetupS)), (JSONMember dimensionS (dimensionToJsonMessage dim))] - toJsonMessage (Timer bool) = JSONObject [(JSONMember sysmessageanswerS (JSONString timerS)), (JSONMember useS (JSONBool bool))] + toJsonMessage (Timer timedata) = JSONObject [(JSONMember sysmessageanswerS (JSONString timerS)), (JSONMember timedataS (toJsonMessage timedata))] toJsonMessage (Close) = JSONObject [(JSONMember sysmessageanswerS (JSONString closeS))] --- Support Function +-- | Private dimensionToJsonMessage :: Dimension -> JSONMessage -dimensionToJsonMessage (h, w) = JSONObject [(JSONMember hS (JSONNumber h)), (JSONMember wS (JSONNumber w))]+dimensionToJsonMessage (w, h) = JSONObject [(JSONMember hS (JSONFloat h)), (JSONMember wS (JSONFloat w))] + +{-| + Instance to express how to parse a 'TimeData' to a JSON formatted 'String'. +-} +instance JSONAble TimeData where + toJsonMessage Off = JSONObject [(JSONMember useS (JSONBool False))] + toJsonMessage (On i) = JSONObject [(JSONMember useS (JSONBool True)), (JSONMember iS (JSONFloat $ fromIntegral i))]
+ src/FPPrac/Graphics/NormalizeNumber.hs view
@@ -0,0 +1,49 @@+{-| +Module : FPPrac.Graphics.NormalizeNumber +Description : Used in the FPPrac module to normalize any instance of a Num type to float. + It is used for the "EventLoop" module. +Copyright : (c) Sebastiaan la Fleur, 2014 +License : BSD3 +Maintainer : sebastiaan.la.fleur@gmail.com +Stability : experimental +Portability : All + +In the "EventLoop" module, 'Float's are used to express positions and other characteristics. As that package is also used +in the functional programming lab at the University of Twente, compatibility with the "FPPrac" module is needed. +That module expresses a 'Number' type which abstracts from 'Int' and 'Double' types. This module is used to normalize +both the 'Number' type and the original 'Num' class instances defined in Haskell. +-} +module FPPrac.Graphics.NormalizeNumber where + +import GHC.Float +import FPPrac.Prelude.Number + +{-| + Class to express that the instance 'a' is able to be normalized to a 'Float'. +-} +class (Num a) => NormalizeNumber a where + -- | The function that can be used to normalize 'a' to a 'Float'. + normalize :: a -> Float + + {-# MINIMAL normalize #-} + +-- | How to normalize a 'Float' +instance NormalizeNumber Float where + normalize f = f + +-- | How to normalize an 'Int' +instance NormalizeNumber Int where + normalize = fromIntegral + +-- | How to normalize an 'Integer' +instance NormalizeNumber Integer where + normalize = fromIntegral + +-- | How to normalize a 'Double' +instance NormalizeNumber Double where + normalize = double2Float + +-- | How to normalize a 'Number'. This is definied in "FPPrac.Prelude.Number" in the twentefp-number package +instance NormalizeNumber Number where + normalize (I i) = fromIntegral i + normalize (F d) = double2Float d
twentefp-eventloop-graphics.cabal view
@@ -1,6 +1,6 @@ name: twentefp-eventloop-graphics -version: 0.1.0.0 -synopsis: An eventloop based graphical IO system. Used as Lab Assignments Environment at Univeriteit Twente +version: 0.1.0.4 +synopsis: Used as Lab Assignments Environment at Univeriteit Twente description: An eventloop based graphical IO system. It uses websockets as a way to communicate with IO devices; a browser in this case. This system is used in the Graphical submodule to be able to express graphical output using the eventloop system for a browser. license: BSD3 license-file: LICENSE @@ -18,7 +18,8 @@ EventLoop.Input, EventLoop.Output.Graphical, EventLoop.Output.Single, - EventLoop.CommonTypes + EventLoop.CommonTypes, + FPPrac.Graphics.NormalizeNumber other-modules: EventLoop.Main, @@ -34,9 +35,9 @@ EventLoop.Input.InputEvent build-depends: - base >= 4.6.0.1 && < 5, - twentefp-websockets >= 0.1.0.0, - twentefp-number >= 0.1.0.0, + base >= 4.6.0.0 && < 5, + twentefp-websockets >= 0.1.0.1, + twentefp-number >= 0.1.0.2, text >= 0.11.3.1, network >= 2.3 && < 2.6