twentefp-eventloop-graphics 0.1.0.2 → 0.1.0.3
raw patch · 17 files changed
+406/−173 lines, 17 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
- FPPrac.Graphics.MakePrimitives: createArcPrimitive :: Color -> Pos -> Radius -> Angle -> Angle -> Primitive
- FPPrac.Graphics.MakePrimitives: createColor :: (NormalizeNumber r, NormalizeNumber g, NormalizeNumber b) => r -> g -> b -> (NormalizedNum, NormalizedNum, NormalizedNum)
- FPPrac.Graphics.MakePrimitives: createDimension :: (NormalizeNumber w, NormalizeNumber h) => w -> h -> (NormalizedNum, NormalizedNum)
- FPPrac.Graphics.MakePrimitives: createDrawCommand :: GObject -> String -> Graphical
- FPPrac.Graphics.MakePrimitives: createGraphicalContainer :: [GObject] -> GObject
- FPPrac.Graphics.MakePrimitives: createGraphicalObject :: String -> Primitive -> [GObject] -> GObject
- FPPrac.Graphics.MakePrimitives: createLinePrimitive :: Color -> [Pos] -> Primitive
- FPPrac.Graphics.MakePrimitives: createMoveElementCommand :: String -> Pos -> Relative -> Graphical
- FPPrac.Graphics.MakePrimitives: createMoveGroupCommand :: String -> Pos -> Relative -> Graphical
- FPPrac.Graphics.MakePrimitives: createNormalizedNum :: NormalizeNumber i => i -> NormalizedNum
- FPPrac.Graphics.MakePrimitives: createPosition :: (NormalizeNumber x, NormalizeNumber y) => x -> y -> (NormalizedNum, NormalizedNum)
- FPPrac.Graphics.MakePrimitives: createRectPrimitive :: Color -> Pos -> Dimension -> Primitive
- FPPrac.Graphics.MakePrimitives: createRemoveElementCommand :: String -> Graphical
- FPPrac.Graphics.MakePrimitives: createRemoveGroupCommand :: String -> Graphical
- FPPrac.Graphics.MakePrimitives: createTextPrimitive :: Color -> Pos -> TextSize -> Font -> String -> Bool -> Primitive
- FPPrac.Graphics.MakePrimitives: type Angle = NormalizedNum
- FPPrac.Graphics.MakePrimitives: type NormalizedNum = Float
- FPPrac.Graphics.MakePrimitives: type Radius = NormalizedNum
- FPPrac.Graphics.MakePrimitives: type TextSize = NormalizedNum
+ FPPrac.Graphics.NormalizeNumber: class Num a => NormalizeNumber a
+ FPPrac.Graphics.NormalizeNumber: instance NormalizeNumber Double
+ FPPrac.Graphics.NormalizeNumber: instance NormalizeNumber Float
+ FPPrac.Graphics.NormalizeNumber: instance NormalizeNumber Int
+ FPPrac.Graphics.NormalizeNumber: instance NormalizeNumber Integer
+ FPPrac.Graphics.NormalizeNumber: instance NormalizeNumber Number
+ FPPrac.Graphics.NormalizeNumber: normalize :: NormalizeNumber a => a -> Float
Files
- src/EventLoop.hs +16/−0
- src/EventLoop/CommonTypes.hs +21/−3
- src/EventLoop/Config.hs +14/−2
- src/EventLoop/EventProcessor.hs +47/−7
- src/EventLoop/Input/InputEvent.hs +21/−3
- src/EventLoop/Input/Keyboard.hs +15/−5
- src/EventLoop/Input/Mouse.hs +24/−13
- src/EventLoop/Input/SystemMessage.hs +20/−4
- src/EventLoop/Json.hs +41/−12
- src/EventLoop/Main.hs +18/−2
- src/EventLoop/Output/Graphical/Graphical.hs +74/−45
- src/EventLoop/Output/OutputEvent.hs +18/−1
- src/EventLoop/Output/Single.hs +25/−4
- src/EventLoop/Output/SystemMessage.hs +22/−6
- src/FPPrac/Graphics/MakePrimitives.hs +0/−59
- src/FPPrac/Graphics/NormalizeNumber.hs +26/−2
- twentefp-eventloop-graphics.cabal +4/−5
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 +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 + +All common types throughout the "EventLoop" module +-} module EventLoop.CommonTypes ( Pos , Dimension , Element ) where -import FPPrac +{-| + 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 Pos = (Float,Float) -- (x, y) -type Dimension = (Float, Float) -- (w, h) +-- | 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
src/EventLoop/EventProcessor.hs view
@@ -1,3 +1,20 @@+{-| +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 @@ -9,14 +26,31 @@ import EventLoop.Json import EventLoop.Config +-- | 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.server ipadres (fromIntegral port) $ doEvents eh beginState +{- | + 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 -> WS.StdOutMutex -> WS.ConnectionSendMutex -> IO () +{- | + 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 @@ -24,7 +58,10 @@ sendActions = map (sendResponse connSendM conn stdoutM) resp sequence sendActions 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 @@ -33,7 +70,10 @@ 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
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,22 +18,21 @@ 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 @@ -35,7 +45,8 @@ 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,30 +1,48 @@+{-| +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 = JSONFloat Float - | 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 (JSONFloat f) = show f show (JSONString s) = "\"" ++ escapeStringJson s ++ "\"" @@ -38,12 +56,15 @@ 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 @@ -51,10 +72,14 @@ 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+ '}' @@ -63,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 @@ -95,7 +121,8 @@ | 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")) @@ -106,6 +133,7 @@ (r1, word) = parseWord (cs) (r2, number) = parseNumber (c1:cs) +-- | Private parseWord :: Rest -> (Rest, [Char]) parseWord [] = error (errorMsg "something" "premature end") parseWord (c1:cs) | c1 == '"' = (cs, []) @@ -113,6 +141,7 @@ 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/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,31 @@ 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] + +-- | 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. + +-- | 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)), @@ -51,15 +76,16 @@ --- 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,37 +94,38 @@ toJsonMessage (Container children) = JSONObject [(JSONMember childrenS (JSONArray (map toJsonMessage children)))] --- Primitive graphical structures -data Primitive = Text { edgeColor :: Color - , edgeThickness :: Float - , color :: Color - , position :: Pos - , size :: Float - , font :: Font - , text :: [Char] - , fromCenter :: Bool - } - | Line { edgeColor :: Color - , edgeThickness :: Float - , positions :: [Pos] - } - | Rect { edgeColor :: Color - , edgeThickness :: Float - , color :: Color - , position :: Pos -- Topleft corner - , dimensions :: Dimension - } - | Arc { edgeColor :: Color - , edgeThickness :: Float - , color :: Color - , position :: Pos - , radius :: Float - , startAng :: Float -- In degrees - , endAng :: Float -- 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)), @@ -131,16 +158,18 @@ (JSONMember startangS (JSONFloat startAng)), (JSONMember endangS (JSONFloat endAng))] --- Support Functions +-- | Private colorToJsonMessage :: Color -> JSONMessage 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 (JSONFloat x)), (JSONMember yS (JSONFloat y))] +-- | Private dimensionToJsonMessage :: Dimension -> JSONMessage 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,3 +1,14 @@+{-| +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 @@ -13,6 +24,10 @@ 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) @@ -31,25 +46,30 @@ setup = toIOMessage (setupMessage out) out' = toIOMessage out 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 @@ -57,7 +77,7 @@ text = T.pack string WS.sendTextData conn text - +-- | Private maxDimensions :: GObject -> Dimension maxDimensions (GObject _ prim []) = maxDimensionsPrim prim maxDimensions (GObject n prim (c:cs)) = (max w w', max h h') @@ -70,6 +90,7 @@ (w, h) = maxDimensions c (w', h') = maxDimensions (Container cs) +-- | Private maxDimensionsPrim :: Primitive -> Dimension 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)
src/EventLoop/Output/SystemMessage.hs view
@@ -1,19 +1,35 @@+{-| +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(..)) 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 Bool -- ^ 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. + +{-| + Instance to express how to parse a 'SystemMessageIn' from 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 (Close) = JSONObject [(JSONMember sysmessageanswerS (JSONString closeS))] --- Support Function +-- | Private dimensionToJsonMessage :: Dimension -> JSONMessage dimensionToJsonMessage (w, h) = JSONObject [(JSONMember hS (JSONFloat h)), (JSONMember wS (JSONFloat w))]
− src/FPPrac/Graphics/MakePrimitives.hs
@@ -1,59 +0,0 @@-module FPPrac.Graphics.MakePrimitives where - -import EventLoop.Output -import EventLoop.CommonTypes -import FPPrac.Graphics.NormalizeNumber - -type NormalizedNum = Float -type TextSize = NormalizedNum -type Radius = NormalizedNum -type Angle = NormalizedNum - -createDrawCommand :: GObject -> String -> Graphical -createDrawCommand g groupname = Draw g groupname - -createMoveGroupCommand :: String -> Pos -> Relative -> Graphical -createMoveGroupCommand groupname pos rel = MoveGroup groupname pos rel - -createMoveElementCommand :: String -> Pos -> Relative -> Graphical -createMoveElementCommand name pos rel = MoveElement name pos rel - -createRemoveGroupCommand :: String -> Graphical -createRemoveGroupCommand groupname = RemoveGroup groupname - -createRemoveElementCommand :: String -> Graphical -createRemoveElementCommand name = RemoveElement name - - -createGraphicalObject :: String -> Primitive -> [GObject] -> GObject -createGraphicalObject name prim children = GObject name prim children - -createGraphicalContainer :: [GObject] -> GObject -createGraphicalContainer contents = Container contents - - -createTextPrimitive :: Color -> Pos -> TextSize -> Font -> String -> Bool -> Primitive -createTextPrimitive col pos size font str fromCenter = Text (0,0,0) 1 col pos size font str fromCenter - -createLinePrimitive :: Color -> [Pos] -> Primitive -createLinePrimitive col positions = Line col 1 positions - -createRectPrimitive :: Color -> Pos -> Dimension -> Primitive -createRectPrimitive col pos dim = Rect (0,0,0) 0 col pos dim - -createArcPrimitive :: Color -> Pos -> Radius -> Angle -> Angle -> Primitive -createArcPrimitive col pos rad startAngle endAngle = Arc (0,0,0) 0 col pos rad startAngle endAngle - --- (x,y) -createPosition :: (NormalizeNumber x, NormalizeNumber y) => x -> y -> (NormalizedNum ,NormalizedNum) -createPosition x y = (normalize x, normalize y) - --- (w,h) -createDimension :: (NormalizeNumber w, NormalizeNumber h) => w -> h -> (NormalizedNum, NormalizedNum) -createDimension w h = (normalize w, normalize h) - -createColor :: (NormalizeNumber r, NormalizeNumber g, NormalizeNumber b) => r -> g -> b -> (NormalizedNum, NormalizedNum, NormalizedNum) -createColor r g b = (normalize r, normalize g, normalize b) - -createNormalizedNum :: (NormalizeNumber i) => i -> NormalizedNum -createNormalizedNum i = normalize i
src/FPPrac/Graphics/NormalizeNumber.hs view
@@ -1,25 +1,49 @@-module FPPrac.Graphics.NormalizeNumber where +{-| +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.2 -synopsis: An eventloop based graphical IO system. Used as Lab Assignments Environment at Univeriteit Twente +version: 0.1.0.3 +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 @@ -19,7 +19,7 @@ EventLoop.Output.Graphical, EventLoop.Output.Single, EventLoop.CommonTypes, - FPPrac.Graphics.MakePrimitives + FPPrac.Graphics.NormalizeNumber other-modules: EventLoop.Main, @@ -32,8 +32,7 @@ EventLoop.Input.SystemMessage, EventLoop.Input.Mouse, EventLoop.Input.Keyboard, - EventLoop.Input.InputEvent, - FPPrac.Graphics.NormalizeNumber + EventLoop.Input.InputEvent build-depends: base >= 4.6.0.0 && < 5,