eventloop 0.8.2.7 → 0.8.2.8

raw patch · 59 files changed

+4631/−4642 lines, 59 filesdep ~aesondep ~basedep ~networksetup-changednew-uploaderPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: aeson, base, network, stm, websockets

API changes (from Hackage documentation)

Files

• LICENSE +30/−30
• Setup.hs +2/−2
• eventloop.cabal +120/−120
• src/Eventloop/Core.hs +234/−234
• src/Eventloop/DefaultConfiguration.hs +43/−43
• src/Eventloop/Module/BasicShapes.hs +8/−8
• src/Eventloop/Module/BasicShapes/BasicShapes.hs +45/−45
• src/Eventloop/Module/BasicShapes/Classes.hs +529/−531
• src/Eventloop/Module/BasicShapes/Types.hs +120/−123
• src/Eventloop/Module/DrawTrees.hs +8/−8
• src/Eventloop/Module/DrawTrees/DrawTrees.hs +144/−144
• src/Eventloop/Module/DrawTrees/RoseTreeGeneric.hs +92/−92
• src/Eventloop/Module/DrawTrees/Types.hs +25/−30
• src/Eventloop/Module/File.hs +6/−6
• src/Eventloop/Module/File/File.hs +184/−184
• src/Eventloop/Module/File/Types.hs +28/−28
• src/Eventloop/Module/Graphs.hs +6/−6
• src/Eventloop/Module/Graphs/Graphs.hs +230/−230
• src/Eventloop/Module/Graphs/Types.hs +61/−61
• src/Eventloop/Module/StatefulGraphics/StatefulGraphics.hs +2/−1
• src/Eventloop/Module/StdIn.hs +6/−6
• src/Eventloop/Module/StdIn/StdIn.hs +76/−76
• src/Eventloop/Module/StdIn/Types.hs +14/−14
• src/Eventloop/Module/StdOut.hs +6/−6
• src/Eventloop/Module/StdOut/StdOut.hs +38/−38
• src/Eventloop/Module/StdOut/Types.hs +7/−7
• src/Eventloop/Module/Timer.hs +6/−6
• src/Eventloop/Module/Timer/Timer.hs +153/−153
• src/Eventloop/Module/Timer/Types.hs +22/−22
• src/Eventloop/Module/Websocket/Canvas.hs +6/−6
• src/Eventloop/Module/Websocket/Canvas/Canvas.hs +131/−131
• src/Eventloop/Module/Websocket/Canvas/JSONEncoding.hs +232/−232
• src/Eventloop/Module/Websocket/Canvas/Opcode.hs +104/−104
• src/Eventloop/Module/Websocket/Canvas/Types.hs +228/−228
• src/Eventloop/Module/Websocket/Keyboard.hs +6/−6
• src/Eventloop/Module/Websocket/Keyboard/Keyboard.hs +91/−91
• src/Eventloop/Module/Websocket/Keyboard/Types.hs +13/−13
• src/Eventloop/Module/Websocket/Mouse.hs +6/−6
• src/Eventloop/Module/Websocket/Mouse/Mouse.hs +136/−136
• src/Eventloop/Module/Websocket/Mouse/Types.hs +28/−28
• src/Eventloop/OutRouter.hs +20/−20
• src/Eventloop/System/DisplayExceptionThread.hs +25/−25
• src/Eventloop/System/EventloopThread.hs +79/−79
• src/Eventloop/System/InitializationThread.hs +58/−58
• src/Eventloop/System/OutRouterThread.hs +67/−67
• src/Eventloop/System/Processing.hs +72/−72
• src/Eventloop/System/RetrieverThread.hs +44/−44
• src/Eventloop/System/SenderThread.hs +49/−49
• src/Eventloop/System/Setup.hs +90/−90
• src/Eventloop/System/TeardownThread.hs +57/−57
• src/Eventloop/Types/Common.hs +6/−6
• src/Eventloop/Types/Events.hs +40/−40
• src/Eventloop/Types/Exception.hs +67/−67
• src/Eventloop/Types/System.hs +137/−137
• src/Eventloop/Utility/Config.hs +7/−7
• src/Eventloop/Utility/Trees/GeneralTree.hs +139/−140
• src/Eventloop/Utility/Trees/LayoutTree.hs +57/−57
• src/Eventloop/Utility/Vectors.hs +263/−263
• src/Eventloop/Utility/Websockets.hs +128/−129

@@ -1,30 +1,30 @@-Copyright (c) 2015, Sebastiaan la Fleur
-
-All rights reserved.
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are met:
-
-    * Redistributions of source code must retain the above copyright
-      notice, this list of conditions and the following disclaimer.
-
-    * Redistributions in binary form must reproduce the above
-      copyright notice, this list of conditions and the following
-      disclaimer in the documentation and/or other materials provided
-      with the distribution.
-
-    * Neither the name of Sebastiaan la Fleur nor the names of other
-      contributors may be used to endorse or promote products derived
-      from this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+Copyright (c) 2015, Sebastiaan la Fleur++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Sebastiaan la Fleur nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -1,2 +1,2 @@-import Distribution.Simple
-main = defaultMain
+import Distribution.Simple+main = defaultMain

@@ -1,120 +1,120 @@-name:                eventloop
-
--- The package version.  See the Haskell package versioning policy (PVP) 
--- for standards guiding when and how versions should be incremented.
--- http://www.haskell.org/haskellwiki/Package_versioning_policy
--- PVP summary:      +-+------- breaking API changes
---                   | | +----- non-breaking API additions
---                   | | | +--- code changes with no API change
-version:             0.8.2.7
-synopsis:            A different take on an IO system. Based on Amanda's IO loop, this eventloop takes a function that maps input events to output events. It can easily be extended by modules that represent IO devices or join multiple modules together.
-description:         A different take on an IO system. Based on Amanda's IO loop, this eventloop takes a function that maps input events to output events. It can easily be extended by modules that represent IO devices or join multiple modules together.
-                     Each module exists of a initialize and teardown function that are both called once at startup and shutting down. During run-time, a module can provice a preprocessor function (which transforms input events before they get to the eventloop),
-                     and a postprocessor function (which transforms output events after they are received from the eventloop but before they are send off). Next to these bookkeeping functions, a module can exist of a (check for events and an event retrieve) function pair
-                     which result in input events and an addition to the event sender function which handles output events. This results in the following states:
-                     
-                     |Start|:    initialize -> |Run-Time| -> teardown
-                     |Run-Time|: eventCheckers -  Yes > preprocessors -> eventloop -> postprocessors -> event sender -> |Run-Time|
-                                               |- No  > |Run-Time|
-                                               
-                    Each module has a piece of "memory"/state which is defined by the module itself and all of the module states are combined in the IO state. When writing/installing a module, modifications has to be made at certain points in the code
-                    due to the poor modularity of Haskell. 
-homepage:            -
-license:             BSD3
-license-file:        LICENSE
-author:              Sebastiaan la Fleur
-maintainer:          sebastiaan@slafleur.nl
-copyright:           University of Twente 2015 | Sebastiaan la Fleur 2015
-category:            Eventloop
-build-type:          Simple
--- extra-source-files:  
-cabal-version:       >=1.10
-
-library
-  exposed-modules:     Eventloop.Core,
-                       Eventloop.DefaultConfiguration,
-                       
-                       Eventloop.Module.Websocket.Canvas, 
-                       Eventloop.Module.Websocket.Keyboard, 
-                       Eventloop.Module.Websocket.Mouse, 
-                       Eventloop.Module.DrawTrees,
-                       Eventloop.Module.BasicShapes,
-                       Eventloop.Module.File,
-                       Eventloop.Module.StatefulGraphics,
-                       Eventloop.Module.StdIn,
-                       Eventloop.Module.StdOut, 
-                       Eventloop.Module.Timer,
-                       Eventloop.Module.Graphs,
-                       
-                       Eventloop.Types.Common,
-                       Eventloop.Types.Events,
-                       Eventloop.Types.System,
-                       
-                       Eventloop.Utility.Vectors,
-                       Eventloop.Utility.Trees.GeneralTree
-
-  -- Modules included in this library but not exported.
-  other-modules:       Eventloop.OutRouter,
-                       Eventloop.Module.Websocket.Canvas.Canvas,
-                       Eventloop.Module.Websocket.Canvas.JSONEncoding,
-                       Eventloop.Module.Websocket.Canvas.Opcode,
-                       Eventloop.Module.Websocket.Canvas.Types,
-                       Eventloop.Module.Websocket.Keyboard.Keyboard,
-                       Eventloop.Module.Websocket.Keyboard.Types,
-                       Eventloop.Module.Websocket.Mouse.Mouse,
-                       Eventloop.Module.Websocket.Mouse.Types,
-                       Eventloop.Module.DrawTrees.DrawTrees,
-                       Eventloop.Module.DrawTrees.Types,
-                       Eventloop.Module.DrawTrees.RoseTreeGeneric,
-                       Eventloop.Module.BasicShapes.BasicShapes,
-                       Eventloop.Module.BasicShapes.Types,
-                       Eventloop.Module.BasicShapes.Classes,
-                       Eventloop.Module.BasicShapes.MeasureTextHack,
-                       Eventloop.Module.File.File,
-                       Eventloop.Module.File.Types,
-                       Eventloop.Module.StatefulGraphics.StatefulGraphics,
-                       Eventloop.Module.StatefulGraphics.Types,
-                       Eventloop.Module.StdIn.StdIn,
-                       Eventloop.Module.StdIn.Types,
-                       Eventloop.Module.StdOut.StdOut,
-                       Eventloop.Module.StdOut.Types,
-                       Eventloop.Module.Timer.Timer,
-                       Eventloop.Module.Timer.Types,
-                       Eventloop.Module.Graphs.Graphs,
-                       Eventloop.Module.Graphs.Types,
-                       
-                       Eventloop.System.DisplayExceptionThread,
-                       Eventloop.System.EventloopThread,
-                       Eventloop.System.InitializationThread,
-                       Eventloop.System.OutRouterThread,
-                       Eventloop.System.Processing,
-                       Eventloop.System.RetrieverThread,
-                       Eventloop.System.SenderThread,
-                       Eventloop.System.Setup,
-                       Eventloop.System.TeardownThread,
-                       
-                       Eventloop.Types.Exception,
-                       
-                       Eventloop.Utility.Websockets,
-                       Eventloop.Utility.Config,
-                       Eventloop.Utility.Trees.LayoutTree
-  
-  other-extensions:    OverloadedStrings
-  
-  build-depends:       base >=4.8 && <4.12,
-                       network >=2.6 && <2.7, 
-                       text >=1.2 && <1.3, 
-                       websockets >=0.9 && <0.10, 
-                       timers >=0.2 && <0.3, 
-                       suspend >=0.2 && <0.3, 
-                       aeson >=0.8 && <0.12, 
-                       bytestring >=0.10 && <0.11,
-                       concurrent-utilities >=0.2 && <0.3,
-                       stm >=2.4 && <2.5,
-                       deepseq >=1.4 && <1.5
-  
-  -- Directories containing source files.
-  hs-source-dirs:      src
-  
-  -- Base language which the package is written in.
-  default-language:    Haskell2010
+name:                eventloop++-- The package version.  See the Haskell package versioning policy (PVP)+-- for standards guiding when and how versions should be incremented.+-- http://www.haskell.org/haskellwiki/Package_versioning_policy+-- PVP summary:      +-+------- breaking API changes+--                   | | +----- non-breaking API additions+--                   | | | +--- code changes with no API change+version:             0.8.2.8+synopsis:            A different take on an IO system. Based on Amanda's IO loop, this eventloop takes a function that maps input events to output events. It can easily be extended by modules that represent IO devices or join multiple modules together.+description:         A different take on an IO system. Based on Amanda's IO loop, this eventloop takes a function that maps input events to output events. It can easily be extended by modules that represent IO devices or join multiple modules together.+                     Each module exists of a initialize and teardown function that are both called once at startup and shutting down. During run-time, a module can provice a preprocessor function (which transforms input events before they get to the eventloop),+                     and a postprocessor function (which transforms output events after they are received from the eventloop but before they are send off). Next to these bookkeeping functions, a module can exist of a (check for events and an event retrieve) function pair+                     which result in input events and an addition to the event sender function which handles output events. This results in the following states:++                     |Start|:    initialize -> |Run-Time| -> teardown+                     |Run-Time|: eventCheckers -  Yes > preprocessors -> eventloop -> postprocessors -> event sender -> |Run-Time|+                                               |- No  > |Run-Time|++                    Each module has a piece of "memory"/state which is defined by the module itself and all of the module states are combined in the IO state. When writing/installing a module, modifications has to be made at certain points in the code+                    due to the poor modularity of Haskell.+homepage:            -+license:             BSD3+license-file:        LICENSE+author:              Sebastiaan la Fleur+maintainer:          sebastiaan@slafleur.nl+copyright:           University of Twente 2015 | Sebastiaan la Fleur 2015+category:            Eventloop+build-type:          Simple+-- extra-source-files:+cabal-version:       >=1.10++library+  exposed-modules:     Eventloop.Core,+                       Eventloop.DefaultConfiguration,++                       Eventloop.Module.Websocket.Canvas,+                       Eventloop.Module.Websocket.Keyboard,+                       Eventloop.Module.Websocket.Mouse,+                       Eventloop.Module.DrawTrees,+                       Eventloop.Module.BasicShapes,+                       Eventloop.Module.File,+                       Eventloop.Module.StatefulGraphics,+                       Eventloop.Module.StdIn,+                       Eventloop.Module.StdOut,+                       Eventloop.Module.Timer,+                       Eventloop.Module.Graphs,++                       Eventloop.Types.Common,+                       Eventloop.Types.Events,+                       Eventloop.Types.System,++                       Eventloop.Utility.Vectors,+                       Eventloop.Utility.Trees.GeneralTree++  -- Modules included in this library but not exported.+  other-modules:       Eventloop.OutRouter,+                       Eventloop.Module.Websocket.Canvas.Canvas,+                       Eventloop.Module.Websocket.Canvas.JSONEncoding,+                       Eventloop.Module.Websocket.Canvas.Opcode,+                       Eventloop.Module.Websocket.Canvas.Types,+                       Eventloop.Module.Websocket.Keyboard.Keyboard,+                       Eventloop.Module.Websocket.Keyboard.Types,+                       Eventloop.Module.Websocket.Mouse.Mouse,+                       Eventloop.Module.Websocket.Mouse.Types,+                       Eventloop.Module.DrawTrees.DrawTrees,+                       Eventloop.Module.DrawTrees.Types,+                       Eventloop.Module.DrawTrees.RoseTreeGeneric,+                       Eventloop.Module.BasicShapes.BasicShapes,+                       Eventloop.Module.BasicShapes.Types,+                       Eventloop.Module.BasicShapes.Classes,+                       Eventloop.Module.BasicShapes.MeasureTextHack,+                       Eventloop.Module.File.File,+                       Eventloop.Module.File.Types,+                       Eventloop.Module.StatefulGraphics.StatefulGraphics,+                       Eventloop.Module.StatefulGraphics.Types,+                       Eventloop.Module.StdIn.StdIn,+                       Eventloop.Module.StdIn.Types,+                       Eventloop.Module.StdOut.StdOut,+                       Eventloop.Module.StdOut.Types,+                       Eventloop.Module.Timer.Timer,+                       Eventloop.Module.Timer.Types,+                       Eventloop.Module.Graphs.Graphs,+                       Eventloop.Module.Graphs.Types,++                       Eventloop.System.DisplayExceptionThread,+                       Eventloop.System.EventloopThread,+                       Eventloop.System.InitializationThread,+                       Eventloop.System.OutRouterThread,+                       Eventloop.System.Processing,+                       Eventloop.System.RetrieverThread,+                       Eventloop.System.SenderThread,+                       Eventloop.System.Setup,+                       Eventloop.System.TeardownThread,++                       Eventloop.Types.Exception,++                       Eventloop.Utility.Websockets,+                       Eventloop.Utility.Config,+                       Eventloop.Utility.Trees.LayoutTree++  other-extensions:    OverloadedStrings++  build-depends:       base >=4.8 && <4.13,+                       network >=2.6 && <2.9,+                       text >=1.2 && <1.3,+                       websockets >=0.9 && <0.13,+                       aeson >=0.8 && <1.5,+                       timers >=0.2 && <0.3,+                       suspend >=0.2 && <0.3,+                       bytestring >=0.10 && <0.11,+                       concurrent-utilities >=0.2 && <0.3,+                       stm >=2.4 && <2.6,+                       deepseq >=1.4 && <1.5++  -- Directories containing source files.+  hs-source-dirs:      src++  -- Base language which the package is written in.+  default-language:    Haskell2010

@@ -1,234 +1,234 @@-module Eventloop.Core where
-
-import Control.Exception
-import Control.Concurrent
-import Control.Concurrent.MVar
-import Control.Concurrent.ExceptionCollection
-import Control.Concurrent.Suspend.Lifted
-import Control.Concurrent.Thread
-import Control.Concurrent.Timer
-import Control.Concurrent.Datastructures.BlockingConcurrentQueue
-
-import Eventloop.System.DisplayExceptionThread
-import Eventloop.System.EventloopThread
-import Eventloop.System.InitializationThread
-import Eventloop.System.OutRouterThread
-import Eventloop.System.RetrieverThread
-import Eventloop.System.SenderThread
-import Eventloop.System.Setup
-import Eventloop.System.TeardownThread
-import Eventloop.Types.Events
-import Eventloop.Types.Exception
-import Eventloop.Types.System
-
-
-
-{- | Starts the entire system. First the setup phase is handled to setup the different
-concurrent resources. This is followed by the initialization phase where all modules are initialised.
-Than, the different worker threads are spawned and finally the system thread will go to work as the eventloop thread.
-
-Shutting down is handled centrally through the system thread (main thread).
-If any of the threads(including the system thread) receive an exception, only the first exception is thrown to the system
-thread which will try to shutdown immediately. This exception is logged by the system thread.
-All other exceptions are logged by their respective threads. The system thread will than shutdown the worker
-threads. This is done by throwing exceptions to all workerthreads except sender threads. These are sent a Stop event.
-If they take longer than 1 second, to finish up, they will also be thrown an exception.
--}
-startEventloopSystem :: EventloopSetupConfiguration progstateT
-                     -> IO ()
-startEventloopSystem setupConfig
-    = do
-        systemConfig <- setupEventloopSystemConfig setupConfig -- Setup
-        systemConfig' <- catch (startInitializing systemConfig) -- Initialization
-                               (\shutdownException -> do
-                                    logException (exceptions systemConfig) shutdownException -- Log the thrown exception
-                                    return systemConfig
-                               )
-        failed <- hasExceptions (exceptions systemConfig')
-        case failed of
-            True -> return ()
-            False -> do
-                let
-                    moduleConfigs_ = moduleConfigs systemConfig'
-                    exceptions_ = exceptions systemConfig'
-                    isStoppingM_ = isStoppingM systemConfig'
-                catch ( do
-                            let
-                                retrieverThreadActions = threadActionsBasedOnModule systemConfig' startRetrieving retrieverM moduleConfigs_
-                                outRouterAction = startOutRouting systemConfig'
-                                senderThreadActions = threadActionsBasedOnModule systemConfig' startSending senderConfigM moduleConfigs_
-                            -- Spawn worker threads
-                            mapM_ (spawnWorkerThread systemConfig' registerRetrieverThread) retrieverThreadActions
-                            spawnWorkerThread systemConfig' registerOutRouterThread outRouterAction
-                            mapM_ (spawnWorkerThread systemConfig' registerSenderThread) senderThreadActions
-                            startEventlooping systemConfig' -- Eventlooping
-                      )
-                      ( \shutdownException -> do
-                            swapMVar isStoppingM_ True -- If its already true, nothing happens, otherwise notify other threads the system thread is already shutting down
-                            logException exceptions_ shutdownException -- Log the thrown exception
-
-                            -- Send a stop to the OutRouter
-                            outRouter <- outRouterThread systemConfig'
-                            let
-                                eventloopConfig_ = eventloopConfig systemConfig'
-                                outEventQueue_ = outEventQueue eventloopConfig_
-                            putInBlockingConcurrentQueue outEventQueue_ Stop
-
-                            -- Wait for the Stop to propagate
-                            threadDelay 1000000
-
-                            -- Kill the outrouter and senders if need be
-                            senders <- senderThreads systemConfig'
-                            senderTimers <- mapM (terminateWithinOrThrowException 2000000 (toException ShuttingDownException)) (outRouter ++ senders)
-
-                            -- Wait for the outRouter and Sender
-                            joinThreads (outRouter ++ senders)
-
-                            -- Stop all outrouter and sender kill timers if they are still active
-                            mapM_ stopTimer senderTimers
-
-                            -- Stop the retriever threads
-                            retrievers <- retrieverThreads systemConfig'
-                            mapM_ throwShutdownExceptionToThread retrievers
-
-                            -- Wait for all retrievers
-                            joinThreads retrievers
-                      )
-        -- Clean up the system
-        startTeardowning systemConfig'
-        startDisplayingExceptions systemConfig'
-
-terminateWithinOrThrowException :: Int
-                                -> SomeException
-                                -> Thread
-                                -> IO TimerIO
-terminateWithinOrThrowException delay e t
-    = oneShotTimer ( do
-                       term <- isTerminated t
-                       case term of
-                        True  -> return ()
-                        False -> throwTo (getThreadId t) e
-                     )
-                     ((usDelay.fromIntegral) delay)
-
-{- |
-Utility function in order to create the different thread actions in the system.
-Assumed is that the action requires the system configuration, the module configuration and some resource
-that may be available in the module configuration.
--}
-threadActionsBasedOnModule :: EventloopSystemConfiguration progstateT
-                           -> (EventloopSystemConfiguration progstateT -> (EventloopModuleConfiguration, resource) -> IO ())
-                           -> (EventloopModuleConfiguration -> Maybe resource)
-                           -> [EventloopModuleConfiguration]
-                           -> [IO ()]
-threadActionsBasedOnModule _ _ _ [] = []
-threadActionsBasedOnModule systemconfig action getResourceFunc (moduleConfig:mcs)
-    = case (getResourceFunc moduleConfig) of
-        Nothing         -> otherThreadActions
-        (Just resource) -> (action systemconfig (moduleConfig, resource)):otherThreadActions
-    where
-        otherThreadActions = threadActionsBasedOnModule systemconfig action getResourceFunc mcs
-
-        
-spawnWorkerThread :: EventloopSystemConfiguration progstateT
-                  -> (EventloopSystemConfiguration progstateT -> Thread -> IO ())
-                  -> IO ()
-                  -> IO ()
-spawnWorkerThread systemconfig logAction action
-    = do
-        thread <- forkThread $ do
-            catch action
-                ( \exception ->
-                        case (fromException exception) of
-                            (Just ShuttingDownException) ->
-                                return ()
-                            _                     -> do
-                                isStopping <- takeMVar isStoppingM_
-                                putMVar isStoppingM_ True
-                                case isStopping of
-                                    True -> do
-                                        case (fromException exception) of
-                                            (Just RequestShutdownException) -> return ()
-                                            _                               -> logException exceptions_ exception
-                                    False -> throwTo systemTid exception
-                    )
-        logAction systemconfig thread
-                                                    
-    where
-        exceptions_ = exceptions systemconfig
-        systemTid = systemThreadId systemconfig
-        isStoppingM_ = isStoppingM systemconfig
-                    
- 
-registerRetrieverThread :: EventloopSystemConfiguration progstateT
-                        -> Thread
-                        -> IO ()
-registerRetrieverThread systemconfig thread
-    = do
-        retrieverThreads <- takeMVar retrieverThreadsM_
-        putMVar retrieverThreadsM_ (retrieverThreads ++ [thread])
-    where
-        retrieverThreadsM_ = retrieverThreadsM systemconfig
-
-
-registerOutRouterThread :: EventloopSystemConfiguration progstateT
-                        -> Thread
-                        -> IO ()
-registerOutRouterThread systemconfig thread
-    = putMVar (outRouterThreadM systemconfig) thread
-
-
-registerSenderThread :: EventloopSystemConfiguration progstateT
-                        -> Thread
-                        -> IO ()
-registerSenderThread systemconfig thread
-    = do
-        senderThreads <- takeMVar senderThreadsM_
-        putMVar senderThreadsM_ (senderThreads ++ [thread])
-    where
-        senderThreadsM_ = senderThreadsM systemconfig
-        
-
-throwShutdownExceptionToThread :: Thread -> IO ()
-throwShutdownExceptionToThread thread
-    = throwTo (getThreadId thread) ShuttingDownException
-        
-        
-allWorkerThreads :: EventloopSystemConfiguration progstateT
-                 -> IO [Thread]
-allWorkerThreads systemconfig
-    = do
-        retrievers <- retrieverThreads systemconfig
-        outRouter <- outRouterThread systemconfig
-        senders <- senderThreads systemconfig
-        return (retrievers ++ outRouter ++ senders)
-
-
-retrieverThreads :: EventloopSystemConfiguration progstateT
-                 -> IO [Thread]
-retrieverThreads systemconfig
-    = readMVar retrieverThreadsM_
-    where
-        retrieverThreadsM_ = retrieverThreadsM systemconfig
-
-
-outRouterThread :: EventloopSystemConfiguration progstateT
-                -> IO [Thread]
-outRouterThread systemconfig
-    = do
-        hasNotOutRouterThread <- isEmptyMVar outRouterThreadM_
-        case hasNotOutRouterThread of
-                    True  -> return []
-                    False -> do
-                                outRouterThread <- readMVar outRouterThreadM_
-                                return [outRouterThread]
-    where
-        outRouterThreadM_ = outRouterThreadM systemconfig
-
-
-senderThreads :: EventloopSystemConfiguration progstateT
-                 -> IO [Thread]
-senderThreads systemconfig
-    = readMVar senderThreadsM_
-    where
-        senderThreadsM_ = senderThreadsM systemconfig
+module Eventloop.Core where++import Control.Exception+import Control.Concurrent+import Control.Concurrent.MVar+import Control.Concurrent.ExceptionCollection+import Control.Concurrent.Suspend.Lifted+import Control.Concurrent.Thread+import Control.Concurrent.Timer+import Control.Concurrent.Datastructures.BlockingConcurrentQueue++import Eventloop.System.DisplayExceptionThread+import Eventloop.System.EventloopThread+import Eventloop.System.InitializationThread+import Eventloop.System.OutRouterThread+import Eventloop.System.RetrieverThread+import Eventloop.System.SenderThread+import Eventloop.System.Setup+import Eventloop.System.TeardownThread+import Eventloop.Types.Events+import Eventloop.Types.Exception+import Eventloop.Types.System++++{- | Starts the entire system. First the setup phase is handled to setup the different+concurrent resources. This is followed by the initialization phase where all modules are initialised.+Than, the different worker threads are spawned and finally the system thread will go to work as the eventloop thread.++Shutting down is handled centrally through the system thread (main thread).+If any of the threads(including the system thread) receive an exception, only the first exception is thrown to the system+thread which will try to shutdown immediately. This exception is logged by the system thread.+All other exceptions are logged by their respective threads. The system thread will than shutdown the worker+threads. This is done by throwing exceptions to all workerthreads except sender threads. These are sent a Stop event.+If they take longer than 1 second, to finish up, they will also be thrown an exception.+-}+startEventloopSystem :: EventloopSetupConfiguration progstateT+                     -> IO ()+startEventloopSystem setupConfig+    = do+        systemConfig <- setupEventloopSystemConfig setupConfig -- Setup+        systemConfig' <- catch (startInitializing systemConfig) -- Initialization+                               (\shutdownException -> do+                                    logException (exceptions systemConfig) shutdownException -- Log the thrown exception+                                    return systemConfig+                               )+        failed <- hasExceptions (exceptions systemConfig')+        case failed of+            True -> return ()+            False -> do+                let+                    moduleConfigs_ = moduleConfigs systemConfig'+                    exceptions_ = exceptions systemConfig'+                    isStoppingM_ = isStoppingM systemConfig'+                catch ( do+                            let+                                retrieverThreadActions = threadActionsBasedOnModule systemConfig' startRetrieving retrieverM moduleConfigs_+                                outRouterAction = startOutRouting systemConfig'+                                senderThreadActions = threadActionsBasedOnModule systemConfig' startSending senderConfigM moduleConfigs_+                            -- Spawn worker threads+                            mapM_ (spawnWorkerThread systemConfig' registerRetrieverThread) retrieverThreadActions+                            spawnWorkerThread systemConfig' registerOutRouterThread outRouterAction+                            mapM_ (spawnWorkerThread systemConfig' registerSenderThread) senderThreadActions+                            startEventlooping systemConfig' -- Eventlooping+                      )+                      ( \shutdownException -> do+                            swapMVar isStoppingM_ True -- If its already true, nothing happens, otherwise notify other threads the system thread is already shutting down+                            logException exceptions_ shutdownException -- Log the thrown exception++                            -- Send a stop to the OutRouter+                            outRouter <- outRouterThread systemConfig'+                            let+                                eventloopConfig_ = eventloopConfig systemConfig'+                                outEventQueue_ = outEventQueue eventloopConfig_+                            putInBlockingConcurrentQueue outEventQueue_ Stop++                            -- Wait for the Stop to propagate+                            threadDelay 1000000++                            -- Kill the outrouter and senders if need be+                            senders <- senderThreads systemConfig'+                            senderTimers <- mapM (terminateWithinOrThrowException 2000000 (toException ShuttingDownException)) (outRouter ++ senders)++                            -- Wait for the outRouter and Sender+                            joinThreads (outRouter ++ senders)++                            -- Stop all outrouter and sender kill timers if they are still active+                            mapM_ stopTimer senderTimers++                            -- Stop the retriever threads+                            retrievers <- retrieverThreads systemConfig'+                            mapM_ throwShutdownExceptionToThread retrievers++                            -- Wait for all retrievers+                            joinThreads retrievers+                      )+        -- Clean up the system+        startTeardowning systemConfig'+        startDisplayingExceptions systemConfig'++terminateWithinOrThrowException :: Int+                                -> SomeException+                                -> Thread+                                -> IO TimerIO+terminateWithinOrThrowException delay e t+    = oneShotTimer ( do+                       term <- isTerminated t+                       case term of+                        True  -> return ()+                        False -> throwTo (getThreadId t) e+                     )+                     ((usDelay.fromIntegral) delay)++{- |+Utility function in order to create the different thread actions in the system.+Assumed is that the action requires the system configuration, the module configuration and some resource+that may be available in the module configuration.+-}+threadActionsBasedOnModule :: EventloopSystemConfiguration progstateT+                           -> (EventloopSystemConfiguration progstateT -> (EventloopModuleConfiguration, resource) -> IO ())+                           -> (EventloopModuleConfiguration -> Maybe resource)+                           -> [EventloopModuleConfiguration]+                           -> [IO ()]+threadActionsBasedOnModule _ _ _ [] = []+threadActionsBasedOnModule systemconfig action getResourceFunc (moduleConfig:mcs)+    = case (getResourceFunc moduleConfig) of+        Nothing         -> otherThreadActions+        (Just resource) -> (action systemconfig (moduleConfig, resource)):otherThreadActions+    where+        otherThreadActions = threadActionsBasedOnModule systemconfig action getResourceFunc mcs+++spawnWorkerThread :: EventloopSystemConfiguration progstateT+                  -> (EventloopSystemConfiguration progstateT -> Thread -> IO ())+                  -> IO ()+                  -> IO ()+spawnWorkerThread systemconfig logAction action+    = do+        thread <- forkThread $ do+            catch action+                ( \exception ->+                        case (fromException exception) of+                            (Just ShuttingDownException) ->+                                return ()+                            _                     -> do+                                isStopping <- takeMVar isStoppingM_+                                putMVar isStoppingM_ True+                                case isStopping of+                                    True -> do+                                        case (fromException exception) of+                                            (Just RequestShutdownException) -> return ()+                                            _                               -> logException exceptions_ exception+                                    False -> throwTo systemTid exception+                    )+        logAction systemconfig thread++    where+        exceptions_ = exceptions systemconfig+        systemTid = systemThreadId systemconfig+        isStoppingM_ = isStoppingM systemconfig+++registerRetrieverThread :: EventloopSystemConfiguration progstateT+                        -> Thread+                        -> IO ()+registerRetrieverThread systemconfig thread+    = do+        retrieverThreads <- takeMVar retrieverThreadsM_+        putMVar retrieverThreadsM_ (retrieverThreads ++ [thread])+    where+        retrieverThreadsM_ = retrieverThreadsM systemconfig+++registerOutRouterThread :: EventloopSystemConfiguration progstateT+                        -> Thread+                        -> IO ()+registerOutRouterThread systemconfig thread+    = putMVar (outRouterThreadM systemconfig) thread+++registerSenderThread :: EventloopSystemConfiguration progstateT+                        -> Thread+                        -> IO ()+registerSenderThread systemconfig thread+    = do+        senderThreads <- takeMVar senderThreadsM_+        putMVar senderThreadsM_ (senderThreads ++ [thread])+    where+        senderThreadsM_ = senderThreadsM systemconfig+++throwShutdownExceptionToThread :: Thread -> IO ()+throwShutdownExceptionToThread thread+    = throwTo (getThreadId thread) ShuttingDownException+++allWorkerThreads :: EventloopSystemConfiguration progstateT+                 -> IO [Thread]+allWorkerThreads systemconfig+    = do+        retrievers <- retrieverThreads systemconfig+        outRouter <- outRouterThread systemconfig+        senders <- senderThreads systemconfig+        return (retrievers ++ outRouter ++ senders)+++retrieverThreads :: EventloopSystemConfiguration progstateT+                 -> IO [Thread]+retrieverThreads systemconfig+    = readMVar retrieverThreadsM_+    where+        retrieverThreadsM_ = retrieverThreadsM systemconfig+++outRouterThread :: EventloopSystemConfiguration progstateT+                -> IO [Thread]+outRouterThread systemconfig+    = do+        hasNotOutRouterThread <- isEmptyMVar outRouterThreadM_+        case hasNotOutRouterThread of+                    True  -> return []+                    False -> do+                                outRouterThread <- readMVar outRouterThreadM_+                                return [outRouterThread]+    where+        outRouterThreadM_ = outRouterThreadM systemconfig+++senderThreads :: EventloopSystemConfiguration progstateT+                 -> IO [Thread]+senderThreads systemconfig+    = readMVar senderThreadsM_+    where+        senderThreadsM_ = senderThreadsM systemconfig

@@ -1,44 +1,44 @@-module Eventloop.DefaultConfiguration where
-
-import Control.Concurrent.SafePrint
-
-import Eventloop.Module.Websocket.Keyboard
-import Eventloop.Module.Websocket.Mouse
-import Eventloop.Module.File
-import Eventloop.Module.StdOut
-import Eventloop.Module.StdIn
-import Eventloop.Module.Timer
-import Eventloop.Types.Events
-import Eventloop.Types.System
-
-allModulesEventloopSetupConfiguration :: progstateT -> {- Begin program state -}
-                                         (progstateT -> In -> (progstateT, [Out])) -> {- Eventloop function -}
-                                         EventloopSetupConfiguration progstateT
-allModulesEventloopSetupConfiguration beginProgstate eventloop
-    = ( EventloopSetupConfiguration
-            -- Begin program state
-            beginProgstate
-            
-            -- Eventloop function
-            eventloop
-            
-            -- All module setupconfigurations
-            [ setupFileModuleConfiguration
-            , setupTimerModuleConfiguration
-            , setupKeyboardModuleConfiguration
-            , setupMouseModuleConfiguration
-            , setupStdInModuleConfiguration
-            , setupStdOutModuleConfiguration
-            ]
-        )
-
-
-setupSharedIOConstants :: IO SharedIOConstants
-setupSharedIOConstants
-    = do
-        safePrintToken <- createSafePrintToken
-        return (SharedIOConstants safePrintToken undefined)
-
-setupSharedIOState :: IO SharedIOState
-setupSharedIOState
+module Eventloop.DefaultConfiguration where++import Control.Concurrent.SafePrint++import Eventloop.Module.Websocket.Keyboard+import Eventloop.Module.Websocket.Mouse+import Eventloop.Module.File+import Eventloop.Module.StdOut+import Eventloop.Module.StdIn+import Eventloop.Module.Timer+import Eventloop.Types.Events+import Eventloop.Types.System++allModulesEventloopSetupConfiguration :: progstateT -> {- Begin program state -}+                                         (progstateT -> In -> (progstateT, [Out])) -> {- Eventloop function -}+                                         EventloopSetupConfiguration progstateT+allModulesEventloopSetupConfiguration beginProgstate eventloop+    = ( EventloopSetupConfiguration+            -- Begin program state+            beginProgstate++            -- Eventloop function+            eventloop++            -- All module setupconfigurations+            [ setupFileModuleConfiguration+            , setupTimerModuleConfiguration+            , setupKeyboardModuleConfiguration+            , setupMouseModuleConfiguration+            , setupStdInModuleConfiguration+            , setupStdOutModuleConfiguration+            ]+        )+++setupSharedIOConstants :: IO SharedIOConstants+setupSharedIOConstants+    = do+        safePrintToken <- createSafePrintToken+        return (SharedIOConstants safePrintToken undefined)++setupSharedIOState :: IO SharedIOState+setupSharedIOState     = return SharedIOState

@@ -1,9 +1,9 @@-module Eventloop.Module.BasicShapes
-    ( module Eventloop.Module.BasicShapes.BasicShapes
-    , module Eventloop.Module.BasicShapes.Types
-    , module Eventloop.Module.BasicShapes.Classes
-    ) where
-    
-import Eventloop.Module.BasicShapes.BasicShapes
-import Eventloop.Module.BasicShapes.Types
+module Eventloop.Module.BasicShapes+    ( module Eventloop.Module.BasicShapes.BasicShapes+    , module Eventloop.Module.BasicShapes.Types+    , module Eventloop.Module.BasicShapes.Classes+    ) where++import Eventloop.Module.BasicShapes.BasicShapes+import Eventloop.Module.BasicShapes.Types import Eventloop.Module.BasicShapes.Classes

@@ -1,46 +1,46 @@-module Eventloop.Module.BasicShapes.BasicShapes
-    ( setupBasicShapesModuleConfiguration
-    , basicShapesModuleIdentifier
-    , basicShapesPostProcessor
-    ) where
-
-import Control.Concurrent.SafePrint
-
-import Eventloop.Module.BasicShapes.Types
-import Eventloop.Module.BasicShapes.Classes
-import Eventloop.Module.BasicShapes.MeasureTextHack
-import Eventloop.Types.Common
-import Eventloop.Types.Events
-import Eventloop.Types.System
-
-setupBasicShapesModuleConfiguration :: EventloopSetupModuleConfiguration
-setupBasicShapesModuleConfiguration = ( EventloopSetupModuleConfiguration
-                                            basicShapesModuleIdentifier
-                                            (Just basicShapesInitializer)
-                                            Nothing
-                                            Nothing
-                                            (Just basicShapesPostProcessor)
-                                            Nothing
-                                            Nothing
-                                        )
-
-
-basicShapesModuleIdentifier :: EventloopModuleIdentifier
-basicShapesModuleIdentifier = "basicshapes"
-
-
-basicShapesInitializer :: Initializer
-basicShapesInitializer sharedConst sharedIO
-    = do
-        saveMeasureText (measureText sharedConst)
-        return (sharedConst, sharedIO, NoConstants, NoState)
-
-
-basicShapesPostProcessor :: PostProcessor
-basicShapesPostProcessor sharedConst sharedIOT ioConst ioStateT (OutBasicShapes basicShapesOut)
-    = return [OutCanvas canvasOut]
-    where
-        canvasOut = toCanvasOut basicShapesOut
-        
-basicShapesPostProcessor sharedConst sharedIOT ioConst ioStateT out
+module Eventloop.Module.BasicShapes.BasicShapes+    ( setupBasicShapesModuleConfiguration+    , basicShapesModuleIdentifier+    , basicShapesPostProcessor+    ) where++import Control.Concurrent.SafePrint++import Eventloop.Module.BasicShapes.Types+import Eventloop.Module.BasicShapes.Classes+import Eventloop.Module.BasicShapes.MeasureTextHack+import Eventloop.Types.Common+import Eventloop.Types.Events+import Eventloop.Types.System++setupBasicShapesModuleConfiguration :: EventloopSetupModuleConfiguration+setupBasicShapesModuleConfiguration = ( EventloopSetupModuleConfiguration+                                            basicShapesModuleIdentifier+                                            (Just basicShapesInitializer)+                                            Nothing+                                            Nothing+                                            (Just basicShapesPostProcessor)+                                            Nothing+                                            Nothing+                                        )+++basicShapesModuleIdentifier :: EventloopModuleIdentifier+basicShapesModuleIdentifier = "basicshapes"+++basicShapesInitializer :: Initializer+basicShapesInitializer sharedConst sharedIO+    = do+        saveMeasureText (measureText sharedConst)+        return (sharedConst, sharedIO, NoConstants, NoState)+++basicShapesPostProcessor :: PostProcessor+basicShapesPostProcessor sharedConst sharedIOT ioConst ioStateT (OutBasicShapes basicShapesOut)+    = return [OutCanvas canvasOut]+    where+        canvasOut = toCanvasOut basicShapesOut++basicShapesPostProcessor sharedConst sharedIOT ioConst ioStateT out     = return [out]

@@ -1,531 +1,529 @@-module Eventloop.Module.BasicShapes.Classes where
-
-import Control.Concurrent.MVar
-import Data.Maybe
-
-import Eventloop.Utility.Vectors
-import Eventloop.Module.BasicShapes.Types
-import Eventloop.Module.BasicShapes.MeasureTextHack
-import qualified Eventloop.Module.Websocket.Canvas.Types as CT
-
-{-
-The center of a boundingbox is not the center of an element
-    Rectangle - Intersection of two halves of adjoining sides
-    Circle    - Centre point
-    RegularPolygon   - Centre point
-    Text      - See boundingbox to rectangle
-    Line      - Halfway down the line
-    MultiLine - See boundingbox
-Split into points to calc boundingbox
-    Rectangle - Split into 4 corners
-    Circle    - Top, left, right and bottom points on the circle
-    RegularPolygon   - Split into the regular polygon points
-    Text      - Split into 4 corners of bbox
-    Line      - Split into the two points
-    MultiLine - Split into the different points with stroke
-    Polygon   - Split into the different points with stroke
--}
-
-{-
-Bugs:
-- BoundingBox of circle fails. Cannot use 'rotate points on circle' method.
-- Difficult rotation? (Stacked composite shapes)
--}
-
-data GeometricPrimitive = Points [Point]
-                        | CircleArea Point Radius
-                        deriving (Show, Eq)
-
-
-instance RotateLeftAround GeometricPrimitive where
-    rotateLeftAround p angle (Points points)
-        = Points $ map (rotateLeftAround p angle) points
-    rotateLeftAround p angle (CircleArea p' r)
-        = CircleArea (rotateLeftAround p angle p') r
-
-
-opOnBoundingBox :: (Point -> Point) -> BoundingBox -> BoundingBox
-opOnBoundingBox op (BoundingBox p1 p2 p3 p4) = BoundingBox (op p1)
-                                                           (op p2)
-                                                           (op p3)
-                                                           (op p4)
- 
-
-instance ExtremaCoord BoundingBox where
-    xMin (BoundingBox ll _ _ _) = x ll
-    xMax (BoundingBox _ _ ur _) = x ur
-    yMin (BoundingBox ll _ _ _) = y ll
-    yMax (BoundingBox _ _ ur _) = y ur
-
-
-instance ExtremaCoord GeometricPrimitive where
-    xMin (Points points) = xMin points
-    xMin (CircleArea (Point (x, y)) r) = x - r
-
-    xMax (Points points) = xMax points
-    xMax (CircleArea (Point (x, y)) r) = x + r
-
-    yMin (Points points) = yMin points
-    yMin (CircleArea (Point (x, y)) r) = y - r
-
-    yMax (Points points) = yMax points
-    yMax (CircleArea (Point (x, y)) r) = y + r
-
-
-instance RotateLeftAround BoundingBox where
-    rotateLeftAround p angle bbox = opOnBoundingBox (rotateLeftAround p angle) bbox
-
-
-
-allRegularPolygonPoints :: NumberOfPoints -> Point -> Radius -> [Point]
-allRegularPolygonPoints n centralPoint r | n < 1 = error "A regular polygon with 0 or more sides doesn't exist!"
-                                  | otherwise = [centralPoint |+| (toPoint (PolarCoord (r, angle)))  |angle <- anglesRads]
-                                where
-                                    anglePart = 360 / (fromIntegral n)
-                                    startAngle = 0
-                                    anglesDeg = filter (< 360) [startAngle, startAngle + anglePart..360]
-                                    anglesRads = map degreesToRadians anglesDeg
-
-
-boundingBoxFromPrimitives :: [GeometricPrimitive] -> BoundingBox
-boundingBoxFromPrimitives primitives
-    = BoundingBox (Point (xMin_, yMin_)) (Point (xMin_, yMax_)) (Point (xMax_, yMax_)) (Point (xMax_, yMin_))
-    where
-        xMin_ = minimum $ map xMin primitives
-        xMax_ = maximum $ map xMax primitives
-        yMin_ = minimum $ map yMin primitives
-        yMax_ = maximum $ map yMax primitives
-
-
-normalizeBBox :: BoundingBox -> BoundingBox
-normalizeBBox (BoundingBox p1 p2 p3 p4)
-    = boundingBoxFromPrimitives [Points [p1, p2, p3, p4]]
-
-
-roundPoint :: Point -> CT.ScreenPoint
-roundPoint (Point (x, y)) = (round x, round y)
-
-
-roundColor :: Color -> CT.ScreenColor
-roundColor (r, b, g, a) = (round r, round b, round g, a)
-
-strokePointsForLine :: StrokeLineThickness -> Point -> Point -> [Point]
-strokePointsForLine thick p1 p2
-    = [ followVector (0.5 * thick) upPerpVector p1
-      , followVector (0.5 * thick) upPerpVector p2
-      , followVector (0.5 * thick) downPerpVector p1
-      , followVector (0.5 * thick) downPerpVector p2
-      ]
-
-    where
-        upPerpVector = upPerpendicular p1 p2
-        downPerpVector = negateVector upPerpVector
-
-strokePointsForConnection :: StrokeLineThickness -> Point -> Point -> Point -> [Point]
-strokePointsForConnection strokeWidth start inspected dest
-    | start == inspected && inspected == dest = [dest]
-    | start == inspected                      = strokePointsForLine strokeWidth inspected dest
-    | inspected == dest                       = strokePointsForLine strokeWidth start inspected
-    | isJust mp1 && isJust mp2                = [fromJust mp1, fromJust mp2]
-    | otherwise                               = [sup1, sdown1] -- Is possible due to rounding. Direction vectors are roughly parallel but stepping points are not equal
-                                                               -- GHC will think parallel vectors are parallel while they are not. So no intersection as stepping points are slightly different
-                                                               -- Just return half width up and down from inspected as this is close enough
-    where
-        halfWidth = strokeWidth / 2
-        quart = 0.5 * pi
-        v1 = inspected |-| start
-        v1' = negateVector v1
-        v2 = inspected |-| dest
-        v2' = negateVector v2
-        upv1 = turnToVector v1 quart v2
-        sup1 = followVector halfWidth upv1 inspected
-        upv2 = turnToVector v2 quart v1
-        sup2 = followVector halfWidth upv2 inspected
-        downv1 = negateVector upv1
-        sdown1 = followVector halfWidth downv1 inspected
-        downv2 = negateVector upv2
-        sdown2 = followVector halfWidth downv2 inspected
-        mp1 = intersectVector sdown1 v1 sdown2 v2
-        mp2 = intersectVector sup1 v1 sup2 v2
-
-
-strokePoints :: StrokeLineThickness -> [Point] -> [Point]
-strokePoints strokeWidth ps
-    | l >= 3    = concat $ map (\(start, inspected, dest) -> strokePointsForConnection strokeWidth start inspected dest) connections
-    | otherwise = []
-    where
-        l = length ps
-        connections = zip3 ps (drop 1 ps) (drop 2 ps)
-
-
-strokePointsClosedPath :: StrokeLineThickness -> [Point] -> [Point]
-strokePointsClosedPath strokeWidth ps
-    | length ps >= 3 = strokePoints strokeWidth (ps ++ take 2 ps)
-    | otherwise = []
-
-
-instance Translate Shape where
-    translate p c@(CompositeShape {positionM=Nothing})
-        = c {positionM = (Just p)}
-    translate p c@(CompositeShape {positionM=(Just p1)})
-        = c {positionM = (Just $ p1 |+| p)}
-    translate p r@(Rectangle {position=trans})
-        = r {position = trans |+| p}
-    translate p c@(Circle {position=trans})
-        = c {position = trans |+| p}
-    translate p po@(RegularPolygon {position=trans})
-        = po {position = trans |+| p}
-    translate p t@(Text {position=trans})
-        = t {position = trans |+| p}
-    translate pTrans l@(Line {point1=p1, point2=p2})
-        = l {point1 = (p1 |+| pTrans), point2 = (p2 |+| pTrans)}
-    translate pTrans ml@(MultiLine {points=points})
-        = ml {points = (map ((|+|) pTrans) points)}
-    translate pTrans a@(Polygon {points=points})
-        = a {points = (map ((|+|) pTrans) points)}
-
-instance Translate GeometricPrimitive where
-    translate p (Points points) = Points (map (|+| p) points)
-    translate p (CircleArea p' r) = CircleArea (p |+| p') r
-
-
-class ToPrimitives a where
-    toPrimitives :: a -> [GeometricPrimitive]
-
-instance ToPrimitives BoundingBox where
-    toPrimitives (BoundingBox ll ul ur lr) = [Points [ll, ul, ur, lr]]
-
-instance ToPrimitives Shape where
-    toPrimitives (CompositeShape shapes positionM Nothing)
-        | isJust positionM = map (translate (fromJust positionM)) primitives
-        | otherwise           = primitives
-        where
-            primitives = concat $ map toPrimitives shapes
-    toPrimitives (Rectangle {position=(Point (x, y)), dimensions=(w, h), strokeLineThickness=thick, rotationM=Nothing})
-        = [ Points [ Point (x - hthick, y - hthick)
-                   , Point (x - hthick, y + h + hthick)
-                   , Point (x + w + hthick, y + h + hthick)
-                   , Point (x + w + hthick, y - hthick)
-                   ]
-          ]
-        where
-            hthick = 0.5 * thick
-    toPrimitives (Circle {position=p, radius=r, strokeLineThickness=thick, rotationM=Nothing})
-        = [CircleArea p (r + 0.5 * thick)]
-    toPrimitives (RegularPolygon {numberOfPoints=a, position=p, radius=r, strokeLineThickness=thick, rotationM=Nothing})
-        = toPrimitives (Polygon points undefined thick undefined Nothing)
-        where
-             points = allRegularPolygonPoints a p r
-    toPrimitives text@(Text {position=(Point (x,y)), alignment=align, rotationM=Nothing})
-        = [ Points $ case align of
-            CT.AlignLeft   -> [ Point (x, y)
-                              , Point (x, y + height)
-                              , Point (x + width, y)
-                              , Point (x + width, y + height)
-                              ]
-            CT.AlignCenter -> [ Point (x - hwidth, y - hheight)
-                              , Point (x - hwidth, y + hheight)
-                              , Point (x + hwidth, y - hheight)
-                              , Point (x + hwidth, y + hheight)
-                              ]
-            CT.AlignRight  -> [ Point (x, y)
-                              , Point (x, y + height)
-                              , Point (x - width, y)
-                              , Point (x - width, y + height)
-                              ]
-          ]
-        where
-            canvasText = toCanvasText text
-            (width_, height_) = useMeasureText canvasText
-            width = fromIntegral width_
-            hwidth = width * 0.5
-            height = fromIntegral height_
-            hheight = height * 0.5
-
-    toPrimitives (Line {point1=p1, point2=p2, strokeLineThickness=thick, rotationM=Nothing})
-        = [Points (strokePointsForLine thick p1 p2)]
-    toPrimitives (MultiLine {points=points, strokeLineThickness=thick, strokeColor=color, rotationM=Nothing})
-        | len >= 3 = (Points strokePoints_) : (concat $ map toPrimitives lines)
-        | len == 2 = toPrimitives (Line p1 p2 thick color Nothing)
-        | otherwise = error "Multilines should atleast include 2 points!"
-        where
-            [p1, p2] = points
-            len = length points
-            strokePoints_ = strokePoints thick points
-            tailPoints = drop 1 points
-            linePoints = zip points tailPoints
-            lines = map (\(p, p') -> Line p p' thick undefined Nothing) linePoints
-    toPrimitives (FilledMultiLine {points=points, fillWidth=fillThick, strokeLineThickness=strokeThick, rotationM=Nothing})
-        = (toPrimitives (MultiLine points fillThick undefined Nothing)) ++ (toPrimitives (MultiLine points (fillThick + strokeThick) undefined Nothing))
-    toPrimitives pol@(Polygon {points=points, strokeLineThickness=thick, rotationM=Nothing})
-        | length points >= 3 = [ Points (strokePointsClosedPath thick points)]
-        | length points == 2 = toPrimitives (Line p1 p2 thick undefined Nothing)
-        | length points == 1 = [ CircleArea p1 thick ]
-        | otherwise          = [ Points []]
-        where
-            (p1:p2:ps) = points
-    toPrimitives shape
-        = map (rotateLeftAround rotatePoint angle) (toPrimitives shapePreRotate)
-        where
-            shapePreRotate = shape{rotationM=Nothing}
-            (Just rotation@(Rotation _ angle)) = rotationM shape
-            rotatePoint = findRotationPoint shapePreRotate rotation
-
-
-class ToCenter a where
-    toCenter :: a -> Point
-
-instance ToCenter BoundingBox where
-    toCenter bbox
-        = Point (minX + 0.5 * (maxX - minX), minY + 0.5 * (maxY - minY))
-        where
-            minX = xMin bbox
-            maxX = xMax bbox
-            minY = yMin bbox
-            maxY = yMax bbox
-
-instance ToCenter Shape where
-    toCenter c@(CompositeShape {positionM=(Just p), rotationM=Nothing})
-        = p |+| center
-        where
-            center = toCenter c{positionM=Nothing}
-    toCenter c@(CompositeShape {shapes=shapes, positionM=Nothing, rotationM=Nothing})
-        = averagePoint centers
-        where
-            centers = map toCenter shapes
-    toCenter r@(Rectangle {dimensions=(width, height), position=p, rotationM=Nothing})
-        = p |+| (Point (0.5 * width, 0.5 * height))
-    toCenter c@(Circle {position=p, rotationM=Nothing})
-        = p
-    toCenter po@(RegularPolygon {position=p, rotationM=Nothing})
-        = p
-    toCenter t@(Text {rotationM=Nothing})
-        = (toCenter.toBoundingBox) t
-    toCenter l@(Line {})
-        = (toCenter.toBoundingBox) l
-    toCenter ml@(MultiLine {})
-        = (toCenter.toBoundingBox) ml
-    toCenter fml@(FilledMultiLine {})
-        = (toCenter.toBoundingBox) fml
-    toCenter a@(Polygon {})
-        = (toCenter.toBoundingBox) a
-    toCenter shape
-        = rotateLeftAround rotationPoint angle center
-        where
-            (Just rotation) = rotationM shape
-            shapePreRotate = shape{rotationM=Nothing}
-            center = toCenter shapePreRotate
-            rotationPoint = findRotationPoint shapePreRotate rotation
-            (Rotation _ angle) = rotation
-
-
-class (ToPrimitives a) => ToBoundingBox a where
-    toBoundingBox :: a -> BoundingBox
-
-instance ToBoundingBox BoundingBox where
-    toBoundingBox box = box
-    
-instance ToBoundingBox Shape where
-    toBoundingBox a
-        = boundingBoxFromPrimitives $ toPrimitives a
-
-
-class (ToBoundingBox a) => Overlaps a where
-    {-
-    The boundingbox of a1 partially overlaps the boundingbox of a2. Ofcourse if overlaps(a1, a2) then
-    overlaps(a2, a1). However, if contains(a1, a2) or contains(a2, a1), then overlaps(a1, a2) == false
-    -}
-    overlaps :: (Overlaps b) => a -> b -> Bool
-    overlaps a1 a2
-        | contains a1 a2 || contains a2 a1 = False
-        | xMax b1 < xMin b2 = False -- b1 is left of b2
-        | xMin b1 > xMax b2 = False -- b2 is right of b2
-        | yMax b1 < yMin b2 = False -- b1 is lower than b2
-        | yMin b1 > yMax b2 = False -- b1 is higher than b2
-        | otherwise = True
-        where
-            b1 = toBoundingBox a1
-            b2 = toBoundingBox a2
-
-    {-
-    The boundingbox of a1 contains the boundingbox of a2. If boundingbox(a2) > boundingbox(a1)
-    then a1 can never contain a2. If boundingbox(a2) == boundingbox(a1) and contains(a1, a2)
-    then also contains(a2, a1).
-    -}
-    contains :: (Overlaps b) => a -> b -> Bool
-    contains a1 a2
-        | xMax b2 <= xMax b1 &&
-          xMin b2 >= xMin b1 &&
-          yMax b2 <= yMax b1 &&
-          yMin b2 >= yMin b1 = True
-        | otherwise = False
-        where
-            b1 = toBoundingBox a1
-            b2 = toBoundingBox a2
-
-    touches :: (Overlaps b) => a -> b -> Bool
-    touches a1 a2 = overlaps a1 a2 || contains a1 a2 || contains a2 a1
-
-
-instance Overlaps Shape
-instance Overlaps BoundingBox
-
-
-findRotationPoint :: (ToCenter a) => a -> Rotation -> Point
-findRotationPoint a (Rotation AroundCenter _) = toCenter a
-findRotationPoint _ (Rotation (AroundPoint p) _) = p
-
-class ToCanvasOut a where
-    toCanvasOut :: a -> CT.CanvasOut
-    
-instance ToCanvasOut BasicShapesOut where
-    toCanvasOut (DrawShapes canvasId shapes) = CT.CanvasOperations canvasId (canvasOperations ++ [CT.Frame])
-                where
-                    canvasOperations = (concat.(map toCanvasOperations)) shapes
-                    
-  
-class ToCanvasOperations a where
-    toCanvasOperations :: a -> [CT.CanvasOperation]  
-
-
-toCanvasText :: Shape -> CT.CanvasText
-toCanvasText (Text {text=text, fontFamily=family_, fontSize=size, alignment=align})
-    = CT.CanvasText text (CT.Font family_ $ round size) align
-
-
-instance ToCanvasOperations Shape where
-    toCanvasOperations (CompositeShape shapes Nothing Nothing)
-        = (concat.(map toCanvasOperations)) shapes
-
-    toCanvasOperations (CompositeShape shapes (Just translate) Nothing)
-        = [ CT.DoTransform CT.Save
-          , CT.DoTransform (CT.Translate screenPositionPoint)
-          ] ++ drawOperations ++
-          [ CT.DoTransform CT.Restore
-          ]
-        where
-            screenPositionPoint = roundPoint translate
-            drawOperations = toCanvasOperations (CompositeShape shapes Nothing Nothing)
-
-    toCanvasOperations text@(Text { position=p
-                                  , fillColor=fill
-                                  , strokeLineThickness=thick
-                                  , strokeColor=stroke
-                                  , rotationM=Nothing
-                                  })
-        = [CT.DrawText canvasText p' textStroke textFill]
-        where
-          canvasText = toCanvasText text
-          textFill = CT.TextFill (CT.CanvasColor screenFillColor)
-          textStroke = CT.TextStroke thick (CT.CanvasColor screenStrokeColor)
-          screenStrokeColor = roundColor stroke
-          screenFillColor = roundColor fill
-          p' = roundPoint p
-
-    toCanvasOperations (FilledMultiLine points fillWidth fillColor strokeThick strokeColor Nothing)
-        =  toCanvasOperations (MultiLine points (fillWidth + strokeThick) strokeColor Nothing)
-        ++ toCanvasOperations (MultiLine points fillWidth fillColor Nothing)
-
-    toCanvasOperations shape
-        -- Might be any rotated shape
-        | isJust (rotationM shape) = [ CT.DoTransform CT.Save
-                                     , CT.DoTransform (CT.Translate screenRotationPoint)
-                                     , CT.DoTransform (CT.Rotate screenAngle)
-                                     ]
-                                   ++ (toCanvasOperations movedShape) ++
-                                     [ CT.DoTransform CT.Restore
-                                     ]
-        -- Can only be Rectangle, Circle, RegularPolygon, Line, MultiLine or Polygon
-        | isJust screenPathPartsM  = [CT.DrawPath startingPoint screenPathParts pathStroke canvasPathFill]
-        | otherwise                = []
-        where
-            (Just rotation) = rotationM shape
-            shapePreRotate = shape{rotationM = Nothing}
-            rotationPoint = findRotationPoint shapePreRotate rotation
-            screenRotationPoint = roundPoint rotationPoint
-            (Rotation _ angle) = rotation
-            screenAngle = round angle
-            movedShape = translate (negateVector rotationPoint) shapePreRotate
-
-            canvasPathFill = toCanvasPathFill shape
-            screenPathPartsM = toScreenPathParts shape
-            Just (screenPathParts, startingPoint) = screenPathPartsM
-            screenStrokeColor = roundColor $ strokeColor shape
-            thick = strokeLineThickness shape
-            pathStroke = CT.PathStroke thick (CT.CanvasColor screenStrokeColor)
-
-          
-class ToScreenPathPart a where
-    toScreenPathParts :: a -> Maybe ([CT.ScreenPathPart], CT.ScreenStartingPoint)
-    
-instance ToScreenPathPart Shape where
-    toScreenPathParts (Rectangle {position=p, dimensions=(w, h)})
-        = Just ([CT.Rectangle p' (w', h')], p')
-        where
-            p' = roundPoint p
-            w' = round w
-            h' = round h
-    toScreenPathParts (Circle {position=p, radius=r})
-        = Just ([CT.Arc (p', r') 0 360], p')
-        where
-            p' = roundPoint p
-            r' = round r
-    toScreenPathParts (RegularPolygon {position=p, numberOfPoints=n, radius=r})
-        = Just (lines ++ [CT.ClosePath], screenPoint)
-        where
-            polygonPoints = allRegularPolygonPoints n p r
-            (screenPoint:ps) = map roundPoint polygonPoints
-            lines = [CT.LineTo screenPoint' | screenPoint' <- (ps ++ [screenPoint])]
-    toScreenPathParts (Line {point1=p1, point2=p2})
-        = Just ([CT.LineTo p2'], p1')
-        where
-            p1' = roundPoint p1
-            p2' = roundPoint p2
-                                        
-    toScreenPathParts (MultiLine {points=points})
-        | (length points) > 0 = Just (lines ++ [CT.MoveTo p1'], p1')
-        | otherwise           = Nothing
-        where
-            (p1':otherPoints') = map roundPoint points
-            lines = [CT.LineTo p' | p' <- otherPoints']
-
-    toScreenPathParts pol@(Polygon {points=points})
-        | (length points) > 0 = Just (lines ++ [CT.ClosePath], p1')
-        | otherwise           = Nothing
-        where
-            allPoints = allScreenPolygonPoints pol
-            (p1':otherPoints') = map roundPoint allPoints
-            lines = [CT.LineTo p' | p' <- otherPoints']
-
-
-toCanvasPathFill :: Shape -> CT.PathFill
-toCanvasPathFill shape
-    | hasCanvasPathFill shape = CT.PathFill (CT.CanvasColor screenFillColor)
-    | otherwise               = CT.NoPathFill
-    where
-        fillColor_ = fillColor shape
-        screenFillColor = roundColor fillColor_
-
-
-hasCanvasPathFill :: Shape -> Bool
-hasCanvasPathFill (Rectangle {})
-    = True
-hasCanvasPathFill (Circle {})
-    = True
-hasCanvasPathFill (RegularPolygon {})
-    = True
-hasCanvasPathFill (Polygon {})
-    = True
-hasCanvasPathFill _
-    = False
-
-
-allScreenPolygonPoints :: Shape -> [Point]
-allScreenPolygonPoints (Polygon {points=points})
-    | (length points) >= 2 = points ++ [firstP]
-    | otherwise            = points
-    where
-        firstP = head points
-        lastP  = last points
-
-
+module Eventloop.Module.BasicShapes.Classes where++import Control.Concurrent.MVar+import Data.Maybe++import Eventloop.Utility.Vectors+import Eventloop.Module.BasicShapes.Types+import Eventloop.Module.BasicShapes.MeasureTextHack+import qualified Eventloop.Module.Websocket.Canvas.Types as CT++{-+The center of a boundingbox is not the center of an element+    Rectangle - Intersection of two halves of adjoining sides+    Circle    - Centre point+    RegularPolygon   - Centre point+    Text      - See boundingbox to rectangle+    Line      - Halfway down the line+    MultiLine - See boundingbox+Split into points to calc boundingbox+    Rectangle - Split into 4 corners+    Circle    - Top, left, right and bottom points on the circle+    RegularPolygon   - Split into the regular polygon points+    Text      - Split into 4 corners of bbox+    Line      - Split into the two points+    MultiLine - Split into the different points with stroke+    Polygon   - Split into the different points with stroke+-}++{-+Bugs:+- BoundingBox of circle fails. Cannot use 'rotate points on circle' method.+- Difficult rotation? (Stacked composite shapes)+-}++data GeometricPrimitive = Points [Point]+                        | CircleArea Point Radius+                        deriving (Show, Eq)+++instance RotateLeftAround GeometricPrimitive where+    rotateLeftAround p angle (Points points)+        = Points $ map (rotateLeftAround p angle) points+    rotateLeftAround p angle (CircleArea p' r)+        = CircleArea (rotateLeftAround p angle p') r+++opOnBoundingBox :: (Point -> Point) -> BoundingBox -> BoundingBox+opOnBoundingBox op (BoundingBox p1 p2 p3 p4) = BoundingBox (op p1)+                                                           (op p2)+                                                           (op p3)+                                                           (op p4)+++instance ExtremaCoord BoundingBox where+    xMin (BoundingBox ll _ _ _) = x ll+    xMax (BoundingBox _ _ ur _) = x ur+    yMin (BoundingBox ll _ _ _) = y ll+    yMax (BoundingBox _ _ ur _) = y ur+++instance ExtremaCoord GeometricPrimitive where+    xMin (Points points) = xMin points+    xMin (CircleArea (Point (x, y)) r) = x - r++    xMax (Points points) = xMax points+    xMax (CircleArea (Point (x, y)) r) = x + r++    yMin (Points points) = yMin points+    yMin (CircleArea (Point (x, y)) r) = y - r++    yMax (Points points) = yMax points+    yMax (CircleArea (Point (x, y)) r) = y + r+++instance RotateLeftAround BoundingBox where+    rotateLeftAround p angle bbox = opOnBoundingBox (rotateLeftAround p angle) bbox++++allRegularPolygonPoints :: NumberOfPoints -> Point -> Radius -> [Point]+allRegularPolygonPoints n centralPoint r | n < 1 = error "A regular polygon with 0 or more sides doesn't exist!"+                                  | otherwise = [centralPoint |+| (toPoint (PolarCoord (r, angle)))  |angle <- anglesRads]+                                where+                                    anglePart = 360 / (fromIntegral n)+                                    startAngle = 0+                                    anglesDeg = filter (< 360) [startAngle, startAngle + anglePart..360]+                                    anglesRads = map degreesToRadians anglesDeg+++boundingBoxFromPrimitives :: [GeometricPrimitive] -> BoundingBox+boundingBoxFromPrimitives primitives+    = BoundingBox (Point (xMin_, yMin_)) (Point (xMin_, yMax_)) (Point (xMax_, yMax_)) (Point (xMax_, yMin_))+    where+        xMin_ = minimum $ map xMin primitives+        xMax_ = maximum $ map xMax primitives+        yMin_ = minimum $ map yMin primitives+        yMax_ = maximum $ map yMax primitives+++normalizeBBox :: BoundingBox -> BoundingBox+normalizeBBox (BoundingBox p1 p2 p3 p4)+    = boundingBoxFromPrimitives [Points [p1, p2, p3, p4]]+++roundPoint :: Point -> CT.ScreenPoint+roundPoint (Point (x, y)) = (round x, round y)+++roundColor :: Color -> CT.ScreenColor+roundColor (r, b, g, a) = (round r, round b, round g, a)++strokePointsForLine :: StrokeLineThickness -> Point -> Point -> [Point]+strokePointsForLine thick p1 p2+    = [ followVector (0.5 * thick) upPerpVector p1+      , followVector (0.5 * thick) upPerpVector p2+      , followVector (0.5 * thick) downPerpVector p1+      , followVector (0.5 * thick) downPerpVector p2+      ]++    where+        upPerpVector = upPerpendicular p1 p2+        downPerpVector = negateVector upPerpVector++strokePointsForConnection :: StrokeLineThickness -> Point -> Point -> Point -> [Point]+strokePointsForConnection strokeWidth start inspected dest+    | start == inspected && inspected == dest = [dest]+    | start == inspected                      = strokePointsForLine strokeWidth inspected dest+    | inspected == dest                       = strokePointsForLine strokeWidth start inspected+    | isJust mp1 && isJust mp2                = [fromJust mp1, fromJust mp2]+    | otherwise                               = [sup1, sdown1] -- Is possible due to rounding. Direction vectors are roughly parallel but stepping points are not equal+                                                               -- GHC will think parallel vectors are parallel while they are not. So no intersection as stepping points are slightly different+                                                               -- Just return half width up and down from inspected as this is close enough+    where+        halfWidth = strokeWidth / 2+        quart = 0.5 * pi+        v1 = inspected |-| start+        v1' = negateVector v1+        v2 = inspected |-| dest+        v2' = negateVector v2+        upv1 = turnToVector v1 quart v2+        sup1 = followVector halfWidth upv1 inspected+        upv2 = turnToVector v2 quart v1+        sup2 = followVector halfWidth upv2 inspected+        downv1 = negateVector upv1+        sdown1 = followVector halfWidth downv1 inspected+        downv2 = negateVector upv2+        sdown2 = followVector halfWidth downv2 inspected+        mp1 = intersectVector sdown1 v1 sdown2 v2+        mp2 = intersectVector sup1 v1 sup2 v2+++strokePoints :: StrokeLineThickness -> [Point] -> [Point]+strokePoints strokeWidth ps+    | l >= 3    = concat $ map (\(start, inspected, dest) -> strokePointsForConnection strokeWidth start inspected dest) connections+    | otherwise = []+    where+        l = length ps+        connections = zip3 ps (drop 1 ps) (drop 2 ps)+++strokePointsClosedPath :: StrokeLineThickness -> [Point] -> [Point]+strokePointsClosedPath strokeWidth ps+    | length ps >= 3 = strokePoints strokeWidth (ps ++ take 2 ps)+    | otherwise = []+++instance Translate Shape where+    translate p c@(CompositeShape {positionM=Nothing})+        = c {positionM = (Just p)}+    translate p c@(CompositeShape {positionM=(Just p1)})+        = c {positionM = (Just $ p1 |+| p)}+    translate p r@(Rectangle {position=trans})+        = r {position = trans |+| p}+    translate p c@(Circle {position=trans})+        = c {position = trans |+| p}+    translate p po@(RegularPolygon {position=trans})+        = po {position = trans |+| p}+    translate p t@(Text {position=trans})+        = t {position = trans |+| p}+    translate pTrans l@(Line {point1=p1, point2=p2})+        = l {point1 = (p1 |+| pTrans), point2 = (p2 |+| pTrans)}+    translate pTrans ml@(MultiLine {points=points})+        = ml {points = (map ((|+|) pTrans) points)}+    translate pTrans a@(Polygon {points=points})+        = a {points = (map ((|+|) pTrans) points)}++instance Translate GeometricPrimitive where+    translate p (Points points) = Points (map (|+| p) points)+    translate p (CircleArea p' r) = CircleArea (p |+| p') r+++class ToPrimitives a where+    toPrimitives :: a -> [GeometricPrimitive]++instance ToPrimitives BoundingBox where+    toPrimitives (BoundingBox ll ul ur lr) = [Points [ll, ul, ur, lr]]++instance ToPrimitives Shape where+    toPrimitives (CompositeShape shapes positionM Nothing)+        | isJust positionM = map (translate (fromJust positionM)) primitives+        | otherwise           = primitives+        where+            primitives = concat $ map toPrimitives shapes+    toPrimitives (Rectangle {position=(Point (x, y)), dimensions=(w, h), strokeLineThickness=thick, rotationM=Nothing})+        = [ Points [ Point (x - hthick, y - hthick)+                   , Point (x - hthick, y + h + hthick)+                   , Point (x + w + hthick, y + h + hthick)+                   , Point (x + w + hthick, y - hthick)+                   ]+          ]+        where+            hthick = 0.5 * thick+    toPrimitives (Circle {position=p, radius=r, strokeLineThickness=thick, rotationM=Nothing})+        = [CircleArea p (r + 0.5 * thick)]+    toPrimitives (RegularPolygon {numberOfPoints=a, position=p, radius=r, strokeLineThickness=thick, rotationM=Nothing})+        = toPrimitives (Polygon points undefined thick undefined Nothing)+        where+             points = allRegularPolygonPoints a p r+    toPrimitives text@(Text {position=(Point (x,y)), alignment=align, rotationM=Nothing})+        = [ Points $ case align of+            CT.AlignLeft   -> [ Point (x, y)+                              , Point (x, y + height)+                              , Point (x + width, y)+                              , Point (x + width, y + height)+                              ]+            CT.AlignCenter -> [ Point (x - hwidth, y - hheight)+                              , Point (x - hwidth, y + hheight)+                              , Point (x + hwidth, y - hheight)+                              , Point (x + hwidth, y + hheight)+                              ]+            CT.AlignRight  -> [ Point (x, y)+                              , Point (x, y + height)+                              , Point (x - width, y)+                              , Point (x - width, y + height)+                              ]+          ]+        where+            canvasText = toCanvasText text+            (width_, height_) = useMeasureText canvasText+            width = fromIntegral width_+            hwidth = width * 0.5+            height = fromIntegral height_+            hheight = height * 0.5++    toPrimitives (Line {point1=p1, point2=p2, strokeLineThickness=thick, rotationM=Nothing})+        = [Points (strokePointsForLine thick p1 p2)]+    toPrimitives (MultiLine {points=points, strokeLineThickness=thick, strokeColor=color, rotationM=Nothing})+        | len >= 3 = (Points strokePoints_) : (concat $ map toPrimitives lines)+        | len == 2 = toPrimitives (Line p1 p2 thick color Nothing)+        | otherwise = error "Multilines should atleast include 2 points!"+        where+            [p1, p2] = points+            len = length points+            strokePoints_ = strokePoints thick points+            tailPoints = drop 1 points+            linePoints = zip points tailPoints+            lines = map (\(p, p') -> Line p p' thick undefined Nothing) linePoints+    toPrimitives (FilledMultiLine {points=points, fillWidth=fillThick, strokeLineThickness=strokeThick, rotationM=Nothing})+        = (toPrimitives (MultiLine points fillThick undefined Nothing)) ++ (toPrimitives (MultiLine points (fillThick + strokeThick) undefined Nothing))+    toPrimitives pol@(Polygon {points=points, strokeLineThickness=thick, rotationM=Nothing})+        | length points >= 3 = [ Points (strokePointsClosedPath thick points)]+        | length points == 2 = toPrimitives (Line p1 p2 thick undefined Nothing)+        | length points == 1 = [ CircleArea p1 thick ]+        | otherwise          = [ Points []]+        where+            (p1:p2:ps) = points+    toPrimitives shape+        = map (rotateLeftAround rotatePoint angle) (toPrimitives shapePreRotate)+        where+            shapePreRotate = shape{rotationM=Nothing}+            (Just rotation@(Rotation _ angle)) = rotationM shape+            rotatePoint = findRotationPoint shapePreRotate rotation+++class ToCenter a where+    toCenter :: a -> Point++instance ToCenter BoundingBox where+    toCenter bbox+        = Point (minX + 0.5 * (maxX - minX), minY + 0.5 * (maxY - minY))+        where+            minX = xMin bbox+            maxX = xMax bbox+            minY = yMin bbox+            maxY = yMax bbox++instance ToCenter Shape where+    toCenter c@(CompositeShape {positionM=(Just p), rotationM=Nothing})+        = p |+| center+        where+            center = toCenter c{positionM=Nothing}+    toCenter c@(CompositeShape {shapes=shapes, positionM=Nothing, rotationM=Nothing})+        = averagePoint centers+        where+            centers = map toCenter shapes+    toCenter r@(Rectangle {dimensions=(width, height), position=p, rotationM=Nothing})+        = p |+| (Point (0.5 * width, 0.5 * height))+    toCenter c@(Circle {position=p, rotationM=Nothing})+        = p+    toCenter po@(RegularPolygon {position=p, rotationM=Nothing})+        = p+    toCenter t@(Text {rotationM=Nothing})+        = (toCenter.toBoundingBox) t+    toCenter l@(Line {})+        = (toCenter.toBoundingBox) l+    toCenter ml@(MultiLine {})+        = (toCenter.toBoundingBox) ml+    toCenter fml@(FilledMultiLine {})+        = (toCenter.toBoundingBox) fml+    toCenter a@(Polygon {})+        = (toCenter.toBoundingBox) a+    toCenter shape+        = rotateLeftAround rotationPoint angle center+        where+            (Just rotation) = rotationM shape+            shapePreRotate = shape{rotationM=Nothing}+            center = toCenter shapePreRotate+            rotationPoint = findRotationPoint shapePreRotate rotation+            (Rotation _ angle) = rotation+++class (ToPrimitives a) => ToBoundingBox a where+    toBoundingBox :: a -> BoundingBox++instance ToBoundingBox BoundingBox where+    toBoundingBox box = box++instance ToBoundingBox Shape where+    toBoundingBox a+        = boundingBoxFromPrimitives $ toPrimitives a+++class (ToBoundingBox a) => Overlaps a where+    {-+    The boundingbox of a1 partially overlaps the boundingbox of a2. Ofcourse if overlaps(a1, a2) then+    overlaps(a2, a1). However, if contains(a1, a2) or contains(a2, a1), then overlaps(a1, a2) == false+    -}+    overlaps :: (Overlaps b) => a -> b -> Bool+    overlaps a1 a2+        | contains a1 a2 || contains a2 a1 = False+        | xMax b1 < xMin b2 = False -- b1 is left of b2+        | xMin b1 > xMax b2 = False -- b2 is right of b2+        | yMax b1 < yMin b2 = False -- b1 is lower than b2+        | yMin b1 > yMax b2 = False -- b1 is higher than b2+        | otherwise = True+        where+            b1 = toBoundingBox a1+            b2 = toBoundingBox a2++    {-+    The boundingbox of a1 contains the boundingbox of a2. If boundingbox(a2) > boundingbox(a1)+    then a1 can never contain a2. If boundingbox(a2) == boundingbox(a1) and contains(a1, a2)+    then also contains(a2, a1).+    -}+    contains :: (Overlaps b) => a -> b -> Bool+    contains a1 a2+        | xMax b2 <= xMax b1 &&+          xMin b2 >= xMin b1 &&+          yMax b2 <= yMax b1 &&+          yMin b2 >= yMin b1 = True+        | otherwise = False+        where+            b1 = toBoundingBox a1+            b2 = toBoundingBox a2++    touches :: (Overlaps b) => a -> b -> Bool+    touches a1 a2 = overlaps a1 a2 || contains a1 a2 || contains a2 a1+++instance Overlaps Shape+instance Overlaps BoundingBox+++findRotationPoint :: (ToCenter a) => a -> Rotation -> Point+findRotationPoint a (Rotation AroundCenter _) = toCenter a+findRotationPoint _ (Rotation (AroundPoint p) _) = p++class ToCanvasOut a where+    toCanvasOut :: a -> CT.CanvasOut++instance ToCanvasOut BasicShapesOut where+    toCanvasOut (DrawShapes canvasId shapes) = CT.CanvasOperations canvasId (canvasOperations ++ [CT.Frame])+                where+                    canvasOperations = (concat.(map toCanvasOperations)) shapes+++class ToCanvasOperations a where+    toCanvasOperations :: a -> [CT.CanvasOperation]+++toCanvasText :: Shape -> CT.CanvasText+toCanvasText (Text {text=text, fontFamily=family_, fontSize=size, alignment=align})+    = CT.CanvasText text (CT.Font family_ $ round size) align+++instance ToCanvasOperations Shape where+    toCanvasOperations (CompositeShape shapes Nothing Nothing)+        = (concat.(map toCanvasOperations)) shapes++    toCanvasOperations (CompositeShape shapes (Just translate) Nothing)+        = [ CT.DoTransform CT.Save+          , CT.DoTransform (CT.Translate screenPositionPoint)+          ] ++ drawOperations +++          [ CT.DoTransform CT.Restore+          ]+        where+            screenPositionPoint = roundPoint translate+            drawOperations = toCanvasOperations (CompositeShape shapes Nothing Nothing)++    toCanvasOperations text@(Text { position=p+                                  , fillColor=fill+                                  , strokeLineThickness=thick+                                  , strokeColor=stroke+                                  , rotationM=Nothing+                                  })+        = [CT.DrawText canvasText p' textStroke textFill]+        where+          canvasText = toCanvasText text+          textFill = CT.TextFill (CT.CanvasColor screenFillColor)+          textStroke = CT.TextStroke thick (CT.CanvasColor screenStrokeColor)+          screenStrokeColor = roundColor stroke+          screenFillColor = roundColor fill+          p' = roundPoint p++    toCanvasOperations (FilledMultiLine points fillWidth fillColor strokeThick strokeColor Nothing)+        =  toCanvasOperations (MultiLine points (fillWidth + strokeThick) strokeColor Nothing)+        ++ toCanvasOperations (MultiLine points fillWidth fillColor Nothing)++    toCanvasOperations shape+        -- Might be any rotated shape+        | isJust (rotationM shape) = [ CT.DoTransform CT.Save+                                     , CT.DoTransform (CT.Translate screenRotationPoint)+                                     , CT.DoTransform (CT.Rotate screenAngle)+                                     ]+                                   ++ (toCanvasOperations movedShape) +++                                     [ CT.DoTransform CT.Restore+                                     ]+        -- Can only be Rectangle, Circle, RegularPolygon, Line, MultiLine or Polygon+        | isJust screenPathPartsM  = [CT.DrawPath startingPoint screenPathParts pathStroke canvasPathFill]+        | otherwise                = []+        where+            (Just rotation) = rotationM shape+            shapePreRotate = shape{rotationM = Nothing}+            rotationPoint = findRotationPoint shapePreRotate rotation+            screenRotationPoint = roundPoint rotationPoint+            (Rotation _ angle) = rotation+            screenAngle = round angle+            movedShape = translate (negateVector rotationPoint) shapePreRotate++            canvasPathFill = toCanvasPathFill shape+            screenPathPartsM = toScreenPathParts shape+            Just (screenPathParts, startingPoint) = screenPathPartsM+            screenStrokeColor = roundColor $ strokeColor shape+            thick = strokeLineThickness shape+            pathStroke = CT.PathStroke thick (CT.CanvasColor screenStrokeColor)+++class ToScreenPathPart a where+    toScreenPathParts :: a -> Maybe ([CT.ScreenPathPart], CT.ScreenStartingPoint)++instance ToScreenPathPart Shape where+    toScreenPathParts (Rectangle {position=p, dimensions=(w, h)})+        = Just ([CT.Rectangle p' (w', h')], p')+        where+            p' = roundPoint p+            w' = round w+            h' = round h+    toScreenPathParts (Circle {position=p, radius=r})+        = Just ([CT.Arc (p', r') 0 360], p')+        where+            p' = roundPoint p+            r' = round r+    toScreenPathParts (RegularPolygon {position=p, numberOfPoints=n, radius=r})+        = Just (lines ++ [CT.ClosePath], screenPoint)+        where+            polygonPoints = allRegularPolygonPoints n p r+            (screenPoint:ps) = map roundPoint polygonPoints+            lines = [CT.LineTo screenPoint' | screenPoint' <- (ps ++ [screenPoint])]+    toScreenPathParts (Line {point1=p1, point2=p2})+        = Just ([CT.LineTo p2'], p1')+        where+            p1' = roundPoint p1+            p2' = roundPoint p2++    toScreenPathParts (MultiLine {points=points})+        | (length points) > 0 = Just (lines ++ [CT.MoveTo p1'], p1')+        | otherwise           = Nothing+        where+            (p1':otherPoints') = map roundPoint points+            lines = [CT.LineTo p' | p' <- otherPoints']++    toScreenPathParts pol@(Polygon {points=points})+        | (length points) > 0 = Just (lines ++ [CT.ClosePath], p1')+        | otherwise           = Nothing+        where+            allPoints = allScreenPolygonPoints pol+            (p1':otherPoints') = map roundPoint allPoints+            lines = [CT.LineTo p' | p' <- otherPoints']+++toCanvasPathFill :: Shape -> CT.PathFill+toCanvasPathFill shape+    | hasCanvasPathFill shape = CT.PathFill (CT.CanvasColor screenFillColor)+    | otherwise               = CT.NoPathFill+    where+        fillColor_ = fillColor shape+        screenFillColor = roundColor fillColor_+++hasCanvasPathFill :: Shape -> Bool+hasCanvasPathFill (Rectangle {})+    = True+hasCanvasPathFill (Circle {})+    = True+hasCanvasPathFill (RegularPolygon {})+    = True+hasCanvasPathFill (Polygon {})+    = True+hasCanvasPathFill _+    = False+++allScreenPolygonPoints :: Shape -> [Point]+allScreenPolygonPoints (Polygon {points=points})+    | (length points) >= 2 = points ++ [firstP]+    | otherwise            = points+    where+        firstP = head points+        lastP  = last points

@@ -1,123 +1,120 @@-{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
-module Eventloop.Module.BasicShapes.Types
-    ( module Eventloop.Module.BasicShapes.Types
-    , CanvasId
-    , Alignment(..)
-    ) where
-
-import Eventloop.Module.Websocket.Canvas.Types (CanvasId, Alignment(..))
-import Eventloop.Utility.Vectors
-
-import GHC.Generics (Generic)
-import Control.DeepSeq
-
-
-type GraphicalNumeric = Float
-type Position = Point
-
-type Width = GraphicalNumeric
-type Height = GraphicalNumeric
-type Dimensions = (Width, Height)
-
-type Radius = GraphicalNumeric
-
-type Red = GraphicalNumeric
-type Green = GraphicalNumeric
-type Blue = GraphicalNumeric
-type Alpha = GraphicalNumeric
-type Color = (Red, Green, Blue, Alpha)
-type FillColor = Color
-type StrokeColor = Color
-
-type FillThickness = GraphicalNumeric
-type StrokeLineThickness = GraphicalNumeric
-
-type UpperLeft = Point
-type UpperRight = Point
-type LowerLeft = Point
-type LowerRight = Point
-
-type NumberOfPoints = Int
-
-type FontFamily = [Char]
-type FontSize = GraphicalNumeric
-
-
-data BasicShapesOut = DrawShapes CanvasId [Shape]
-                    deriving (Show, Eq, Generic, NFData)
-
-data Shape = CompositeShape { shapes :: [Shape]
-                            , positionM :: Maybe Position
-                            , rotationM :: Maybe Rotation
-                            } -- ^Should contain atleast 1 shape. Rotation before Position
-           | Rectangle { position :: Position
-                       , dimensions :: Dimensions
-                       , fillColor :: FillColor
-                       , strokeLineThickness :: StrokeLineThickness
-                       , strokeColor :: StrokeColor
-                       , rotationM :: Maybe Rotation
-                       } -- ^| Position is upperleftcorner. Position is the corner closes to origin. Visually in canvas, this is top left. In a Cartesian coördinate system, this is bottom left.
-           | Circle { position :: Position
-                    , radius :: Radius
-                    , fillColor :: FillColor
-                    , strokeLineThickness :: StrokeLineThickness
-                    , strokeColor :: StrokeColor
-                    , rotationM :: Maybe Rotation
-                    } -- ^| Position is center
-           | RegularPolygon { position :: Position
-                     , numberOfPoints :: NumberOfPoints
-                     , radius :: Radius
-                     , fillColor :: FillColor
-                     , strokeLineThickness :: StrokeLineThickness
-                     , strokeColor :: StrokeColor
-                     , rotationM :: Maybe Rotation
-                     } -- ^The first point of the regular polygon, always starts in the direction from the x-axis.(Towards x-infinity). Position is the the centre of the regular polygon
-           | Text { text :: [Char]
-                  , fontFamily :: FontFamily
-                  , fontSize :: FontSize
-                  , position :: Position
-                  , alignment :: Alignment
-                  , fillColor :: FillColor
-                  , strokeLineThickness :: StrokeLineThickness
-                  , strokeColor :: StrokeColor
-                  , rotationM :: Maybe Rotation
-                  }
-           | Line { point1 :: Point
-                  , point2 :: Point
-                  , strokeLineThickness :: StrokeLineThickness
-                  , strokeColor :: StrokeColor
-                  , rotationM :: Maybe Rotation
-                  }
-           | MultiLine { points :: [Point] -- ^| Can contain any number of points
-                       , strokeLineThickness :: StrokeLineThickness
-                       , strokeColor :: StrokeColor
-                       , rotationM :: Maybe Rotation
-                       }
-           | FilledMultiLine { points :: [Point]
-                             , fillWidth :: FillThickness
-                             , fillColor :: FillColor
-                             , strokeLineThickness :: StrokeLineThickness
-                             , strokeColor :: StrokeColor
-                             , rotationM :: Maybe Rotation
-                             }
-           | Polygon { points :: [Point] -- ^| Closes shape automatically with fill. Do not forget that the fill encloses the entire path. This means that half of the stroke is overwritten by the fill.
-                     , fillColor :: FillColor
-                     , strokeLineThickness :: StrokeLineThickness
-                     , strokeColor :: StrokeColor
-                     , rotationM :: Maybe Rotation
-                     }
-           deriving (Show, Eq, Generic, NFData)
-           
-           
-data Rotation = Rotation RotatePoint Angle -- ^| Rotation is around a point on the canvas. May be the centre of the boundingbox (enclosing rectangle) or an arbitrary point. Angle is in degrees and counter-clockwise in the coördinate system(from the x-axis to the y-axis) and visually on canvas clock-wise.
-            deriving (Show, Eq, Generic, NFData)
-
-data RotatePoint = AroundCenter
-                 | AroundPoint Point
-                deriving (Show, Eq, Generic, NFData)
-              
-data BoundingBox = BoundingBox LowerLeft UpperLeft UpperRight LowerRight -- ^| The point indications are from the perspective of a regular Cartesian coördinate system.
-                deriving (Show, Eq)
-                         
-
-               
+{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}+module Eventloop.Module.BasicShapes.Types+    ( module Eventloop.Module.BasicShapes.Types+    , CanvasId+    , Alignment(..)+    ) where++import Eventloop.Module.Websocket.Canvas.Types (CanvasId, Alignment(..))+import Eventloop.Utility.Vectors++import GHC.Generics (Generic)+import Control.DeepSeq+++type GraphicalNumeric = Float+type Position = Point++type Width = GraphicalNumeric+type Height = GraphicalNumeric+type Dimensions = (Width, Height)++type Radius = GraphicalNumeric++type Red = GraphicalNumeric+type Green = GraphicalNumeric+type Blue = GraphicalNumeric+type Alpha = GraphicalNumeric+type Color = (Red, Green, Blue, Alpha)+type FillColor = Color+type StrokeColor = Color++type FillThickness = GraphicalNumeric+type StrokeLineThickness = GraphicalNumeric++type UpperLeft = Point+type UpperRight = Point+type LowerLeft = Point+type LowerRight = Point++type NumberOfPoints = Int++type FontFamily = [Char]+type FontSize = GraphicalNumeric+++data BasicShapesOut = DrawShapes CanvasId [Shape]+                    deriving (Show, Eq, Generic, NFData)++data Shape = CompositeShape { shapes :: [Shape]+                            , positionM :: Maybe Position+                            , rotationM :: Maybe Rotation+                            } -- ^Should contain atleast 1 shape. Rotation before Position+           | Rectangle { position :: Position+                       , dimensions :: Dimensions+                       , fillColor :: FillColor+                       , strokeLineThickness :: StrokeLineThickness+                       , strokeColor :: StrokeColor+                       , rotationM :: Maybe Rotation+                       } -- ^| Position is upperleftcorner. Position is the corner closes to origin. Visually in canvas, this is top left. In a Cartesian coördinate system, this is bottom left.+           | Circle { position :: Position+                    , radius :: Radius+                    , fillColor :: FillColor+                    , strokeLineThickness :: StrokeLineThickness+                    , strokeColor :: StrokeColor+                    , rotationM :: Maybe Rotation+                    } -- ^| Position is center+           | RegularPolygon { position :: Position+                     , numberOfPoints :: NumberOfPoints+                     , radius :: Radius+                     , fillColor :: FillColor+                     , strokeLineThickness :: StrokeLineThickness+                     , strokeColor :: StrokeColor+                     , rotationM :: Maybe Rotation+                     } -- ^The first point of the regular polygon, always starts in the direction from the x-axis.(Towards x-infinity). Position is the the centre of the regular polygon+           | Text { text :: [Char]+                  , fontFamily :: FontFamily+                  , fontSize :: FontSize+                  , position :: Position+                  , alignment :: Alignment+                  , fillColor :: FillColor+                  , strokeLineThickness :: StrokeLineThickness+                  , strokeColor :: StrokeColor+                  , rotationM :: Maybe Rotation+                  }+           | Line { point1 :: Point+                  , point2 :: Point+                  , strokeLineThickness :: StrokeLineThickness+                  , strokeColor :: StrokeColor+                  , rotationM :: Maybe Rotation+                  }+           | MultiLine { points :: [Point] -- ^| Can contain any number of points+                       , strokeLineThickness :: StrokeLineThickness+                       , strokeColor :: StrokeColor+                       , rotationM :: Maybe Rotation+                       }+           | FilledMultiLine { points :: [Point]+                             , fillWidth :: FillThickness+                             , fillColor :: FillColor+                             , strokeLineThickness :: StrokeLineThickness+                             , strokeColor :: StrokeColor+                             , rotationM :: Maybe Rotation+                             }+           | Polygon { points :: [Point] -- ^| Closes shape automatically with fill. Do not forget that the fill encloses the entire path. This means that half of the stroke is overwritten by the fill.+                     , fillColor :: FillColor+                     , strokeLineThickness :: StrokeLineThickness+                     , strokeColor :: StrokeColor+                     , rotationM :: Maybe Rotation+                     }+           deriving (Show, Eq, Generic, NFData)+++data Rotation = Rotation RotatePoint Angle -- ^| Rotation is around a point on the canvas. May be the centre of the boundingbox (enclosing rectangle) or an arbitrary point. Angle is in degrees and counter-clockwise in the coördinate system(from the x-axis to the y-axis) and visually on canvas clock-wise.+            deriving (Show, Eq, Generic, NFData)++data RotatePoint = AroundCenter+                 | AroundPoint Point+                deriving (Show, Eq, Generic, NFData)++data BoundingBox = BoundingBox LowerLeft UpperLeft UpperRight LowerRight -- ^| The point indications are from the perspective of a regular Cartesian coördinate system.+                deriving (Show, Eq)

@@ -1,9 +1,9 @@-module Eventloop.Module.DrawTrees
-    ( module Eventloop.Module.DrawTrees.Types
-    , module Eventloop.Module.DrawTrees.DrawTrees
-    , module Eventloop.Module.DrawTrees.RoseTreeGeneric
-    ) where
-    
-import Eventloop.Module.DrawTrees.Types
-import Eventloop.Module.DrawTrees.DrawTrees
+module Eventloop.Module.DrawTrees+    ( module Eventloop.Module.DrawTrees.Types+    , module Eventloop.Module.DrawTrees.DrawTrees+    , module Eventloop.Module.DrawTrees.RoseTreeGeneric+    ) where++import Eventloop.Module.DrawTrees.Types+import Eventloop.Module.DrawTrees.DrawTrees import Eventloop.Module.DrawTrees.RoseTreeGeneric

@@ -1,145 +1,145 @@-module Eventloop.Module.DrawTrees.DrawTrees
-    ( setupDrawTreesModuleConfiguration
-    , drawTreesModuleIdentifier
-    , drawTreesPostProcessor
-    , showGeneralTreeList
-    , rbExampleTree
-    , roseExampleTree
-    ) where
-
-import Eventloop.Module.DrawTrees.Types
-import Eventloop.Utility.Trees.LayoutTree
-import Eventloop.Utility.Trees.GeneralTree
-import Eventloop.Module.BasicShapes.Types
-import Eventloop.Types.Common
-import Eventloop.Types.Events
-import Eventloop.Types.System
-
-
-setupDrawTreesModuleConfiguration :: EventloopSetupModuleConfiguration
-setupDrawTreesModuleConfiguration = ( EventloopSetupModuleConfiguration 
-                                         drawTreesModuleIdentifier
-                                         Nothing
-                                         Nothing
-                                         Nothing
-                                         (Just drawTreesPostProcessor)
-                                         Nothing
-                                         Nothing
-                                      )
-
-drawTreesModuleIdentifier :: EventloopModuleIdentifier
-drawTreesModuleIdentifier = "parseTree"
-
-
-drawTreesPostProcessor :: PostProcessor
-drawTreesPostProcessor sharedConst sharedIOT ioConst ioStateT (OutDrawTrees (DrawTrees canvasId trees))
-    = return [OutBasicShapes $ DrawShapes canvasId [shapeTrees]]
-    where
-        (shapeTrees, _, _) = showGeneralTreeList trees
-        
-drawTreesPostProcessor sharedConst sharedIOT ioConst ioStateT out
-    = return [out]
-
-
-maxWidth :: Int
-maxWidth = 1024
-
-showGeneralTreeList :: [GeneralTree] -> (Shape, RightOffset, BottomOffset)
-showGeneralTreeList list = showGeneralTreeList' 0 0 0 0 list
-
-showGeneralTreeList' :: LeftOffset -> TopOffset -> Float -> Int -> [GeneralTree] -> (Shape, RightOffset, BottomOffset)
-showGeneralTreeList' _ _ _ _ [] = (CompositeShape [] Nothing Nothing, 0, 0)
-showGeneralTreeList' left top maxBottom i (x:xs) | right <= 1024 || width > 1024 = (CompositeShape (treeShapes ++ gtrees) Nothing Nothing, rightOff', botOff')
-                                                 | otherwise = showGeneralTreeList' 0 maxBottom' maxBottom' i (x:xs)
-                                               where
-                                                   maxBottom' = max maxBottom bottom
-                                                   (CompositeShape treeShapes _ _, right, bottom) = showGeneralTree left top i x
-                                                   (CompositeShape gtrees _ _, rightOff, botOff) = showGeneralTreeList' (right + marginBetweenTrees) top maxBottom' i' xs
-                                                   i' = i + 1
-                                                   width = right - left
-                                                   rightOff' = max rightOff right
-                                                   botOff'   = max bottom botOff
-
-       
-showGeneralTree :: LeftOffset -> TopOffset -> Int -> GeneralTree -> (Shape, RightOffset, BottomOffset)
-showGeneralTree left top i tree =  (CompositeShape [treeIndexShape, treeShape] Nothing Nothing, right, bottom)
-                                where
-                                    (ltree, right, bottom) = layoutGeneralTree left' top tree
-                                    treeShape = printTree ltree
-                                    (treeIndexShape, left') = treeIndex i (left, top)
-
-instance GeneralizeTree RBTree where
-    generalizeTree (RBNode col _ []) = GeneralTreeBox content []
-                                    where
-                                        content = [GeneralNode (nodeColorToFillColor col) 5]
-                                                
-    generalizeTree (RBNode col str children) = GeneralTreeBox content children'WithLines
-                                            where
-                                                content = [GeneralNode (nodeColorToFillColor col) 20, GeneralNodeText (0,0,0, 255) str]
-                                                children' = map generalizeTree children
-                                                line = GeneralLine (0,0,0, 255)
-                                                children'WithLines = zip (repeat line) children'
-
-nodeColorToFillColor :: NodeColor -> FillColor
-nodeColorToFillColor NodeRed   = (255, 0, 0, 255)
-nodeColorToFillColor NodeBlack = (0, 0, 0, 255)
-nodeColorToFillColor NodeGrey  = (125, 125, 125, 255)
-                  
-                 
-instance GeneralizeTree RoseTree where
-    generalizeTree (RoseNode str children) = GeneralTreeBox content children'WithLines
-                                            where
-                                                content = [GeneralNodeText (0,0,0, 255) str]
-                                                children'WithLines = zip (repeat line) (map generalizeTree children)
-                                                line = GeneralLine (0,0,0, 255)   
-                        
-rbExampleTree = RBNode NodeBlack "12"
-                        [ RBNode NodeRed "10"
-                                    [ RBNode NodeBlack "9"
-                                                [ RBNode NodeBlack "" [],
-                                                  RBNode NodeBlack "" []
-                                                ],
-                                      RBNode NodeBlack "11"
-                                                [RBNode NodeBlack "" [],
-                                                 RBNode NodeBlack "" []
-                                                ]
-                                    ],
-                          RBNode NodeRed "13"
-                                    [RBNode NodeBlack "36" [],
-                                     RBNode NodeBlack "42"
-                                               [RBNode NodeRed "36"
-                                                          [RBNode NodeBlack "" [],
-                                                           RBNode NodeBlack "" []
-                                                          ],
-                                                RBNode NodeBlack "" []
-                                               ]
-                                    ]
-                        ]
-                        
-roseExampleTree = RoseNode "z"
-                        [ RoseNode "aaa"
-                                    [ RoseNode "bbb"
-                                                [ RoseNode "ccc" [],
-                                                  RoseNode "ddd" []
-                                                ],
-                                      RoseNode ""
-                                                [RoseNode "fff" [],
-                                                 RoseNode "ggg" [],
-                                                 RoseNode "hhh" []
-                                                ],
-                                      RoseNode "iii"
-                                                [RoseNode "" []
-                                                ]
-                                    ],
-                          RoseNode "kkk"
-                                    [RoseNode "lll" [],
-                                     RoseNode "mmm"
-                                               [RoseNode "nnn"
-                                                          [RoseNode "q" [],
-                                                           RoseNode "r" []
-                                                          ],
-                                                RoseNode "ooo" [],
-                                                RoseNode "ppp" []
-                                               ]
-                                    ]
+module Eventloop.Module.DrawTrees.DrawTrees+    ( setupDrawTreesModuleConfiguration+    , drawTreesModuleIdentifier+    , drawTreesPostProcessor+    , showGeneralTreeList+    , rbExampleTree+    , roseExampleTree+    ) where++import Eventloop.Module.DrawTrees.Types+import Eventloop.Utility.Trees.LayoutTree+import Eventloop.Utility.Trees.GeneralTree+import Eventloop.Module.BasicShapes.Types+import Eventloop.Types.Common+import Eventloop.Types.Events+import Eventloop.Types.System+++setupDrawTreesModuleConfiguration :: EventloopSetupModuleConfiguration+setupDrawTreesModuleConfiguration = ( EventloopSetupModuleConfiguration+                                         drawTreesModuleIdentifier+                                         Nothing+                                         Nothing+                                         Nothing+                                         (Just drawTreesPostProcessor)+                                         Nothing+                                         Nothing+                                      )++drawTreesModuleIdentifier :: EventloopModuleIdentifier+drawTreesModuleIdentifier = "parseTree"+++drawTreesPostProcessor :: PostProcessor+drawTreesPostProcessor sharedConst sharedIOT ioConst ioStateT (OutDrawTrees (DrawTrees canvasId trees))+    = return [OutBasicShapes $ DrawShapes canvasId [shapeTrees]]+    where+        (shapeTrees, _, _) = showGeneralTreeList trees++drawTreesPostProcessor sharedConst sharedIOT ioConst ioStateT out+    = return [out]+++maxWidth :: Int+maxWidth = 1024++showGeneralTreeList :: [GeneralTree] -> (Shape, RightOffset, BottomOffset)+showGeneralTreeList list = showGeneralTreeList' 0 0 0 0 list++showGeneralTreeList' :: LeftOffset -> TopOffset -> Float -> Int -> [GeneralTree] -> (Shape, RightOffset, BottomOffset)+showGeneralTreeList' _ _ _ _ [] = (CompositeShape [] Nothing Nothing, 0, 0)+showGeneralTreeList' left top maxBottom i (x:xs) | right <= 1024 || width > 1024 = (CompositeShape (treeShapes ++ gtrees) Nothing Nothing, rightOff', botOff')+                                                 | otherwise = showGeneralTreeList' 0 maxBottom' maxBottom' i (x:xs)+                                               where+                                                   maxBottom' = max maxBottom bottom+                                                   (CompositeShape treeShapes _ _, right, bottom) = showGeneralTree left top i x+                                                   (CompositeShape gtrees _ _, rightOff, botOff) = showGeneralTreeList' (right + marginBetweenTrees) top maxBottom' i' xs+                                                   i' = i + 1+                                                   width = right - left+                                                   rightOff' = max rightOff right+                                                   botOff'   = max bottom botOff+++showGeneralTree :: LeftOffset -> TopOffset -> Int -> GeneralTree -> (Shape, RightOffset, BottomOffset)+showGeneralTree left top i tree =  (CompositeShape [treeIndexShape, treeShape] Nothing Nothing, right, bottom)+                                where+                                    (ltree, right, bottom) = layoutGeneralTree left' top tree+                                    treeShape = printTree ltree+                                    (treeIndexShape, left') = treeIndex i (left, top)++instance GeneralizeTree RBTree where+    generalizeTree (RBNode col _ []) = GeneralTreeBox content []+                                    where+                                        content = [GeneralNode (nodeColorToFillColor col) 5]++    generalizeTree (RBNode col str children) = GeneralTreeBox content children'WithLines+                                            where+                                                content = [GeneralNode (nodeColorToFillColor col) 20, GeneralNodeText (0,0,0, 255) str]+                                                children' = map generalizeTree children+                                                line = GeneralLine (0,0,0, 255)+                                                children'WithLines = zip (repeat line) children'++nodeColorToFillColor :: NodeColor -> FillColor+nodeColorToFillColor NodeRed   = (255, 0, 0, 255)+nodeColorToFillColor NodeBlack = (0, 0, 0, 255)+nodeColorToFillColor NodeGrey  = (125, 125, 125, 255)+++instance GeneralizeTree RoseTree where+    generalizeTree (RoseNode str children) = GeneralTreeBox content children'WithLines+                                            where+                                                content = [GeneralNodeText (0,0,0, 255) str]+                                                children'WithLines = zip (repeat line) (map generalizeTree children)+                                                line = GeneralLine (0,0,0, 255)++rbExampleTree = RBNode NodeBlack "12"+                        [ RBNode NodeRed "10"+                                    [ RBNode NodeBlack "9"+                                                [ RBNode NodeBlack "" [],+                                                  RBNode NodeBlack "" []+                                                ],+                                      RBNode NodeBlack "11"+                                                [RBNode NodeBlack "" [],+                                                 RBNode NodeBlack "" []+                                                ]+                                    ],+                          RBNode NodeRed "13"+                                    [RBNode NodeBlack "36" [],+                                     RBNode NodeBlack "42"+                                               [RBNode NodeRed "36"+                                                          [RBNode NodeBlack "" [],+                                                           RBNode NodeBlack "" []+                                                          ],+                                                RBNode NodeBlack "" []+                                               ]+                                    ]+                        ]++roseExampleTree = RoseNode "z"+                        [ RoseNode "aaa"+                                    [ RoseNode "bbb"+                                                [ RoseNode "ccc" [],+                                                  RoseNode "ddd" []+                                                ],+                                      RoseNode ""+                                                [RoseNode "fff" [],+                                                 RoseNode "ggg" [],+                                                 RoseNode "hhh" []+                                                ],+                                      RoseNode "iii"+                                                [RoseNode "" []+                                                ]+                                    ],+                          RoseNode "kkk"+                                    [RoseNode "lll" [],+                                     RoseNode "mmm"+                                               [RoseNode "nnn"+                                                          [RoseNode "q" [],+                                                           RoseNode "r" []+                                                          ],+                                                RoseNode "ooo" [],+                                                RoseNode "ppp" []+                                               ]+                                    ]                         ]

@@ -1,92 +1,92 @@-{-# LANGUAGE TypeOperators, DefaultSignatures, FlexibleContexts, DeriveGeneric,
-             DeriveAnyClass, TypeSynonymInstances, FlexibleInstances,
-             ScopedTypeVariables, StandaloneDeriving #-}
-module Eventloop.Module.DrawTrees.RoseTreeGeneric
-    ( ToRoseTree (..)
-    , genericToRoseTree
-    ) where
-
-import GHC.Generics
-import Eventloop.Module.DrawTrees.Types
-
-emptyNode = RoseNode "" []
-
-cleanTree = concatMap mergeProduct
-          . filter (/= emptyNode)
-
-mergeProduct (RoseNode "" xs) = xs
-mergeProduct r                = [r]
-
--- | Convert to a 'RoseTree'
-class ToRoseTree a where
-  -- | Convert to a 'RoseTree'
-  toRoseTree :: a -> RoseTree
-  default toRoseTree :: (Generic a, GToRoseTree (Rep a)) => a -> RoseTree
-  toRoseTree = genericToRoseTree
-
--- | A version of 'toRoseTree' that works for any data type that has an
--- instance for 'Generic'
-genericToRoseTree :: (Generic a, GToRoseTree (Rep a)) => a -> RoseTree
-genericToRoseTree = gtoRoseTree . from
-
-class GToRoseTree f where
-  gtoRoseTree :: f a -> RoseTree
-
--- constants
-instance ToRoseTree c => GToRoseTree (K1 i c) where
-  gtoRoseTree = toRoseTree . unK1
-
--- meta
-instance {-# OVERLAPPABLE #-} GToRoseTree f => GToRoseTree (M1 i c f) where
-  gtoRoseTree = gtoRoseTree . unM1
-
--- constructors
-instance (Constructor c, GToRoseTree f) => GToRoseTree (C1 c f) where
-  gtoRoseTree = RoseNode (conName (undefined :: t c f p))
-              . cleanTree
-              . (:[])
-              . gtoRoseTree
-              . unM1
-
--- unit
-instance GToRoseTree U1 where
-  gtoRoseTree U1 = emptyNode
-
--- void
-instance GToRoseTree V1 where
-  gtoRoseTree _ = emptyNode
-
--- product
-instance (GToRoseTree f, GToRoseTree g) => GToRoseTree (f :*: g) where
-  gtoRoseTree (f1 :*: g1) = RoseNode "" (cleanTree [gtoRoseTree f1, gtoRoseTree g1])
-
--- sum
-instance (GToRoseTree f, GToRoseTree g) => GToRoseTree (f :+: g) where
-  gtoRoseTree (L1 f1) = gtoRoseTree f1
-  gtoRoseTree (R1 g1) = gtoRoseTree g1
-
-instance ToRoseTree Int where
-  toRoseTree i = RoseNode (show i) []
-
-instance ToRoseTree Integer where
-  toRoseTree i = RoseNode (show i) []
-
-instance ToRoseTree Float where
-  toRoseTree f = RoseNode (show f) []
-
-instance ToRoseTree Double where
-  toRoseTree d = RoseNode (show d) []
-
-instance ToRoseTree Char where
-  toRoseTree c = RoseNode [c] []
-
-deriving instance ToRoseTree Bool
-deriving instance ToRoseTree Ordering
-deriving instance (ToRoseTree l, ToRoseTree r) => ToRoseTree (Either l r)
-deriving instance ToRoseTree a => ToRoseTree (Maybe a)
-
-instance {-# OVERLAPPABLE #-} ToRoseTree a => ToRoseTree [a] where
-  toRoseTree = RoseNode "" . cleanTree . map toRoseTree
-
-instance ToRoseTree String where
-  toRoseTree s = RoseNode s []
+{-# LANGUAGE TypeOperators, DefaultSignatures, FlexibleContexts, DeriveGeneric,+             DeriveAnyClass, TypeSynonymInstances, FlexibleInstances,+             ScopedTypeVariables, StandaloneDeriving #-}+module Eventloop.Module.DrawTrees.RoseTreeGeneric+    ( ToRoseTree (..)+    , genericToRoseTree+    ) where++import GHC.Generics+import Eventloop.Module.DrawTrees.Types++emptyNode = RoseNode "" []++cleanTree = concatMap mergeProduct+          . filter (/= emptyNode)++mergeProduct (RoseNode "" xs) = xs+mergeProduct r                = [r]++-- | Convert to a 'RoseTree'+class ToRoseTree a where+  -- | Convert to a 'RoseTree'+  toRoseTree :: a -> RoseTree+  default toRoseTree :: (Generic a, GToRoseTree (Rep a)) => a -> RoseTree+  toRoseTree = genericToRoseTree++-- | A version of 'toRoseTree' that works for any data type that has an+-- instance for 'Generic'+genericToRoseTree :: (Generic a, GToRoseTree (Rep a)) => a -> RoseTree+genericToRoseTree = gtoRoseTree . from++class GToRoseTree f where+  gtoRoseTree :: f a -> RoseTree++-- constants+instance ToRoseTree c => GToRoseTree (K1 i c) where+  gtoRoseTree = toRoseTree . unK1++-- meta+instance {-# OVERLAPPABLE #-} GToRoseTree f => GToRoseTree (M1 i c f) where+  gtoRoseTree = gtoRoseTree . unM1++-- constructors+instance (Constructor c, GToRoseTree f) => GToRoseTree (C1 c f) where+  gtoRoseTree = RoseNode (conName (undefined :: t c f p))+              . cleanTree+              . (:[])+              . gtoRoseTree+              . unM1++-- unit+instance GToRoseTree U1 where+  gtoRoseTree U1 = emptyNode++-- void+instance GToRoseTree V1 where+  gtoRoseTree _ = emptyNode++-- product+instance (GToRoseTree f, GToRoseTree g) => GToRoseTree (f :*: g) where+  gtoRoseTree (f1 :*: g1) = RoseNode "" (cleanTree [gtoRoseTree f1, gtoRoseTree g1])++-- sum+instance (GToRoseTree f, GToRoseTree g) => GToRoseTree (f :+: g) where+  gtoRoseTree (L1 f1) = gtoRoseTree f1+  gtoRoseTree (R1 g1) = gtoRoseTree g1++instance ToRoseTree Int where+  toRoseTree i = RoseNode (show i) []++instance ToRoseTree Integer where+  toRoseTree i = RoseNode (show i) []++instance ToRoseTree Float where+  toRoseTree f = RoseNode (show f) []++instance ToRoseTree Double where+  toRoseTree d = RoseNode (show d) []++instance ToRoseTree Char where+  toRoseTree c = RoseNode [c] []++deriving instance ToRoseTree Bool+deriving instance ToRoseTree Ordering+deriving instance (ToRoseTree l, ToRoseTree r) => ToRoseTree (Either l r)+deriving instance ToRoseTree a => ToRoseTree (Maybe a)++instance {-# OVERLAPPABLE #-} ToRoseTree a => ToRoseTree [a] where+  toRoseTree = RoseNode "" . cleanTree . map toRoseTree++instance ToRoseTree String where+  toRoseTree s = RoseNode s []

@@ -1,30 +1,25 @@-{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
-module Eventloop.Module.DrawTrees.Types where
-
-import Eventloop.Module.Websocket.Canvas.Types
-import Eventloop.Utility.Trees.GeneralTree
-
-import GHC.Generics (Generic)
-import Control.DeepSeq
-
-
-data DrawTreesOut = DrawTrees CanvasId [GeneralTree]
-                  deriving (Show, Eq, Generic, NFData)
-             
-          
-data NodeColor = NodeRed
-               | NodeBlack
-               | NodeGrey
-               deriving (Show, Eq, Generic, NFData)
-
-data RBTree = RBNode NodeColor String [RBTree]
-            deriving (Show, Eq)
-            
-            
-data RoseTree = RoseNode String [RoseTree]
-                deriving (Show, Eq)
-
-
-
-                
-
+{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}+module Eventloop.Module.DrawTrees.Types where++import Eventloop.Module.Websocket.Canvas.Types+import Eventloop.Utility.Trees.GeneralTree++import GHC.Generics (Generic)+import Control.DeepSeq+++data DrawTreesOut = DrawTrees CanvasId [GeneralTree]+                  deriving (Show, Eq, Generic, NFData)+++data NodeColor = NodeRed+               | NodeBlack+               | NodeGrey+               deriving (Show, Eq, Generic, NFData)++data RBTree = RBNode NodeColor String [RBTree]+            deriving (Show, Eq)+++data RoseTree = RoseNode String [RoseTree]+                deriving (Show, Eq)

@@ -1,7 +1,7 @@-module Eventloop.Module.File
-    ( module Eventloop.Module.File.File
-    , module Eventloop.Module.File.Types
-    ) where
-    
-import Eventloop.Module.File.File
+module Eventloop.Module.File+    ( module Eventloop.Module.File.File+    , module Eventloop.Module.File.Types+    ) where++import Eventloop.Module.File.File import Eventloop.Module.File.Types

@@ -1,185 +1,185 @@-module Eventloop.Module.File.File
-    ( setupFileModuleConfiguration
-    , fileModuleIdentifier
-    , fileEventRetriever
-    , fileEventSender
-    , fileTeardown
-    ) where
-
-import Data.Maybe
-import Control.Concurrent.Datastructures.BlockingConcurrentQueue
-import Control.Concurrent.STM
-import System.IO
-
-import Eventloop.Module.File.Types
-import Eventloop.Types.Common
-import Eventloop.Types.Events
-import Eventloop.Types.System
-
-
-setupFileModuleConfiguration :: EventloopSetupModuleConfiguration
-setupFileModuleConfiguration = ( EventloopSetupModuleConfiguration 
-                                    fileModuleIdentifier
-                                    (Just fileInitializer)
-                                    (Just fileEventRetriever)
-                                    Nothing
-                                    Nothing
-                                    (Just fileEventSender)
-                                    (Just fileTeardown)
-                                 )
-
-fileModuleIdentifier :: EventloopModuleIdentifier
-fileModuleIdentifier = "file"
-
-
-fileInitializer :: Initializer
-fileInitializer sharedConst sharedIO
-    = do
-        inQueue <- createBlockingConcurrentQueue
-        return (sharedConst, sharedIO, FileConstants inQueue, FileState [])
-
-    
-fileEventRetriever :: EventRetriever
-fileEventRetriever sharedConst sharedIOT ioConst ioStateT
-    = do
-        fileInEvents <- takeAllFromBlockingConcurrentQueue queue
-        return (map InFile fileInEvents)
-    where
-        queue = fileInQueue ioConst
-
-
-fileEventSender :: EventSender
-fileEventSender _ _ _ _ Stop = return ()
-fileEventSender sharedConst sharedIOT ioConst ioStateT (OutFile out)
-    = do
-        (FileState openFiles) <- readTVarIO ioStateT
-        (openFiles', inEvents) <- fileEventSender' openFiles out
-        atomically $ writeTVar ioStateT (FileState openFiles')
-        putAllInBlockingConcurrentQueue inQueue inEvents
-    where
-        inQueue = fileInQueue ioConst
-
-    
-fileEventSender' :: [OpenFile] -> FileOut -> IO ([OpenFile], [FileIn])
-fileEventSender' openFiles (OpenFile filepath iomode)
-    = do
-        handle <- openFile filepath iomode
-        let
-            fileOpenedEvent = FileOpened filepath True
-            openFiles' = openFiles ++ [(filepath, handle, iomode)]
-        return (openFiles', [fileOpenedEvent])
-                                                                                         
-fileEventSender' openFiles (CloseFile filepath)
-    | openFileM == Nothing = return ([], [])
-    | otherwise = do
-                   hClose handle
-                   return (openFiles', [closedFileEvent])
-    where
-        openFileM = retrieveOpenedFile openFiles filepath
-        (fp, handle, iomode) = fromJust openFileM
-        openFiles' = removeOpenedFile openFiles filepath
-        closedFileEvent = FileClosed filepath True
-                                                        
-fileEventSender' openFiles (RetrieveContents filepath)
-    = doReadAction filepath openFiles RetrievedContents retrieveContents
-
-fileEventSender' openFiles (RetrieveLine filepath)
-     = doReadAction filepath openFiles RetrievedLine hGetLine
-
-fileEventSender' openFiles (RetrieveChar filepath)
-    = doReadAction filepath openFiles RetrievedChar hGetChar
-
-fileEventSender' openFiles (IfEOF filepath)
-    = getFromFile filepath openFiles fileIsOpened IsEOF hIsEOF
-                                                                     
-fileEventSender' openFiles (WriteTo filepath contents)
-    | fileIsWriteable openFiles filepath = do
-        hPutStr handle contents
-        return (openFiles, [WroteTo filepath True])
-    | otherwise = return (openFiles, [])
-    where
-        Just (fp, handle, iomode) = retrieveOpenedFile openFiles filepath
-
-                                                                                
-doReadAction :: FilePath
-             -> [OpenFile]
-             -> (FilePath -> a -> FileIn)
-             -> (Handle -> IO a)
-             -> IO ([OpenFile], [FileIn])
-doReadAction filepath openFiles inEvent readAction
-    = getFromFile filepath openFiles fileIsReadable inEvent readAction
-                         
-                         
-getFromFile :: FilePath -> 
-               [OpenFile] ->
-               ([OpenFile] -> FilePath -> Bool) -> {- Check if the action should be done -}
-               (FilePath -> a -> FileIn) -> {- The inEvent Constructor -}
-               (Handle -> IO a) ->  {- The action which will grant a result -}
-               IO ([OpenFile], [FileIn])
-getFromFile filepath openFiles fileCheck inEvent action
-    | fileCheck openFiles filepath = do
-        result <- action handle
-        return (openFiles, [inEvent filepath result])
-    | otherwise                 = return (openFiles, [])
-    where
-        Just (fp, handle, iomode) = retrieveOpenedFile openFiles filepath
-                                                            
-
-fileIsReadable :: [OpenFile] -> FilePath -> Bool
-fileIsReadable opened filepath | fileIsOpened opened filepath = iomode == ReadMode || iomode == ReadWriteMode
-                               | otherwise                    = False
-                              where
-                                  Just (fp, handle, iomode) = retrieveOpenedFile opened filepath
-
-                                  
-fileIsWriteable :: [OpenFile] -> FilePath -> Bool
-fileIsWriteable opened filepath | fileIsOpened opened filepath = iomode == WriteMode || iomode == ReadWriteMode || iomode == AppendMode
-                                | otherwise                    = False
-                                where
-                                    Just (fp, handle, iomode) = retrieveOpenedFile opened filepath
-
-                                  
-fileIsOpened :: [OpenFile] -> FilePath -> Bool
-fileIsOpened opened filepath = not (openedFileM == Nothing)
-                             where
-                                openedFileM = retrieveOpenedFile opened filepath
-                                  
-                                  
-retrieveContents :: Handle -> IO [[Char]]
-retrieveContents handle = do
-                            line <- hGetLine handle
-                            isEOF <- hIsEOF handle
-                            if isEOF
-                                then
-                                    return [line]
-                                else do
-                                    lines <- retrieveContents handle
-                                    return (line:lines)
-                                      
-                                      
-retrieveOpenedFile :: [OpenFile] -> FilePath -> Maybe OpenFile
-retrieveOpenedFile [] _ = Nothing
-retrieveOpenedFile (openfile@(fp, h, iom):ofs) ufp | ufp == fp = Just openfile
-                                                   | otherwise = retrieveOpenedFile ofs ufp
-
-                                             
-removeOpenedFile :: [OpenFile] -> FilePath -> [OpenFile]
-removeOpenedFile [] _ = []
-removeOpenedFile (openfile@(fp, h, iom):ofs) ufp | ufp == fp = ofs
-                                                 | otherwise = openfile:(removeOpenedFile ofs ufp)
-
-                                           
-fileTeardown :: Teardown
-fileTeardown sharedConst sharedIO ioConst ioState
-    = do
-         closeAllFiles handles
-         return (sharedIO)
-    where
-        handles = map (\(fp, h, iom) -> h) (opened ioState)
-
-
-closeAllFiles :: [Handle] -> IO ()
-closeAllFiles [] = return ()
-closeAllFiles (h:hs) = do
-                         hClose h
+module Eventloop.Module.File.File+    ( setupFileModuleConfiguration+    , fileModuleIdentifier+    , fileEventRetriever+    , fileEventSender+    , fileTeardown+    ) where++import Data.Maybe+import Control.Concurrent.Datastructures.BlockingConcurrentQueue+import Control.Concurrent.STM+import System.IO++import Eventloop.Module.File.Types+import Eventloop.Types.Common+import Eventloop.Types.Events+import Eventloop.Types.System+++setupFileModuleConfiguration :: EventloopSetupModuleConfiguration+setupFileModuleConfiguration = ( EventloopSetupModuleConfiguration+                                    fileModuleIdentifier+                                    (Just fileInitializer)+                                    (Just fileEventRetriever)+                                    Nothing+                                    Nothing+                                    (Just fileEventSender)+                                    (Just fileTeardown)+                                 )++fileModuleIdentifier :: EventloopModuleIdentifier+fileModuleIdentifier = "file"+++fileInitializer :: Initializer+fileInitializer sharedConst sharedIO+    = do+        inQueue <- createBlockingConcurrentQueue+        return (sharedConst, sharedIO, FileConstants inQueue, FileState [])+++fileEventRetriever :: EventRetriever+fileEventRetriever sharedConst sharedIOT ioConst ioStateT+    = do+        fileInEvents <- takeAllFromBlockingConcurrentQueue queue+        return (map InFile fileInEvents)+    where+        queue = fileInQueue ioConst+++fileEventSender :: EventSender+fileEventSender _ _ _ _ Stop = return ()+fileEventSender sharedConst sharedIOT ioConst ioStateT (OutFile out)+    = do+        (FileState openFiles) <- readTVarIO ioStateT+        (openFiles', inEvents) <- fileEventSender' openFiles out+        atomically $ writeTVar ioStateT (FileState openFiles')+        putAllInBlockingConcurrentQueue inQueue inEvents+    where+        inQueue = fileInQueue ioConst+++fileEventSender' :: [OpenFile] -> FileOut -> IO ([OpenFile], [FileIn])+fileEventSender' openFiles (OpenFile filepath iomode)+    = do+        handle <- openFile filepath iomode+        let+            fileOpenedEvent = FileOpened filepath True+            openFiles' = openFiles ++ [(filepath, handle, iomode)]+        return (openFiles', [fileOpenedEvent])++fileEventSender' openFiles (CloseFile filepath)+    | openFileM == Nothing = return ([], [])+    | otherwise = do+                   hClose handle+                   return (openFiles', [closedFileEvent])+    where+        openFileM = retrieveOpenedFile openFiles filepath+        (fp, handle, iomode) = fromJust openFileM+        openFiles' = removeOpenedFile openFiles filepath+        closedFileEvent = FileClosed filepath True++fileEventSender' openFiles (RetrieveContents filepath)+    = doReadAction filepath openFiles RetrievedContents retrieveContents++fileEventSender' openFiles (RetrieveLine filepath)+     = doReadAction filepath openFiles RetrievedLine hGetLine++fileEventSender' openFiles (RetrieveChar filepath)+    = doReadAction filepath openFiles RetrievedChar hGetChar++fileEventSender' openFiles (IfEOF filepath)+    = getFromFile filepath openFiles fileIsOpened IsEOF hIsEOF++fileEventSender' openFiles (WriteTo filepath contents)+    | fileIsWriteable openFiles filepath = do+        hPutStr handle contents+        return (openFiles, [WroteTo filepath True])+    | otherwise = return (openFiles, [])+    where+        Just (fp, handle, iomode) = retrieveOpenedFile openFiles filepath+++doReadAction :: FilePath+             -> [OpenFile]+             -> (FilePath -> a -> FileIn)+             -> (Handle -> IO a)+             -> IO ([OpenFile], [FileIn])+doReadAction filepath openFiles inEvent readAction+    = getFromFile filepath openFiles fileIsReadable inEvent readAction+++getFromFile :: FilePath ->+               [OpenFile] ->+               ([OpenFile] -> FilePath -> Bool) -> {- Check if the action should be done -}+               (FilePath -> a -> FileIn) -> {- The inEvent Constructor -}+               (Handle -> IO a) ->  {- The action which will grant a result -}+               IO ([OpenFile], [FileIn])+getFromFile filepath openFiles fileCheck inEvent action+    | fileCheck openFiles filepath = do+        result <- action handle+        return (openFiles, [inEvent filepath result])+    | otherwise                 = return (openFiles, [])+    where+        Just (fp, handle, iomode) = retrieveOpenedFile openFiles filepath+++fileIsReadable :: [OpenFile] -> FilePath -> Bool+fileIsReadable opened filepath | fileIsOpened opened filepath = iomode == ReadMode || iomode == ReadWriteMode+                               | otherwise                    = False+                              where+                                  Just (fp, handle, iomode) = retrieveOpenedFile opened filepath+++fileIsWriteable :: [OpenFile] -> FilePath -> Bool+fileIsWriteable opened filepath | fileIsOpened opened filepath = iomode == WriteMode || iomode == ReadWriteMode || iomode == AppendMode+                                | otherwise                    = False+                                where+                                    Just (fp, handle, iomode) = retrieveOpenedFile opened filepath+++fileIsOpened :: [OpenFile] -> FilePath -> Bool+fileIsOpened opened filepath = not (openedFileM == Nothing)+                             where+                                openedFileM = retrieveOpenedFile opened filepath+++retrieveContents :: Handle -> IO [[Char]]+retrieveContents handle = do+                            line <- hGetLine handle+                            isEOF <- hIsEOF handle+                            if isEOF+                                then+                                    return [line]+                                else do+                                    lines <- retrieveContents handle+                                    return (line:lines)+++retrieveOpenedFile :: [OpenFile] -> FilePath -> Maybe OpenFile+retrieveOpenedFile [] _ = Nothing+retrieveOpenedFile (openfile@(fp, h, iom):ofs) ufp | ufp == fp = Just openfile+                                                   | otherwise = retrieveOpenedFile ofs ufp+++removeOpenedFile :: [OpenFile] -> FilePath -> [OpenFile]+removeOpenedFile [] _ = []+removeOpenedFile (openfile@(fp, h, iom):ofs) ufp | ufp == fp = ofs+                                                 | otherwise = openfile:(removeOpenedFile ofs ufp)+++fileTeardown :: Teardown+fileTeardown sharedConst sharedIO ioConst ioState+    = do+         closeAllFiles handles+         return (sharedIO)+    where+        handles = map (\(fp, h, iom) -> h) (opened ioState)+++closeAllFiles :: [Handle] -> IO ()+closeAllFiles [] = return ()+closeAllFiles (h:hs) = do+                         hClose h                          closeAllFiles hs

@@ -1,29 +1,29 @@-{-# LANGUAGE DeriveGeneric, DeriveAnyClass, StandaloneDeriving #-}
-module Eventloop.Module.File.Types where
-
-import System.IO
-import GHC.Generics (Generic)
-import Control.DeepSeq
-
-type OpenFile = (FilePath, Handle, IOMode)
-
-data FileIn = FileOpened FilePath Bool
-            | FileClosed FilePath Bool
-            | RetrievedContents FilePath [[Char]]
-            | RetrievedLine FilePath [Char]
-            | RetrievedChar FilePath Char
-            | IsEOF FilePath Bool
-            | WroteTo FilePath Bool
-            deriving (Eq, Show)
-
-data FileOut = OpenFile FilePath IOMode
-             | CloseFile FilePath
-             | RetrieveContents FilePath
-             | RetrieveLine FilePath
-             | RetrieveChar FilePath
-             | IfEOF FilePath
-             | WriteTo FilePath [Char]
-             deriving (Eq, Show, Generic, NFData)
-
-deriving instance Generic IOMode
+{-# LANGUAGE DeriveGeneric, DeriveAnyClass, StandaloneDeriving #-}+module Eventloop.Module.File.Types where++import System.IO+import GHC.Generics (Generic)+import Control.DeepSeq++type OpenFile = (FilePath, Handle, IOMode)++data FileIn = FileOpened FilePath Bool+            | FileClosed FilePath Bool+            | RetrievedContents FilePath [[Char]]+            | RetrievedLine FilePath [Char]+            | RetrievedChar FilePath Char+            | IsEOF FilePath Bool+            | WroteTo FilePath Bool+            deriving (Eq, Show)++data FileOut = OpenFile FilePath IOMode+             | CloseFile FilePath+             | RetrieveContents FilePath+             | RetrieveLine FilePath+             | RetrieveChar FilePath+             | IfEOF FilePath+             | WriteTo FilePath [Char]+             deriving (Eq, Show, Generic, NFData)++deriving instance Generic IOMode deriving instance NFData IOMode

@@ -1,7 +1,7 @@-module Eventloop.Module.Graphs
-    ( module Eventloop.Module.Graphs.Graphs
-    , module Eventloop.Module.Graphs.Types
-    ) where
-    
-import Eventloop.Module.Graphs.Graphs
+module Eventloop.Module.Graphs+    ( module Eventloop.Module.Graphs.Graphs+    , module Eventloop.Module.Graphs.Types+    ) where++import Eventloop.Module.Graphs.Graphs import Eventloop.Module.Graphs.Types

@@ -1,230 +1,230 @@-module Eventloop.Module.Graphs.Graphs where
-
-
-import Eventloop.Module.Graphs.Types
-import qualified Eventloop.Module.Websocket.Canvas as C
-import qualified Eventloop.Module.Websocket.Mouse as M
-import qualified Eventloop.Module.Websocket.Keyboard as K
-import qualified Eventloop.Module.BasicShapes as BS
-import Eventloop.Types.Common
-import Eventloop.Types.Events
-import Eventloop.Types.System
-import Eventloop.Utility.Vectors
-
-
-setupGraphsModuleConfiguration :: EventloopSetupModuleConfiguration
-setupGraphsModuleConfiguration = ( EventloopSetupModuleConfiguration
-                                      graphsModuleIdentifier
-                                      Nothing
-                                      Nothing
-                                      (Just graphsPreProcessor)
-                                      (Just graphsPostProcessor)
-                                      Nothing
-                                      Nothing
-                                   )
-
-graphsModuleIdentifier :: EventloopModuleIdentifier
-graphsModuleIdentifier = "graphs"
-                                      
-
-
-nodeRadius   = 20 :: Float                 
-textSize     = 16 :: Float
-textFont     = "Courier"
-xArrowSize   = 6 :: Float
-yArrowSize   = 6 :: Float
-weightHeight = 15 :: Float
-
-dimCanvasGraphs = (840,440) :: (Float, Float)
-roundDimCanvasGraphs = (round $ fst dimCanvasGraphs, round $ snd dimCanvasGraphs) :: (Int, Int)
-canvasGraphsWidth = fst dimCanvasGraphs
-canvasGraphsHeight = snd dimCanvasGraphs
-
-instructionsHeight = 200 :: Float
-instructionsBeginAt = instructionsHeight + canvasGraphsHeight
-canvasInstrWidth = canvasGraphsWidth
-canvasInstrHeight = instructionsHeight * 2 + canvasGraphsHeight
-dimCanvasInstr = (canvasInstrWidth, canvasInstrHeight)
-roundDimCanvasInstr = (round $ fst dimCanvasInstr, round $ snd dimCanvasInstr) :: (Int, Int)
-
-canvasIdGraphs = 1 :: C.CanvasId
-canvasIdInstructions = 2 :: C.CanvasId
-
-               
--- | Checkes to see if there is a node on a certain position                
-onNode :: [Node] -> Pos -> Maybe Node
-onNode [] _ = Nothing
-onNode (n@(_, (nx, ny), _):ns) (x,y) | difference <= nodeRadius = Just n
-                                     | otherwise                = onNode ns (x,y)
-                                    where
-                                        dx         = nx - x
-                                        dy         = ny - y
-                                        difference = sqrt (dx^2 + dy^2)
-                 
-
-
--- | Abstracts the standardized 'EventLoop.Types.EventTypes' to 'GraphsIn'
-graphsPreProcessor :: PreProcessor
-graphsPreProcessor sharedConst sharedIOT ioConst ioStateT (InMouse (M.Mouse M.MouseCanvas 1 event (Point p)))
-    | x >=0 && y >= 0 && y <= canvasGraphsHeight && x <= canvasGraphsWidth = return [InGraphs $ Mouse event p]
-    | otherwise = return []
-    where
-        (x, y) = p
-    
-graphsPreProcessor sharedConst sharedIOT ioConst ioStateT k@(InKeyboard (K.Key key))
-    = return [k, InGraphs $ Key key]
-    
-graphsPreProcessor sharedConst sharedIOT ioConst ioStateT inEvent
-    = return [inEvent]
-
-
--- | Abstracts 'GraphsOut' back to 'BasicShapes' and 'Canvas' events
-graphsPostProcessor :: PostProcessor
-graphsPostProcessor sharedConst sharedIOT ioConst ioStateT (OutGraphs SetupGraphs)
-    = return [ OutCanvas $ C.SetupCanvas canvasIdGraphs  1 roundDimCanvasGraphs (C.CSSPosition C.CSSFromCenter (C.CSSPercentage 50, C.CSSPercentage 50))
-             , OutCanvas $ C.SetupCanvas canvasIdInstructions 2 roundDimCanvasInstr (C.CSSPosition C.CSSFromCenter (C.CSSPercentage 50, C.CSSPercentage 50))
-             ]
-        
-                   
-graphsPostProcessor sharedConst sharedIOT ioConst ioStateT (OutGraphs (DrawGraph graph))
-    = return [ OutCanvas $ C.CanvasOperations canvasIdGraphs [C.Clear C.ClearCanvas]
-             , OutBasicShapes $ BS.DrawShapes canvasIdGraphs shapes
-             ]
-    where
-        shapes = graphToShapes graph
-    
-graphsPostProcessor sharedConst sharedIOT ioConst ioStateT (OutGraphs (Instructions is))
-    = return [ OutCanvas $ C.CanvasOperations canvasIdInstructions [C.Clear C.ClearCanvas]
-             , OutBasicShapes $ BS.DrawShapes canvasIdInstructions shapes
-             ]
-    where
-        startPLine  = Point (0, 0)
-        endPLine    = Point (canvasGraphsWidth, 0)
-        lineHeight  = 2
-        lineShape   = BS.Line startPLine endPLine lineHeight (0,0,0,255) Nothing
-        textShape   = (\line p -> BS.Text line textFont textSize p BS.AlignCenter (0,0,0,255) 0 (0,0,0,0) Nothing)
-        textMargin        = 2
-        heights           = iterate ((+) (textSize + textMargin)) lineHeight
-        isAndHeights      = zip is heights
-        instructionShapes = map (\(line, top) -> textShape line $ Point (0.5 * canvasGraphsWidth, top)) isAndHeights
-        shapes            = [BS.CompositeShape (lineShape:instructionShapes) (Just (Point (0, instructionsBeginAt))) Nothing]
-
-graphsPostProcessor sharedConst sharedIOT ioConst ioStateT out
-    = return [out]
-  
--- | Translates color datatype to RGBA codes
-colorToRGBAColor :: Color -> BS.Color
-colorToRGBAColor Red    = (255, 0, 0, 255)
-colorToRGBAColor Blue   = (0, 0, 255, 255)
-colorToRGBAColor Green  = (0, 255, 0, 255)
-colorToRGBAColor Purple = (255, 0, 255, 255)
-colorToRGBAColor Grey   = (125, 125, 125, 255)
-colorToRGBAColor Yellow = (255, 255, 0, 255)
-colorToRGBAColor Orange = (255, 125, 0, 255)
-colorToRGBAColor Black  = (0, 0, 0, 255)
-colorToRGBAColor White  = (255, 255, 255, 255)
-     
-     
--- | Translates the thickness to a float           
-thicknessToFloat :: Thickness -> BS.StrokeLineThickness
-thicknessToFloat Thick = 3.0
-thicknessToFloat Thin  = 1.0
-
-
-findNode :: [Node] -> Label -> Node
-findNode [] l = error ("Tried to find a node in the graph with label '" ++ (show l) ++ "' but could not find it!")
-findNode (n@(ln, _, _):ns) l | l == ln = n
-                             | otherwise = findNode ns l
-                             
-
-graphToShapes :: Graph -> [BS.Shape]
-graphToShapes graph
-    = (concat nodeShapes) ++ (concat edgeShapes)
-    where
-        allNodes = nodes graph
-        allEdges = edges graph
-        isDirected = directed graph
-        isWeighted = weighted graph
-        allEdgesWithNodes = map (\e@(l1, l2,_,_,_) -> (findNode allNodes l1, findNode allNodes l2, e)) allEdges
-        nodeShapes = map nodeToShapes allNodes
-        edgeShapes = map (\(n1, n2, e) -> edgeToShapes n1 n2 e isDirected isWeighted) allEdgesWithNodes
-
-
-nodeToShapes :: Node -> [BS.Shape]
-nodeToShapes (l, p, col)
-    = [ BS.Circle (Point p) nodeRadius color 2 (0,0,0,255) Nothing
-      , BS.Text lStr textFont textSize (Point p) BS.AlignCenter (0,0,0,255) 3 (0,0,0,255) Nothing
-      ]
-    where
-        color = colorToRGBAColor col
-        lStr = [l]
-
-        
-edgeToShapes :: Node -> Node -> Edge -> Directed -> Weighted -> [BS.Shape]
-edgeToShapes (_, p1, _) (_, p2, _) (_, _, col, w, thick) directed weighted
-    = lineShape:(weightShapes ++ directShapes)
-    where
-        directShapes | directed == Directed   = [ BS.Line (Point arrowStart) (Point arrow1End) thickness color Nothing
-                                                , BS.Line (Point arrowStart) (Point arrow2End) thickness color Nothing
-                                                ]
-                     | directed == Undirected = []
-        weightShapes | weighted == Weighted   = [BS.Text wStr textFont textSize (Point textPos) BS.AlignCenter (0,0,0,255) 0 (0,0,0,0) Nothing]
-                     | weighted == Unweighted = []
-                    where
-                        wStr = show w
-        lineShape = BS.Line (Point lineStart) (Point lineEnd) thickness color Nothing
-        thickness = thicknessToFloat thick
-        color = colorToRGBAColor col
-        -- Margin line vector stuff
-        lineVector         = vectorize p1 p2
-        lineVector'        = vectorize p2 p1
-        lineStart          = posOnVector nodeRadius lineVector p1
-        lineEnd            = posOnVector nodeRadius lineVector' p2
-        -- Arrow directed vector stuff
-        arrowPerpStart     = posOnVector xArrowSize lineVector' lineEnd  
-        upPerpLineVector   = upPerpendicularTo p1 p2
-        downPerpLineVector = downPerpendicularTo p1 p2
-        arrowStart         = lineEnd
-        arrow1End          = posOnVector yArrowSize upPerpLineVector arrowPerpStart  
-        arrow2End          = posOnVector yArrowSize downPerpLineVector arrowPerpStart
-        -- Weight vector stuff
-        halfSize          = vectorSize lineVector' / 2
-        textPerpStart     = posOnVector halfSize lineVector p1
-        textPos           = posOnVector weightHeight upPerpLineVector textPerpStart
-        
-
--- | Returns the point when making a step f long from the point start in the direction of the vector. The length between start pos and result pos is always f.
-posOnVector :: Float -> Vector -> Pos -> Pos
-posOnVector f (xv, yv) (xStart, yStart) = (x, y)
-                                        where
-                                            x        = xStart + fraction * xv
-                                            y        = yStart + fraction * yv
-                                            fraction = f / size
-                                            size     = vectorSize (xv, yv)
-
--- | Vector from p1 to p2 
-vectorize :: Pos -> Pos -> Vector
-vectorize (x1, y1) (x2, y2) = (x2 - x1, y2 - y1)
-
-
--- | Returns the vector perpendicular on the given vector between the 2 points. Always has positive y and vector length 1; y is inverted in canvas
-downPerpendicularTo :: Pos -> Pos -> Vector
-downPerpendicularTo (x1, y1) (x2, y2) | y2 > y1   = ((-1) * sign * (abs yv) / size, (abs xv) / size)
-                                    | otherwise = (       sign * (abs yv) / size, (abs xv) / size)
-                                      where
-                                          (xv, yv) = vectorize (x1, y1) (x2, y2)
-                                          size     = vectorSize (xv, yv)
-                                          sign     = case xv of
-                                                        0 -> (-1)
-                                                        _ -> xv / (abs xv)
-                                            
-                                            
--- | Returns the vector perpendicular on the given vector between the 2 points. Always has negative y and vector length 1; y is inverted in canvas
-upPerpendicularTo :: Pos -> Pos -> Vector
-upPerpendicularTo p1 p2 = ((-1) * xp, (-1) * yp)
-                        where
-                            (xp, yp) = downPerpendicularTo p1 p2
-                          
--- | Returns the size of the vector                          
-vectorSize :: Vector -> Float
-vectorSize (x, y) = sqrt (x^2 + y^2)                                            +module Eventloop.Module.Graphs.Graphs where+++import Eventloop.Module.Graphs.Types+import qualified Eventloop.Module.Websocket.Canvas as C+import qualified Eventloop.Module.Websocket.Mouse as M+import qualified Eventloop.Module.Websocket.Keyboard as K+import qualified Eventloop.Module.BasicShapes as BS+import Eventloop.Types.Common+import Eventloop.Types.Events+import Eventloop.Types.System+import Eventloop.Utility.Vectors+++setupGraphsModuleConfiguration :: EventloopSetupModuleConfiguration+setupGraphsModuleConfiguration = ( EventloopSetupModuleConfiguration+                                      graphsModuleIdentifier+                                      Nothing+                                      Nothing+                                      (Just graphsPreProcessor)+                                      (Just graphsPostProcessor)+                                      Nothing+                                      Nothing+                                   )++graphsModuleIdentifier :: EventloopModuleIdentifier+graphsModuleIdentifier = "graphs"++++nodeRadius   = 20 :: Float+textSize     = 16 :: Float+textFont     = "Courier"+xArrowSize   = 6 :: Float+yArrowSize   = 6 :: Float+weightHeight = 15 :: Float++dimCanvasGraphs = (840,440) :: (Float, Float)+roundDimCanvasGraphs = (round $ fst dimCanvasGraphs, round $ snd dimCanvasGraphs) :: (Int, Int)+canvasGraphsWidth = fst dimCanvasGraphs+canvasGraphsHeight = snd dimCanvasGraphs++instructionsHeight = 200 :: Float+instructionsBeginAt = instructionsHeight + canvasGraphsHeight+canvasInstrWidth = canvasGraphsWidth+canvasInstrHeight = instructionsHeight * 2 + canvasGraphsHeight+dimCanvasInstr = (canvasInstrWidth, canvasInstrHeight)+roundDimCanvasInstr = (round $ fst dimCanvasInstr, round $ snd dimCanvasInstr) :: (Int, Int)++canvasIdGraphs = 1 :: C.CanvasId+canvasIdInstructions = 2 :: C.CanvasId+++-- | Checkes to see if there is a node on a certain position+onNode :: [Node] -> Pos -> Maybe Node+onNode [] _ = Nothing+onNode (n@(_, (nx, ny), _):ns) (x,y) | difference <= nodeRadius = Just n+                                     | otherwise                = onNode ns (x,y)+                                    where+                                        dx         = nx - x+                                        dy         = ny - y+                                        difference = sqrt (dx^2 + dy^2)++++-- | Abstracts the standardized 'EventLoop.Types.EventTypes' to 'GraphsIn'+graphsPreProcessor :: PreProcessor+graphsPreProcessor sharedConst sharedIOT ioConst ioStateT (InMouse (M.Mouse M.MouseCanvas 1 event (Point p)))+    | x >=0 && y >= 0 && y <= canvasGraphsHeight && x <= canvasGraphsWidth = return [InGraphs $ Mouse event p]+    | otherwise = return []+    where+        (x, y) = p++graphsPreProcessor sharedConst sharedIOT ioConst ioStateT k@(InKeyboard (K.Key key))+    = return [k, InGraphs $ Key key]++graphsPreProcessor sharedConst sharedIOT ioConst ioStateT inEvent+    = return [inEvent]+++-- | Abstracts 'GraphsOut' back to 'BasicShapes' and 'Canvas' events+graphsPostProcessor :: PostProcessor+graphsPostProcessor sharedConst sharedIOT ioConst ioStateT (OutGraphs SetupGraphs)+    = return [ OutCanvas $ C.SetupCanvas canvasIdGraphs  1 roundDimCanvasGraphs (C.CSSPosition C.CSSFromCenter (C.CSSPercentage 50, C.CSSPercentage 50))+             , OutCanvas $ C.SetupCanvas canvasIdInstructions 2 roundDimCanvasInstr (C.CSSPosition C.CSSFromCenter (C.CSSPercentage 50, C.CSSPercentage 50))+             ]+++graphsPostProcessor sharedConst sharedIOT ioConst ioStateT (OutGraphs (DrawGraph graph))+    = return [ OutCanvas $ C.CanvasOperations canvasIdGraphs [C.Clear C.ClearCanvas]+             , OutBasicShapes $ BS.DrawShapes canvasIdGraphs shapes+             ]+    where+        shapes = graphToShapes graph++graphsPostProcessor sharedConst sharedIOT ioConst ioStateT (OutGraphs (Instructions is))+    = return [ OutCanvas $ C.CanvasOperations canvasIdInstructions [C.Clear C.ClearCanvas]+             , OutBasicShapes $ BS.DrawShapes canvasIdInstructions shapes+             ]+    where+        startPLine  = Point (0, 0)+        endPLine    = Point (canvasGraphsWidth, 0)+        lineHeight  = 2+        lineShape   = BS.Line startPLine endPLine lineHeight (0,0,0,255) Nothing+        textShape   = (\line p -> BS.Text line textFont textSize p BS.AlignCenter (0,0,0,255) 0 (0,0,0,0) Nothing)+        textMargin        = 2+        heights           = iterate ((+) (textSize + textMargin)) lineHeight+        isAndHeights      = zip is heights+        instructionShapes = map (\(line, top) -> textShape line $ Point (0.5 * canvasGraphsWidth, top)) isAndHeights+        shapes            = [BS.CompositeShape (lineShape:instructionShapes) (Just (Point (0, instructionsBeginAt))) Nothing]++graphsPostProcessor sharedConst sharedIOT ioConst ioStateT out+    = return [out]++-- | Translates color datatype to RGBA codes+colorToRGBAColor :: Color -> BS.Color+colorToRGBAColor Red    = (255, 0, 0, 255)+colorToRGBAColor Blue   = (0, 0, 255, 255)+colorToRGBAColor Green  = (0, 255, 0, 255)+colorToRGBAColor Purple = (255, 0, 255, 255)+colorToRGBAColor Grey   = (125, 125, 125, 255)+colorToRGBAColor Yellow = (255, 255, 0, 255)+colorToRGBAColor Orange = (255, 125, 0, 255)+colorToRGBAColor Black  = (0, 0, 0, 255)+colorToRGBAColor White  = (255, 255, 255, 255)+++-- | Translates the thickness to a float+thicknessToFloat :: Thickness -> BS.StrokeLineThickness+thicknessToFloat Thick = 3.0+thicknessToFloat Thin  = 1.0+++findNode :: [Node] -> Label -> Node+findNode [] l = error ("Tried to find a node in the graph with label '" ++ (show l) ++ "' but could not find it!")+findNode (n@(ln, _, _):ns) l | l == ln = n+                             | otherwise = findNode ns l+++graphToShapes :: Graph -> [BS.Shape]+graphToShapes graph+    = (concat nodeShapes) ++ (concat edgeShapes)+    where+        allNodes = nodes graph+        allEdges = edges graph+        isDirected = directed graph+        isWeighted = weighted graph+        allEdgesWithNodes = map (\e@(l1, l2,_,_,_) -> (findNode allNodes l1, findNode allNodes l2, e)) allEdges+        nodeShapes = map nodeToShapes allNodes+        edgeShapes = map (\(n1, n2, e) -> edgeToShapes n1 n2 e isDirected isWeighted) allEdgesWithNodes+++nodeToShapes :: Node -> [BS.Shape]+nodeToShapes (l, p, col)+    = [ BS.Circle (Point p) nodeRadius color 2 (0,0,0,255) Nothing+      , BS.Text lStr textFont textSize (Point p) BS.AlignCenter (0,0,0,255) 3 (0,0,0,255) Nothing+      ]+    where+        color = colorToRGBAColor col+        lStr = [l]+++edgeToShapes :: Node -> Node -> Edge -> Directed -> Weighted -> [BS.Shape]+edgeToShapes (_, p1, _) (_, p2, _) (_, _, col, w, thick) directed weighted+    = lineShape:(weightShapes ++ directShapes)+    where+        directShapes | directed == Directed   = [ BS.Line (Point arrowStart) (Point arrow1End) thickness color Nothing+                                                , BS.Line (Point arrowStart) (Point arrow2End) thickness color Nothing+                                                ]+                     | directed == Undirected = []+        weightShapes | weighted == Weighted   = [BS.Text wStr textFont textSize (Point textPos) BS.AlignCenter (0,0,0,255) 0 (0,0,0,0) Nothing]+                     | weighted == Unweighted = []+                    where+                        wStr = show w+        lineShape = BS.Line (Point lineStart) (Point lineEnd) thickness color Nothing+        thickness = thicknessToFloat thick+        color = colorToRGBAColor col+        -- Margin line vector stuff+        lineVector         = vectorize p1 p2+        lineVector'        = vectorize p2 p1+        lineStart          = posOnVector nodeRadius lineVector p1+        lineEnd            = posOnVector nodeRadius lineVector' p2+        -- Arrow directed vector stuff+        arrowPerpStart     = posOnVector xArrowSize lineVector' lineEnd+        upPerpLineVector   = upPerpendicularTo p1 p2+        downPerpLineVector = downPerpendicularTo p1 p2+        arrowStart         = lineEnd+        arrow1End          = posOnVector yArrowSize upPerpLineVector arrowPerpStart+        arrow2End          = posOnVector yArrowSize downPerpLineVector arrowPerpStart+        -- Weight vector stuff+        halfSize          = vectorSize lineVector' / 2+        textPerpStart     = posOnVector halfSize lineVector p1+        textPos           = posOnVector weightHeight upPerpLineVector textPerpStart+++-- | Returns the point when making a step f long from the point start in the direction of the vector. The length between start pos and result pos is always f.+posOnVector :: Float -> Vector -> Pos -> Pos+posOnVector f (xv, yv) (xStart, yStart) = (x, y)+                                        where+                                            x        = xStart + fraction * xv+                                            y        = yStart + fraction * yv+                                            fraction = f / size+                                            size     = vectorSize (xv, yv)++-- | Vector from p1 to p2+vectorize :: Pos -> Pos -> Vector+vectorize (x1, y1) (x2, y2) = (x2 - x1, y2 - y1)+++-- | Returns the vector perpendicular on the given vector between the 2 points. Always has positive y and vector length 1; y is inverted in canvas+downPerpendicularTo :: Pos -> Pos -> Vector+downPerpendicularTo (x1, y1) (x2, y2) | y2 > y1   = ((-1) * sign * (abs yv) / size, (abs xv) / size)+                                    | otherwise = (       sign * (abs yv) / size, (abs xv) / size)+                                      where+                                          (xv, yv) = vectorize (x1, y1) (x2, y2)+                                          size     = vectorSize (xv, yv)+                                          sign     = case xv of+                                                        0 -> (-1)+                                                        _ -> xv / (abs xv)+++-- | Returns the vector perpendicular on the given vector between the 2 points. Always has negative y and vector length 1; y is inverted in canvas+upPerpendicularTo :: Pos -> Pos -> Vector+upPerpendicularTo p1 p2 = ((-1) * xp, (-1) * yp)+                        where+                            (xp, yp) = downPerpendicularTo p1 p2++-- | Returns the size of the vector+vectorSize :: Vector -> Float+vectorSize (x, y) = sqrt (x^2 + y^2)

@@ -1,62 +1,62 @@-{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
-module Eventloop.Module.Graphs.Types
-    ( module Eventloop.Module.Graphs.Types
-    , M.MouseEvent(..)
-    , M.MouseButton(..)
-    ) where
-
-import GHC.Generics (Generic)
-import Control.DeepSeq
-
-import qualified Eventloop.Module.Websocket.Mouse.Types as M
-    
-type Pos = (Float, Float)
-type Vector = (Float, Float)
-
-
-data GraphsIn = Mouse M.MouseEvent Pos
-              | Key [Char]
-              deriving (Eq, Show)
-    
-data GraphsOut = SetupGraphs
-               | DrawGraph Graph
-               | Instructions [String]
-               deriving (Eq, Show, Generic, NFData)
-              
------ Graph -----
-type Label   = Char
-type Weight  = Float
-
-type Node = (Label, Pos, Color)
-type Edge = (Label, Label, Color, Weight, Thickness)
-
-data Graph = Graph
-            { nodes    :: [Node]
-            , edges    :: [Edge]
-            , directed :: Directed
-            , weighted :: Weighted
-            } deriving (Eq, Show, Generic, NFData)
-            
------ Graph Graphical -----            
-data Color = Red
-           | Blue
-           | Green
-           | Purple
-           | Grey
-           | Yellow
-           | Orange
-           | Black
-           | White
-           deriving (Eq, Show, Generic, NFData)
-
-data Thickness = Thin
-               | Thick
-               deriving (Eq, Show, Generic, NFData)
-
-data Directed  = Directed
-               | Undirected
-                deriving (Eq, Show, Generic, NFData)
-               
-data Weighted  = Weighted
-               | Unweighted
+{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}+module Eventloop.Module.Graphs.Types+    ( module Eventloop.Module.Graphs.Types+    , M.MouseEvent(..)+    , M.MouseButton(..)+    ) where++import GHC.Generics (Generic)+import Control.DeepSeq++import qualified Eventloop.Module.Websocket.Mouse.Types as M++type Pos = (Float, Float)+type Vector = (Float, Float)+++data GraphsIn = Mouse M.MouseEvent Pos+              | Key [Char]+              deriving (Eq, Show)++data GraphsOut = SetupGraphs+               | DrawGraph Graph+               | Instructions [String]+               deriving (Eq, Show, Generic, NFData)++----- Graph -----+type Label   = Char+type Weight  = Float++type Node = (Label, Pos, Color)+type Edge = (Label, Label, Color, Weight, Thickness)++data Graph = Graph+            { nodes    :: [Node]+            , edges    :: [Edge]+            , directed :: Directed+            , weighted :: Weighted+            } deriving (Eq, Show, Generic, NFData)++----- Graph Graphical -----+data Color = Red+           | Blue+           | Green+           | Purple+           | Grey+           | Yellow+           | Orange+           | Black+           | White+           deriving (Eq, Show, Generic, NFData)++data Thickness = Thin+               | Thick+               deriving (Eq, Show, Generic, NFData)++data Directed  = Directed+               | Undirected+                deriving (Eq, Show, Generic, NFData)++data Weighted  = Weighted+               | Unweighted                deriving (Eq, Show, Generic, NFData)

@@ -40,7 +40,8 @@ statefulGraphicsPostProcessor :: PostProcessor statefulGraphicsPostProcessor sharedConst sharedIOT ioConst ioStateT (OutStatefulGraphics canvasId commands)     = atomically $ do-        (StatefulGraphicsState states) <- readTVar ioStateT+        -- HACK: (StatefulGraphicsState states) is a failable pattern that GHC-8.6 doesn't want to compile because there is no MonadFail STM instance+        ~(StatefulGraphicsState states) <- readTVar ioStateT         let             stateM = findGraphicalState states canvasId             state = case stateM of

@@ -1,7 +1,7 @@-module Eventloop.Module.StdIn
-    ( module Eventloop.Module.StdIn.StdIn
-    , module Eventloop.Module.StdIn.Types
-    ) where
-    
-import Eventloop.Module.StdIn.StdIn
+module Eventloop.Module.StdIn+    ( module Eventloop.Module.StdIn.StdIn+    , module Eventloop.Module.StdIn.Types+    ) where++import Eventloop.Module.StdIn.StdIn import Eventloop.Module.StdIn.Types

@@ -1,77 +1,77 @@-module Eventloop.Module.StdIn.StdIn
-    ( setupStdInModuleConfiguration
-    , stdInModuleIdentifier
-    , stdInInitializer
-    , stdInEventRetriever
-    , stdInEventSender
-    ) where
-
-import System.IO
-import Data.String
-import Control.Concurrent.Datastructures.BlockingConcurrentQueue
-import Control.Concurrent.STM
-
-import Eventloop.Module.StdIn.Types
-import Eventloop.Types.Common
-import Eventloop.Types.Events
-import Eventloop.Types.System
-
-setupStdInModuleConfiguration :: EventloopSetupModuleConfiguration
-setupStdInModuleConfiguration = ( EventloopSetupModuleConfiguration 
-                                    stdInModuleIdentifier
-                                    (Just stdInInitializer)
-                                    (Just stdInEventRetriever)
-                                    Nothing
-                                    Nothing
-                                    (Just stdInEventSender)
-                                    Nothing
-                                  )
-                                  
-
-stdInModuleIdentifier :: EventloopModuleIdentifier
-stdInModuleIdentifier = "stdin"
-
-
-stdInInitializer :: Initializer
-stdInInitializer sharedConst sharedIO
-    = do
-        inQueue <- createBlockingConcurrentQueue
-        return (sharedConst, sharedIO, StdInConstants inQueue, NoState)
-
-    
-stdInEventRetriever :: EventRetriever
-stdInEventRetriever sharedConst sharedIOT ioConst ioStateT
-    = do
-        inEvents <- takeAllFromBlockingConcurrentQueue inQueue
-        return (map InStdIn inEvents)
-    where
-        inQueue = stdInInQueue ioConst
-
-        
-stdInEventSender :: EventSender
-stdInEventSender _ _ _ _ Stop = return ()
-stdInEventSender sharedConst sharedIOT ioConst ioStateT (OutStdIn a)
-    = do
-        inEvents <- stdInEventSender' a
-        putAllInBlockingConcurrentQueue inQueue inEvents
-    where
-        inQueue = stdInInQueue ioConst
-        
-        
-stdInEventSender' :: StdInOut -> IO [StdInIn]
-stdInEventSender' StdInReceiveContents
-    = doStdInGet linedGetContents StdInReceivedContents
-    where
-        linedGetContents = (getContents >>= (\strContents -> return $ lines strContents))
-                  
-stdInEventSender' StdInReceiveLine
-    = doStdInGet getLine StdInReceivedLine
-stdInEventSender' StdInReceiveChar
-    = doStdInGet getChar StdInReceivedChar
-                                                
-                                                
-doStdInGet :: (IO a) -> (a -> StdInIn) -> IO [StdInIn]
-doStdInGet source typeEvent
-    = do
-        content <- source
+module Eventloop.Module.StdIn.StdIn+    ( setupStdInModuleConfiguration+    , stdInModuleIdentifier+    , stdInInitializer+    , stdInEventRetriever+    , stdInEventSender+    ) where++import System.IO+import Data.String+import Control.Concurrent.Datastructures.BlockingConcurrentQueue+import Control.Concurrent.STM++import Eventloop.Module.StdIn.Types+import Eventloop.Types.Common+import Eventloop.Types.Events+import Eventloop.Types.System++setupStdInModuleConfiguration :: EventloopSetupModuleConfiguration+setupStdInModuleConfiguration = ( EventloopSetupModuleConfiguration+                                    stdInModuleIdentifier+                                    (Just stdInInitializer)+                                    (Just stdInEventRetriever)+                                    Nothing+                                    Nothing+                                    (Just stdInEventSender)+                                    Nothing+                                  )+++stdInModuleIdentifier :: EventloopModuleIdentifier+stdInModuleIdentifier = "stdin"+++stdInInitializer :: Initializer+stdInInitializer sharedConst sharedIO+    = do+        inQueue <- createBlockingConcurrentQueue+        return (sharedConst, sharedIO, StdInConstants inQueue, NoState)+++stdInEventRetriever :: EventRetriever+stdInEventRetriever sharedConst sharedIOT ioConst ioStateT+    = do+        inEvents <- takeAllFromBlockingConcurrentQueue inQueue+        return (map InStdIn inEvents)+    where+        inQueue = stdInInQueue ioConst+++stdInEventSender :: EventSender+stdInEventSender _ _ _ _ Stop = return ()+stdInEventSender sharedConst sharedIOT ioConst ioStateT (OutStdIn a)+    = do+        inEvents <- stdInEventSender' a+        putAllInBlockingConcurrentQueue inQueue inEvents+    where+        inQueue = stdInInQueue ioConst+++stdInEventSender' :: StdInOut -> IO [StdInIn]+stdInEventSender' StdInReceiveContents+    = doStdInGet linedGetContents StdInReceivedContents+    where+        linedGetContents = (getContents >>= (\strContents -> return $ lines strContents))++stdInEventSender' StdInReceiveLine+    = doStdInGet getLine StdInReceivedLine+stdInEventSender' StdInReceiveChar+    = doStdInGet getChar StdInReceivedChar+++doStdInGet :: (IO a) -> (a -> StdInIn) -> IO [StdInIn]+doStdInGet source typeEvent+    = do+        content <- source         return ([typeEvent content])

@@ -1,15 +1,15 @@-{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
-module Eventloop.Module.StdIn.Types where
-
-import GHC.Generics (Generic)
-import Control.DeepSeq
-
-data StdInIn = StdInReceivedContents [[Char]]
-             | StdInReceivedLine [Char]
-             | StdInReceivedChar Char
-             deriving (Eq, Show)
-
-data StdInOut = StdInReceiveContents
-              | StdInReceiveLine
-              | StdInReceiveChar
+{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}+module Eventloop.Module.StdIn.Types where++import GHC.Generics (Generic)+import Control.DeepSeq++data StdInIn = StdInReceivedContents [[Char]]+             | StdInReceivedLine [Char]+             | StdInReceivedChar Char+             deriving (Eq, Show)++data StdInOut = StdInReceiveContents+              | StdInReceiveLine+              | StdInReceiveChar               deriving (Eq, Show, Generic, NFData)

@@ -1,7 +1,7 @@-module Eventloop.Module.StdOut
-    ( module Eventloop.Module.StdOut.StdOut
-    , module Eventloop.Module.StdOut.Types
-    ) where
-    
-import Eventloop.Module.StdOut.StdOut
+module Eventloop.Module.StdOut+    ( module Eventloop.Module.StdOut.StdOut+    , module Eventloop.Module.StdOut.Types+    ) where++import Eventloop.Module.StdOut.StdOut import Eventloop.Module.StdOut.Types

@@ -1,39 +1,39 @@-module Eventloop.Module.StdOut.StdOut
-    ( setupStdOutModuleConfiguration
-    , stdOutModuleIdentifier
-    , stdOutEventSender
-    ) where
-
-import System.IO
-
-import Control.Concurrent.MVar
-import Control.Concurrent.SafePrint
-
-import Eventloop.Module.StdOut.Types
-import Eventloop.Types.Common
-import Eventloop.Types.Events
-import Eventloop.Types.System
-
-setupStdOutModuleConfiguration :: EventloopSetupModuleConfiguration
-setupStdOutModuleConfiguration = ( EventloopSetupModuleConfiguration 
-                                    stdOutModuleIdentifier
-                                    Nothing
-                                    Nothing
-                                    Nothing
-                                    Nothing
-                                    (Just stdOutEventSender)
-                                    Nothing
-                                  )
-
-stdOutModuleIdentifier :: EventloopModuleIdentifier
-stdOutModuleIdentifier = "stdout"
-
-
-stdOutEventSender :: EventSender
-stdOutEventSender _ _ _ _ Stop = return ()
-stdOutEventSender sharedConst sharedIOT ioConst ioStateT (OutStdOut (StdOutMessage str))
-    = do
-        safePrint token str
-        hFlush stdout
-    where
+module Eventloop.Module.StdOut.StdOut+    ( setupStdOutModuleConfiguration+    , stdOutModuleIdentifier+    , stdOutEventSender+    ) where++import System.IO++import Control.Concurrent.MVar+import Control.Concurrent.SafePrint++import Eventloop.Module.StdOut.Types+import Eventloop.Types.Common+import Eventloop.Types.Events+import Eventloop.Types.System++setupStdOutModuleConfiguration :: EventloopSetupModuleConfiguration+setupStdOutModuleConfiguration = ( EventloopSetupModuleConfiguration+                                    stdOutModuleIdentifier+                                    Nothing+                                    Nothing+                                    Nothing+                                    Nothing+                                    (Just stdOutEventSender)+                                    Nothing+                                  )++stdOutModuleIdentifier :: EventloopModuleIdentifier+stdOutModuleIdentifier = "stdout"+++stdOutEventSender :: EventSender+stdOutEventSender _ _ _ _ Stop = return ()+stdOutEventSender sharedConst sharedIOT ioConst ioStateT (OutStdOut (StdOutMessage str))+    = do+        safePrint token str+        hFlush stdout+    where         token = safePrintToken sharedConst

@@ -1,8 +1,8 @@-{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
-module Eventloop.Module.StdOut.Types where
-
-import GHC.Generics (Generic)
-import Control.DeepSeq
-
-data StdOutOut = StdOutMessage [Char]
+{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}+module Eventloop.Module.StdOut.Types where++import GHC.Generics (Generic)+import Control.DeepSeq++data StdOutOut = StdOutMessage [Char]             deriving (Eq, Show, Generic, NFData)

@@ -1,7 +1,7 @@-module Eventloop.Module.Timer
-    ( module Eventloop.Module.Timer.Timer
-    , module Eventloop.Module.Timer.Types
-    ) where
-    
-import Eventloop.Module.Timer.Timer
+module Eventloop.Module.Timer+    ( module Eventloop.Module.Timer.Timer+    , module Eventloop.Module.Timer.Types+    ) where++import Eventloop.Module.Timer.Timer import Eventloop.Module.Timer.Types

@@ -1,154 +1,154 @@-module Eventloop.Module.Timer.Timer
-    ( setupTimerModuleConfiguration
-    , timerModuleIdentifier
-    , timerInitializer
-    , timerEventRetriever
-    , timerEventSender
-    , timerTeardown
-    ) where
-
-import Control.Concurrent.Datastructures.BlockingConcurrentQueue
-import Control.Concurrent.STM
-import Control.Concurrent.Timer
-import Control.Concurrent.Suspend.Lifted
-import Data.Maybe
-import Data.List
-
-import Eventloop.Module.Timer.Types
-import Eventloop.Types.Common
-import Eventloop.Types.Events
-import Eventloop.Types.System
-
-
-setupTimerModuleConfiguration :: EventloopSetupModuleConfiguration
-setupTimerModuleConfiguration = ( EventloopSetupModuleConfiguration 
-                                        timerModuleIdentifier
-                                        (Just timerInitializer)
-                                        (Just timerEventRetriever)
-                                        Nothing
-                                        Nothing
-                                        (Just timerEventSender)
-                                        (Just timerTeardown)
-                                 )
-
-timerModuleIdentifier :: EventloopModuleIdentifier
-timerModuleIdentifier = "timer"
-
-                             
-timerInitializer :: Initializer
-timerInitializer sharedConst sharedIO
-    = do
-        inQueue <- createBlockingConcurrentQueue
-        return (sharedConst, sharedIO, TimerConstants inQueue, TimerState [] [])
-                        
-                                
-timerEventRetriever :: EventRetriever
-timerEventRetriever sharedConst sharedIOT ioConst ioStateT
-    = do
-        inTicks <- takeAllFromBlockingConcurrentQueue inQueue
-        ioState <- readTVarIO ioStateT -- This first read is just a snapshot
-        let
-            toStop = map (\(Tick id) -> id) inTicks
-            startedTimers_  = startedTimers ioState
-        sequence $ map (haltTimer startedTimers_) toStop
-        atomically $ do
-            ioState' <- readTVar ioStateT
-            let
-                startedTimers_'  = startedTimers ioState'
-                startedTimers_'' = foldl unregisterTimer startedTimers_' toStop
-            writeTVar ioStateT (ioState'{startedTimers = startedTimers_'})
-
-        return (map InTimer inTicks)
-    where
-        inQueue = tickInQueue ioConst
-
-
-timerEventSender :: EventSender
-timerEventSender _ _ _ _ Stop = return ()
-timerEventSender sharedConst sharedIOT ioConst ioStateT (OutTimer a)
-    = timerEventSender' ioStateT tickBuffer a
-    where
-        tickBuffer = tickInQueue ioConst
-
-                                    
-timerEventSender' :: TVar IOState -> TickBuffer -> TimerOut -> IO ()
-timerEventSender' ioStateT tickBuffer (SetTimer id delay)
-    = do
-        startedTimer <- startTimer tickBuffer id delay (oneShotStart)
-        atomically $ do
-            ioState <- readTVar ioStateT
-            let
-                startedTimers_' = registerTimer (startedTimers ioState) startedTimer
-            writeTVar ioStateT ioState{startedTimers=startedTimers_'}
-
-timerEventSender' ioStateT tickBuffer (SetIntervalTimer id delay)
-    = do
-        startedTimer <- startTimer tickBuffer id delay (repeatedStart)
-        atomically $ do
-            ioState <- readTVar ioStateT
-            let
-                startedITimers_' = registerTimer (startedIntervalTimers ioState) startedTimer
-            writeTVar ioStateT ioState{startedIntervalTimers=startedITimers_'}
-
-timerEventSender' ioStateT tickBuffer (UnsetTimer id)
-    = do
-        ioState <- readTVarIO ioStateT -- This first read is just a snapshot
-        let
-            startedTimers_  = startedTimers ioState
-            startedITimers_ = startedIntervalTimers ioState
-        haltTimer startedTimers_ id
-        haltTimer startedITimers_ id
-        atomically $ do
-            ioState' <- readTVar ioStateT
-            let
-                startedTimers_'  = startedTimers ioState'
-                startedITimers_' = startedIntervalTimers ioState'
-            writeTVar ioStateT ioState'{ startedTimers = startedTimers_'
-                                       , startedIntervalTimers = startedITimers_'
-                                       }
-
-           
-timerTeardown :: Teardown
-timerTeardown sharedConst sharedIO ioConst ioState
-    = do
-        let
-            allStartedTimers = (startedTimers ioState) ++ (startedIntervalTimers ioState)
-            allStartedIds = map fst allStartedTimers
-        sequence_ $ map (haltTimer allStartedTimers) allStartedIds
-        return sharedIO
-
-           
-registerTimer :: [StartedTimer] -> StartedTimer -> [StartedTimer]
-registerTimer startedTimers startedTimer
-    = startedTimers ++ [startedTimer]
-
-
-startTimer :: TickBuffer -> TimerId -> MicroSecondDelay -> TimerStartFunction -> IO StartedTimer
-startTimer incTickBuff id delay startFunc
-    = do
-        timer <- newTimer
-        startFunc timer (tick id incTickBuff) ((usDelay.fromIntegral) delay)
-        return (id, timer)
-
-
-unregisterTimer :: [StartedTimer] -> TimerId -> [StartedTimer]
-unregisterTimer startedTimers id
-    = filter (\(id', _) -> id /= id') startedTimers
-
-
-haltTimer :: [StartedTimer] -> TimerId -> IO ()
-haltTimer startedTimers id
-    = do
-        let
-            startedTimerM = findStartedTimer startedTimers id
-            stopAction (Just (_, timer)) = stopTimer timer
-            stopAction Nothing           = return ()
-        stopAction startedTimerM
-
-
-findStartedTimer :: [StartedTimer] -> TimerId -> Maybe StartedTimer
-findStartedTimer startedTimers id = find (\(id', timer) -> id == id') startedTimers
-                                        
-       
-tick :: TimerId -> TickBuffer -> IO ()
+module Eventloop.Module.Timer.Timer+    ( setupTimerModuleConfiguration+    , timerModuleIdentifier+    , timerInitializer+    , timerEventRetriever+    , timerEventSender+    , timerTeardown+    ) where++import Control.Concurrent.Datastructures.BlockingConcurrentQueue+import Control.Concurrent.STM+import Control.Concurrent.Timer+import Control.Concurrent.Suspend.Lifted+import Data.Maybe+import Data.List++import Eventloop.Module.Timer.Types+import Eventloop.Types.Common+import Eventloop.Types.Events+import Eventloop.Types.System+++setupTimerModuleConfiguration :: EventloopSetupModuleConfiguration+setupTimerModuleConfiguration = ( EventloopSetupModuleConfiguration+                                        timerModuleIdentifier+                                        (Just timerInitializer)+                                        (Just timerEventRetriever)+                                        Nothing+                                        Nothing+                                        (Just timerEventSender)+                                        (Just timerTeardown)+                                 )++timerModuleIdentifier :: EventloopModuleIdentifier+timerModuleIdentifier = "timer"+++timerInitializer :: Initializer+timerInitializer sharedConst sharedIO+    = do+        inQueue <- createBlockingConcurrentQueue+        return (sharedConst, sharedIO, TimerConstants inQueue, TimerState [] [])+++timerEventRetriever :: EventRetriever+timerEventRetriever sharedConst sharedIOT ioConst ioStateT+    = do+        inTicks <- takeAllFromBlockingConcurrentQueue inQueue+        ioState <- readTVarIO ioStateT -- This first read is just a snapshot+        let+            toStop = map (\(Tick id) -> id) inTicks+            startedTimers_  = startedTimers ioState+        sequence $ map (haltTimer startedTimers_) toStop+        atomically $ do+            ioState' <- readTVar ioStateT+            let+                startedTimers_'  = startedTimers ioState'+                startedTimers_'' = foldl unregisterTimer startedTimers_' toStop+            writeTVar ioStateT (ioState'{startedTimers = startedTimers_'})++        return (map InTimer inTicks)+    where+        inQueue = tickInQueue ioConst+++timerEventSender :: EventSender+timerEventSender _ _ _ _ Stop = return ()+timerEventSender sharedConst sharedIOT ioConst ioStateT (OutTimer a)+    = timerEventSender' ioStateT tickBuffer a+    where+        tickBuffer = tickInQueue ioConst+++timerEventSender' :: TVar IOState -> TickBuffer -> TimerOut -> IO ()+timerEventSender' ioStateT tickBuffer (SetTimer id delay)+    = do+        startedTimer <- startTimer tickBuffer id delay (oneShotStart)+        atomically $ do+            ioState <- readTVar ioStateT+            let+                startedTimers_' = registerTimer (startedTimers ioState) startedTimer+            writeTVar ioStateT ioState{startedTimers=startedTimers_'}++timerEventSender' ioStateT tickBuffer (SetIntervalTimer id delay)+    = do+        startedTimer <- startTimer tickBuffer id delay (repeatedStart)+        atomically $ do+            ioState <- readTVar ioStateT+            let+                startedITimers_' = registerTimer (startedIntervalTimers ioState) startedTimer+            writeTVar ioStateT ioState{startedIntervalTimers=startedITimers_'}++timerEventSender' ioStateT tickBuffer (UnsetTimer id)+    = do+        ioState <- readTVarIO ioStateT -- This first read is just a snapshot+        let+            startedTimers_  = startedTimers ioState+            startedITimers_ = startedIntervalTimers ioState+        haltTimer startedTimers_ id+        haltTimer startedITimers_ id+        atomically $ do+            ioState' <- readTVar ioStateT+            let+                startedTimers_'  = startedTimers ioState'+                startedITimers_' = startedIntervalTimers ioState'+            writeTVar ioStateT ioState'{ startedTimers = startedTimers_'+                                       , startedIntervalTimers = startedITimers_'+                                       }+++timerTeardown :: Teardown+timerTeardown sharedConst sharedIO ioConst ioState+    = do+        let+            allStartedTimers = (startedTimers ioState) ++ (startedIntervalTimers ioState)+            allStartedIds = map fst allStartedTimers+        sequence_ $ map (haltTimer allStartedTimers) allStartedIds+        return sharedIO+++registerTimer :: [StartedTimer] -> StartedTimer -> [StartedTimer]+registerTimer startedTimers startedTimer+    = startedTimers ++ [startedTimer]+++startTimer :: TickBuffer -> TimerId -> MicroSecondDelay -> TimerStartFunction -> IO StartedTimer+startTimer incTickBuff id delay startFunc+    = do+        timer <- newTimer+        startFunc timer (tick id incTickBuff) ((usDelay.fromIntegral) delay)+        return (id, timer)+++unregisterTimer :: [StartedTimer] -> TimerId -> [StartedTimer]+unregisterTimer startedTimers id+    = filter (\(id', _) -> id /= id') startedTimers+++haltTimer :: [StartedTimer] -> TimerId -> IO ()+haltTimer startedTimers id+    = do+        let+            startedTimerM = findStartedTimer startedTimers id+            stopAction (Just (_, timer)) = stopTimer timer+            stopAction Nothing           = return ()+        stopAction startedTimerM+++findStartedTimer :: [StartedTimer] -> TimerId -> Maybe StartedTimer+findStartedTimer startedTimers id = find (\(id', timer) -> id == id') startedTimers+++tick :: TimerId -> TickBuffer -> IO () tick id tickBuffer = putInBlockingConcurrentQueue tickBuffer (Tick id)

@@ -1,23 +1,23 @@-{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
-module Eventloop.Module.Timer.Types where
-
-import GHC.Generics (Generic)
-import Control.DeepSeq
-
-import Control.Concurrent.Datastructures.BlockingConcurrentQueue
-import Control.Concurrent.Timer
-import Control.Concurrent.Suspend.Lifted
-    
-type MicroSecondDelay = Int -- Microseconds
-type TimerId = [Char]
-type TickBuffer = BlockingConcurrentQueue TimerIn
-type StartedTimer = (TimerId, TimerIO)
-type TimerStartFunction = (TimerIO -> IO () -> Delay -> IO Bool)
-
-data TimerIn = Tick TimerId
-             deriving (Eq, Show)
-             
-data TimerOut = SetTimer TimerId MicroSecondDelay
-              | SetIntervalTimer TimerId MicroSecondDelay
-              | UnsetTimer TimerId
+{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}+module Eventloop.Module.Timer.Types where++import GHC.Generics (Generic)+import Control.DeepSeq++import Control.Concurrent.Datastructures.BlockingConcurrentQueue+import Control.Concurrent.Timer+import Control.Concurrent.Suspend.Lifted++type MicroSecondDelay = Int -- Microseconds+type TimerId = [Char]+type TickBuffer = BlockingConcurrentQueue TimerIn+type StartedTimer = (TimerId, TimerIO)+type TimerStartFunction = (TimerIO -> IO () -> Delay -> IO Bool)++data TimerIn = Tick TimerId+             deriving (Eq, Show)++data TimerOut = SetTimer TimerId MicroSecondDelay+              | SetIntervalTimer TimerId MicroSecondDelay+              | UnsetTimer TimerId               deriving (Eq, Show, Generic, NFData)

@@ -1,7 +1,7 @@-module Eventloop.Module.Websocket.Canvas
-    ( module Eventloop.Module.Websocket.Canvas.Canvas
-    , module Eventloop.Module.Websocket.Canvas.Types
-    ) where
-    
-import Eventloop.Module.Websocket.Canvas.Canvas
+module Eventloop.Module.Websocket.Canvas+    ( module Eventloop.Module.Websocket.Canvas.Canvas+    , module Eventloop.Module.Websocket.Canvas.Types+    ) where+    +import Eventloop.Module.Websocket.Canvas.Canvas import Eventloop.Module.Websocket.Canvas.Types

@@ -1,132 +1,132 @@-module Eventloop.Module.Websocket.Canvas.Canvas
-    ( setupCanvasModuleConfiguration
-    , canvasModuleIdentifier
-    , canvasInitializer
-    , canvasEventRetriever
-    , canvasEventSender
-    ) where
-
-    
-import Control.Concurrent
-import Control.Concurrent.MVar
-import Control.Concurrent.SafePrint
-import Control.Concurrent.Thread
-import Data.Aeson
-import Data.Maybe
-import qualified Data.ByteString.Lazy.Char8 as LBS
-
-import Eventloop.Module.Websocket.Canvas.Types
-import Eventloop.Module.Websocket.Canvas.JSONEncoding
-import Eventloop.Types.Common
-import Eventloop.Types.Events
-import Eventloop.Types.System
-import Eventloop.Utility.Config
-import Eventloop.Utility.Websockets
-
-
-setupCanvasModuleConfiguration :: EventloopSetupModuleConfiguration
-setupCanvasModuleConfiguration = ( EventloopSetupModuleConfiguration 
-                                        canvasModuleIdentifier
-                                        (Just canvasInitializer)
-                                        (Just canvasEventRetriever)
-                                        Nothing
-                                        Nothing
-                                        (Just canvasEventSender)
-                                        (Just canvasTeardown)
-                                      )
-                                      
-                                      
-canvasModuleIdentifier :: EventloopModuleIdentifier
-canvasModuleIdentifier = "canvas"
-
-
-canvasInitializer :: Initializer
-canvasInitializer sharedConst sharedIO
-    = do
-        (clientSocket, clientConn, serverSock) <- setupWebsocketConnection iNADDR_ANY canvasPort
-        safePrintLn (safePrintToken sharedConst) "Canvas connection successfull!"
-        sysRecvBuffer <- newEmptyMVar
-        measureTextLock <- newMVar ()
-        let
-            ioConst = CanvasConstants sysRecvBuffer clientSocket clientConn serverSock
-            measureText_' = measureText_ ioConst measureTextLock
-            sharedConst' = sharedConst{measureText = measureText_'}
-        return (sharedConst', sharedIO, ioConst, NoState)
-
-
-canvasEventRetriever :: EventRetriever
-canvasEventRetriever sharedConst sharedIOT ioConst ioStateT
-    = do
-        isConnected <- isConnected sock
-        case isConnected of
-            False -> return []
-            True -> do
-                messageM <- takeMessage safePrintToken_ sock conn
-                case messageM of
-                    Nothing -> return []
-                    (Just message) -> do
-                                        let
-                                            inRouted = fromJust.decode $ LBS.pack message
-                                        inCanvasM <- route sysBuffer inRouted
-                                        case inCanvasM of
-                                            Nothing         -> return []
-                                            (Just inCanvas) -> return [InCanvas inCanvas]
-    where
-        sock = clientSocket ioConst
-        conn = clientConnection ioConst
-        sysBuffer = canvasSystemReceiveBuffer ioConst
-        safePrintToken_ = safePrintToken sharedConst
-
-
-canvasEventSender :: EventSender
-canvasEventSender sharedConst sharedIOT ioConst ioStateT (OutCanvas canvasOut)
-    = sendRoutedMessageOut conn (OutUserCanvas canvasOut)
-    where
-        conn = clientConnection ioConst
-
-canvasEventSender sharedConst sharedIOT ioConst ioStateT Stop
-    = do
-        closeWebsocketConnection safePrintToken_ serverSock clientSock conn
-    where
-        serverSock = serverSocket ioConst
-        clientSock = clientSocket ioConst
-        conn = clientConnection ioConst
-        safePrintToken_ = safePrintToken sharedConst
-
-
-canvasTeardown :: Teardown
-canvasTeardown sharedConst sharedIO ioConst ioState
-    = do
-        destroyWebsocketConnection serverSock clientSock
-        return sharedIO
-    where
-        serverSock = serverSocket ioConst
-        clientSock = clientSocket ioConst
-        conn = clientConnection ioConst
-
-
-sendRoutedMessageOut :: Connection -> RoutedMessageOut -> IO ()
-sendRoutedMessageOut conn out = writeMessage conn $ LBS.unpack $ encode out
-
-
-route :: CanvasSystemReceiveBuffer -> RoutedMessageIn -> IO (Maybe CanvasIn)
-route sysRecvBuffer routedIn
-    = case routedIn of
-        (InUserCanvas canvasIn)   -> return (Just canvasIn)
-        (InSystemCanvas canvasIn) -> do
-                                        putMVar sysRecvBuffer canvasIn
-                                        return Nothing
-
-
-measureText_ :: IOConstants -> MVar () -> CanvasText -> IO ScreenDimensions
-measureText_ ioConst lock canvasText
-    = do
-        lock_ <- takeMVar lock
-        sendRoutedMessageOut conn outMsg
-        (SystemMeasuredText _ screenDims) <- takeMVar buf
-        putMVar lock lock_
-        return screenDims
-    where
-        conn = clientConnection ioConst
-        buf = canvasSystemReceiveBuffer ioConst
+module Eventloop.Module.Websocket.Canvas.Canvas+    ( setupCanvasModuleConfiguration+    , canvasModuleIdentifier+    , canvasInitializer+    , canvasEventRetriever+    , canvasEventSender+    ) where+++import Control.Concurrent+import Control.Concurrent.MVar+import Control.Concurrent.SafePrint+import Control.Concurrent.Thread+import Data.Aeson+import Data.Maybe+import qualified Data.ByteString.Lazy.Char8 as LBS++import Eventloop.Module.Websocket.Canvas.Types+import Eventloop.Module.Websocket.Canvas.JSONEncoding+import Eventloop.Types.Common+import Eventloop.Types.Events+import Eventloop.Types.System+import Eventloop.Utility.Config+import Eventloop.Utility.Websockets+++setupCanvasModuleConfiguration :: EventloopSetupModuleConfiguration+setupCanvasModuleConfiguration = ( EventloopSetupModuleConfiguration+                                        canvasModuleIdentifier+                                        (Just canvasInitializer)+                                        (Just canvasEventRetriever)+                                        Nothing+                                        Nothing+                                        (Just canvasEventSender)+                                        (Just canvasTeardown)+                                      )+++canvasModuleIdentifier :: EventloopModuleIdentifier+canvasModuleIdentifier = "canvas"+++canvasInitializer :: Initializer+canvasInitializer sharedConst sharedIO+    = do+        (clientSocket, clientConn, serverSock) <- setupWebsocketConnection iNADDR_ANY canvasPort+        safePrintLn (safePrintToken sharedConst) "Canvas connection successfull!"+        sysRecvBuffer <- newEmptyMVar+        measureTextLock <- newMVar ()+        let+            ioConst = CanvasConstants sysRecvBuffer clientSocket clientConn serverSock+            measureText_' = measureText_ ioConst measureTextLock+            sharedConst' = sharedConst{measureText = measureText_'}+        return (sharedConst', sharedIO, ioConst, NoState)+++canvasEventRetriever :: EventRetriever+canvasEventRetriever sharedConst sharedIOT ioConst ioStateT+    = do+        isConnected <- isConnected sock+        case isConnected of+            False -> return []+            True -> do+                messageM <- takeMessage safePrintToken_ sock conn+                case messageM of+                    Nothing -> return []+                    (Just message) -> do+                                        let+                                            inRouted = fromJust.decode $ LBS.pack message+                                        inCanvasM <- route sysBuffer inRouted+                                        case inCanvasM of+                                            Nothing         -> return []+                                            (Just inCanvas) -> return [InCanvas inCanvas]+    where+        sock = clientSocket ioConst+        conn = clientConnection ioConst+        sysBuffer = canvasSystemReceiveBuffer ioConst+        safePrintToken_ = safePrintToken sharedConst+++canvasEventSender :: EventSender+canvasEventSender sharedConst sharedIOT ioConst ioStateT (OutCanvas canvasOut)+    = sendRoutedMessageOut conn (OutUserCanvas canvasOut)+    where+        conn = clientConnection ioConst++canvasEventSender sharedConst sharedIOT ioConst ioStateT Stop+    = do+        closeWebsocketConnection safePrintToken_ serverSock clientSock conn+    where+        serverSock = serverSocket ioConst+        clientSock = clientSocket ioConst+        conn = clientConnection ioConst+        safePrintToken_ = safePrintToken sharedConst+++canvasTeardown :: Teardown+canvasTeardown sharedConst sharedIO ioConst ioState+    = do+        destroyWebsocketConnection serverSock clientSock+        return sharedIO+    where+        serverSock = serverSocket ioConst+        clientSock = clientSocket ioConst+        conn = clientConnection ioConst+++sendRoutedMessageOut :: Connection -> RoutedMessageOut -> IO ()+sendRoutedMessageOut conn out = writeMessage conn $ LBS.unpack $ encode out+++route :: CanvasSystemReceiveBuffer -> RoutedMessageIn -> IO (Maybe CanvasIn)+route sysRecvBuffer routedIn+    = case routedIn of+        (InUserCanvas canvasIn)   -> return (Just canvasIn)+        (InSystemCanvas canvasIn) -> do+                                        putMVar sysRecvBuffer canvasIn+                                        return Nothing+++measureText_ :: IOConstants -> MVar () -> CanvasText -> IO ScreenDimensions+measureText_ ioConst lock canvasText+    = do+        lock_ <- takeMVar lock+        sendRoutedMessageOut conn outMsg+        (SystemMeasuredText _ screenDims) <- takeMVar buf+        putMVar lock lock_+        return screenDims+    where+        conn = clientConnection ioConst+        buf = canvasSystemReceiveBuffer ioConst         outMsg = OutSystemCanvas $ SystemMeasureText canvasText

@@ -1,233 +1,233 @@-{-# LANGUAGE OverloadedStrings #-}
-module Eventloop.Module.Websocket.Canvas.JSONEncoding where
-
-import Data.Aeson
-import Data.Aeson.Types
-import Control.Applicative
-import Control.Monad
-
-import Eventloop.Module.Websocket.Canvas.Types
-import Eventloop.Module.Websocket.Canvas.Opcode
-
-
-instance FromJSON RoutedMessageIn where
-    parseJSON (Object v) = do
-                            route <- v .: "r" :: Parser [Char]
-                            obj <- v .: "o"
-                            case route of
-                                        "s" -> InSystemCanvas <$> (parseJSON obj)
-                                        "u" -> InUserCanvas <$> (parseJSON obj)
-
-instance FromJSON SystemCanvasIn where
-    parseJSON (Object v) = do
-                            opCode <- v .: "t" :: Parser Int
-                            case opCode of
-                                        2101 -> SystemMeasuredText <$> (v .: "canvastext" >>= parseJSON)
-                                                                   <*> ( (\width height -> (width, height))
-                                                                        <$> v .: "width"
-                                                                        <*> v .: "height"
-                                                                       )
-
-instance FromJSON CanvasIn where
-    parseJSON (Object v) = do
-                            opCode <- v .: "t" :: Parser Int
-                            case opCode of
-                                        101 -> MeasuredText <$> (v .: "canvastext" >>= parseJSON)
-                                                            <*> ( (\width height -> (width, height)) 
-                                                                <$> v .: "width"
-                                                                <*> v .: "height"
-                                                                )
-
-instance FromJSON CanvasText where
-    parseJSON (Object v) = CanvasText <$>  v .: "text" <*> (v .: "font" >>= parseJSON) <*> (v .: "alignment" >>= parseJSON)
-
-    
-instance FromJSON Font where
-    parseJSON (Object v) = Font <$> v .: "fontfamily" <*> v .: "fontsize"
-
-    
-instance FromJSON Alignment where
-    parseJSON (Object v) = do
-                            alignment <- v .: "t" :: Parser Int
-                            return $ case alignment of
-                                        1501 -> AlignLeft
-                                        1502 -> AlignRight
-                                        1503 -> AlignCenter
-                            
-    
-    
-operationObject :: Opcode -> [Value] -> Value
-operationObject opcode []               = object ["t" .= opcode]
-operationObject opcode encodedArguments = object ["t" .= opcode, "a" .= encodedArguments]
-
-
-instance ToJSON RoutedMessageOut where
-    toJSON d@(OutUserCanvas canvasOut)   = object ["r" .= route, "o" .= canvasOut]
-                                        where
-                                            route = "u" :: [Char]
-    toJSON d@(OutSystemCanvas canvasOut) = object ["r" .= route, "o" .= canvasOut]
-                                        where
-                                            route = "s" :: [Char]
-
-
-instance ToJSON SystemCanvasOut where
-    toJSON d@(SystemMeasureText canvasText) = operationObject (toOpcode d) [ toJSON canvasText
-                                                                           ]
-
-
-instance ToJSON CanvasOut where
-    toJSON d@(SetupCanvas canvasId zIndex screenDimensions cssPosition) = operationObject (toOpcode d) [ toJSON canvasId
-                                                                                                       , toJSON zIndex
-                                                                                                       , toJSON screenDimensions
-                                                                                                       , toJSON cssPosition
-                                                                                                       ]
-    toJSON d@(TeardownCanvas canvasId) = operationObject (toOpcode d) [toJSON canvasId]
-    toJSON d@(CanvasOperations canvasId canvasOperations) = operationObject (toOpcode d) [ toJSON canvasId
-                                                                                         , toJSON canvasOperations
-                                                                                         ]
-    toJSON d@(MeasureText text) = operationObject (toOpcode d) [ toJSON text
-                                                               ]
-
-    
-instance ToJSON CanvasOperation where
-    toJSON d@(DrawPath screenStartingPoint screenPathParts pathStroke pathFill) = operationObject (toOpcode d) [ toJSON screenStartingPoint
-                                                                                                               , toJSON screenPathParts
-                                                                                                               , toJSON pathStroke
-                                                                                                               , toJSON pathFill
-                                                                                                               ]
-    toJSON d@(DrawText canvasText screenPoint textStroke textFill) = operationObject (toOpcode d) [ toJSON canvasText
-                                                                                                  , toJSON screenPoint
-                                                                                                  , toJSON textStroke
-                                                                                                  , toJSON textFill
-                                                                                                  ]
-    toJSON d@(DoTransform canvasTransform) = operationObject (toOpcode d) [toJSON canvasTransform]
-    toJSON d@(Clear clearPart) = operationObject (toOpcode d) [toJSON clearPart]
-    toJSON d@(Frame) = operationObject (toOpcode d) []
-
-    
-instance ToJSON ScreenPathPart where
-    toJSON d@(MoveTo screenPoint) = operationObject (toOpcode d) [toJSON screenPoint]
-    toJSON d@(LineTo screenPoint) = operationObject (toOpcode d) [toJSON screenPoint]
-    toJSON d@(BezierCurveTo screenControlPoint1 screenControlPoint2 screenEndPoint) = operationObject (toOpcode d) [ toJSON screenControlPoint1
-                                                                                                                   , toJSON screenControlPoint2
-                                                                                                                   , toJSON screenEndPoint
-                                                                                                                   ]
-    toJSON d@(QuadraticCurveTo screenControlPoint screenEndPoint) = operationObject (toOpcode d) [ toJSON screenControlPoint
-                                                                                                  , toJSON screenEndPoint
-                                                                                                  ]
-    toJSON d@(ArcTo screenControlPoint1 screenControlPoint2 screenRadius) = operationObject (toOpcode d) [ toJSON screenControlPoint1
-                                                                                                         , toJSON screenControlPoint2
-                                                                                                         , toJSON screenRadius
-                                                                                                         ]
-    toJSON d@(Arc screenCircle screenStartingAngle screenEndAngle) = operationObject (toOpcode d) [ toJSON screenCircle
-                                                                                                  , toJSON screenStartingAngle
-                                                                                                  , toJSON screenEndAngle
-                                                                                                  ]
-    toJSON d@(Rectangle screenPoint screenDimensions) = operationObject (toOpcode d) [ toJSON screenPoint
-                                                                                     , toJSON screenDimensions
-                                                                                     ]
-    toJSON d@(ClosePath) = operationObject (toOpcode d) []
-
-instance ToJSON PathStroke where
-    toJSON d@(PathStroke screenLineThickness pathRenderStrokeStyle) = operationObject (toOpcode d) [ toJSON screenLineThickness
-                                                                                                   , toJSON pathRenderStrokeStyle
-                                                                                                   ]
-    toJSON d = operationObject (toOpcode d) []
-
-    
-instance ToJSON PathFill where
-    toJSON d@(PathFill pathRenderFillStyle) = operationObject (toOpcode d) [toJSON pathRenderFillStyle]
-    toJSON d = operationObject (toOpcode d) []
-    
-
-instance ToJSON RenderStyle where
-    toJSON d@(CanvasColor screenColor) = operationObject (toOpcode d) [toJSON screenColor]
-    toJSON d@(CanvasGradient canvasGradientType canvasColorStops) = operationObject (toOpcode d) [ toJSON canvasGradientType
-                                                                                                 , toJSON canvasColorStops
-                                                                                                 ]
-                                                                                                 
-    toJSON d@(CanvasPattern canvasImage patternRepetition) = operationObject (toOpcode d) [ toJSON canvasImage
-                                                                                          , toJSON patternRepetition
-                                                                                          ]
-
-    
-instance ToJSON CanvasImage where
-    toJSON d@(CanvasElement canvasId screenPoint screenDimensions) = operationObject (toOpcode d) [ toJSON canvasId
-                                                                                                  , toJSON screenPoint
-                                                                                                  , toJSON screenDimensions
-                                                                                                  ]
-                                                                                                  
-    toJSON d@(ImageData screenDimensions screenPixels) = operationObject (toOpcode d) [ toJSON screenDimensions
-                                                                                      , toJSON screenPixels
-                                                                                      ]
-
-instance ToJSON PatternRepetition where
-    toJSON d = operationObject (toOpcode d) []
-
-
-instance ToJSON CanvasGradientType where
-    toJSON d@(RadialGradient screenCircle1 screenCircle2) = operationObject (toOpcode d) [ toJSON screenCircle1
-                                                                                         , toJSON screenCircle2 
-                                                                                         ]
-                                                                                         
-    toJSON d@(LinearGradient screenPoint1 screenPoint2) = operationObject (toOpcode d) [ toJSON screenPoint1
-                                                                                       , toJSON screenPoint2 
-                                                                                       ]
-
-
-instance ToJSON CanvasText where
-    toJSON d@(CanvasText text font alignment) = operationObject (toOpcode d) [ toJSON text
-                                                                             , toJSON font
-                                                                             , toJSON alignment
-                                                                             ]
-
-
-instance ToJSON Font where
-    toJSON d@(Font fontFamily fontSize) = operationObject (toOpcode d) [ toJSON fontFamily
-                                                                       , toJSON fontSize
-                                                                       ]
-
-    
-instance ToJSON TextStroke where
-    toJSON d@(TextStroke screenLineThickness textRenderStyle) = operationObject (toOpcode d) [ toJSON screenLineThickness
-                                                                                             , toJSON textRenderStyle
-                                                                                             ]
-    toJSON d@(NoTextStroke) = operationObject (toOpcode d) []
-
-instance ToJSON TextFill where
-    toJSON d@(TextFill textRenderStyle) = operationObject (toOpcode d) [ toJSON textRenderStyle
-                                                                       ]
-    toJSON d@(NoTextFill) = operationObject (toOpcode d) []
-    
-    
-instance ToJSON Alignment where
-    toJSON d = operationObject (toOpcode d) []
-
-    
-instance ToJSON CanvasTransform where
-    toJSON d@(Translate screenPoint) = operationObject (toOpcode d) [toJSON screenPoint]
-    toJSON d@(Rotate screenAngle)    = operationObject (toOpcode d) [toJSON screenAngle]
-    toJSON d@(Scale x y)             = operationObject (toOpcode d) [toJSON x, toJSON y]
-    toJSON d@(Transform tm)          = operationObject (toOpcode d) [toJSON tm]
-    toJSON d@(SetTransform tm)       = operationObject (toOpcode d) [toJSON tm]
-    toJSON d                         = operationObject (toOpcode d) []
-    
-    
-instance ToJSON CSSPosition where
-    toJSON d@(CSSPosition cssBindPoint cssMeasurements) = operationObject (toOpcode d) [ toJSON cssBindPoint
-                                                                                       , toJSON cssMeasurements
-                                                                                       ]
-
-instance ToJSON CSSBindPoint where
-    toJSON d = operationObject (toOpcode d) []
-                                                                                      
-instance ToJSON CSSUnit where
-    toJSON d@(CSSPixels i)     = operationObject (toOpcode d) [toJSON i]
-    toJSON d@(CSSPercentage i) = operationObject (toOpcode d) [toJSON i]
-    
-    
-instance ToJSON ClearPart where
-    toJSON d@(ClearRectangle screenPoint screenDimensions) = operationObject (toOpcode d) [ toJSON screenPoint
-                                                                                          , toJSON screenDimensions
-                                                                                          ]
+{-# LANGUAGE OverloadedStrings #-}+module Eventloop.Module.Websocket.Canvas.JSONEncoding where++import Data.Aeson+import Data.Aeson.Types+import Control.Applicative+import Control.Monad++import Eventloop.Module.Websocket.Canvas.Types+import Eventloop.Module.Websocket.Canvas.Opcode+++instance FromJSON RoutedMessageIn where+    parseJSON (Object v) = do+                            route <- v .: "r" :: Parser [Char]+                            obj <- v .: "o"+                            case route of+                                        "s" -> InSystemCanvas <$> (parseJSON obj)+                                        "u" -> InUserCanvas <$> (parseJSON obj)++instance FromJSON SystemCanvasIn where+    parseJSON (Object v) = do+                            opCode <- v .: "t" :: Parser Int+                            case opCode of+                                        2101 -> SystemMeasuredText <$> (v .: "canvastext" >>= parseJSON)+                                                                   <*> ( (\width height -> (width, height))+                                                                        <$> v .: "width"+                                                                        <*> v .: "height"+                                                                       )++instance FromJSON CanvasIn where+    parseJSON (Object v) = do+                            opCode <- v .: "t" :: Parser Int+                            case opCode of+                                        101 -> MeasuredText <$> (v .: "canvastext" >>= parseJSON)+                                                            <*> ( (\width height -> (width, height))+                                                                <$> v .: "width"+                                                                <*> v .: "height"+                                                                )++instance FromJSON CanvasText where+    parseJSON (Object v) = CanvasText <$>  v .: "text" <*> (v .: "font" >>= parseJSON) <*> (v .: "alignment" >>= parseJSON)+++instance FromJSON Font where+    parseJSON (Object v) = Font <$> v .: "fontfamily" <*> v .: "fontsize"+++instance FromJSON Alignment where+    parseJSON (Object v) = do+                            alignment <- v .: "t" :: Parser Int+                            return $ case alignment of+                                        1501 -> AlignLeft+                                        1502 -> AlignRight+                                        1503 -> AlignCenter++++operationObject :: Opcode -> [Value] -> Value+operationObject opcode []               = object ["t" .= opcode]+operationObject opcode encodedArguments = object ["t" .= opcode, "a" .= encodedArguments]+++instance ToJSON RoutedMessageOut where+    toJSON d@(OutUserCanvas canvasOut)   = object ["r" .= route, "o" .= canvasOut]+                                        where+                                            route = "u" :: [Char]+    toJSON d@(OutSystemCanvas canvasOut) = object ["r" .= route, "o" .= canvasOut]+                                        where+                                            route = "s" :: [Char]+++instance ToJSON SystemCanvasOut where+    toJSON d@(SystemMeasureText canvasText) = operationObject (toOpcode d) [ toJSON canvasText+                                                                           ]+++instance ToJSON CanvasOut where+    toJSON d@(SetupCanvas canvasId zIndex screenDimensions cssPosition) = operationObject (toOpcode d) [ toJSON canvasId+                                                                                                       , toJSON zIndex+                                                                                                       , toJSON screenDimensions+                                                                                                       , toJSON cssPosition+                                                                                                       ]+    toJSON d@(TeardownCanvas canvasId) = operationObject (toOpcode d) [toJSON canvasId]+    toJSON d@(CanvasOperations canvasId canvasOperations) = operationObject (toOpcode d) [ toJSON canvasId+                                                                                         , toJSON canvasOperations+                                                                                         ]+    toJSON d@(MeasureText text) = operationObject (toOpcode d) [ toJSON text+                                                               ]+++instance ToJSON CanvasOperation where+    toJSON d@(DrawPath screenStartingPoint screenPathParts pathStroke pathFill) = operationObject (toOpcode d) [ toJSON screenStartingPoint+                                                                                                               , toJSON screenPathParts+                                                                                                               , toJSON pathStroke+                                                                                                               , toJSON pathFill+                                                                                                               ]+    toJSON d@(DrawText canvasText screenPoint textStroke textFill) = operationObject (toOpcode d) [ toJSON canvasText+                                                                                                  , toJSON screenPoint+                                                                                                  , toJSON textStroke+                                                                                                  , toJSON textFill+                                                                                                  ]+    toJSON d@(DoTransform canvasTransform) = operationObject (toOpcode d) [toJSON canvasTransform]+    toJSON d@(Clear clearPart) = operationObject (toOpcode d) [toJSON clearPart]+    toJSON d@(Frame) = operationObject (toOpcode d) []+++instance ToJSON ScreenPathPart where+    toJSON d@(MoveTo screenPoint) = operationObject (toOpcode d) [toJSON screenPoint]+    toJSON d@(LineTo screenPoint) = operationObject (toOpcode d) [toJSON screenPoint]+    toJSON d@(BezierCurveTo screenControlPoint1 screenControlPoint2 screenEndPoint) = operationObject (toOpcode d) [ toJSON screenControlPoint1+                                                                                                                   , toJSON screenControlPoint2+                                                                                                                   , toJSON screenEndPoint+                                                                                                                   ]+    toJSON d@(QuadraticCurveTo screenControlPoint screenEndPoint) = operationObject (toOpcode d) [ toJSON screenControlPoint+                                                                                                  , toJSON screenEndPoint+                                                                                                  ]+    toJSON d@(ArcTo screenControlPoint1 screenControlPoint2 screenRadius) = operationObject (toOpcode d) [ toJSON screenControlPoint1+                                                                                                         , toJSON screenControlPoint2+                                                                                                         , toJSON screenRadius+                                                                                                         ]+    toJSON d@(Arc screenCircle screenStartingAngle screenEndAngle) = operationObject (toOpcode d) [ toJSON screenCircle+                                                                                                  , toJSON screenStartingAngle+                                                                                                  , toJSON screenEndAngle+                                                                                                  ]+    toJSON d@(Rectangle screenPoint screenDimensions) = operationObject (toOpcode d) [ toJSON screenPoint+                                                                                     , toJSON screenDimensions+                                                                                     ]+    toJSON d@(ClosePath) = operationObject (toOpcode d) []++instance ToJSON PathStroke where+    toJSON d@(PathStroke screenLineThickness pathRenderStrokeStyle) = operationObject (toOpcode d) [ toJSON screenLineThickness+                                                                                                   , toJSON pathRenderStrokeStyle+                                                                                                   ]+    toJSON d = operationObject (toOpcode d) []+++instance ToJSON PathFill where+    toJSON d@(PathFill pathRenderFillStyle) = operationObject (toOpcode d) [toJSON pathRenderFillStyle]+    toJSON d = operationObject (toOpcode d) []+++instance ToJSON RenderStyle where+    toJSON d@(CanvasColor screenColor) = operationObject (toOpcode d) [toJSON screenColor]+    toJSON d@(CanvasGradient canvasGradientType canvasColorStops) = operationObject (toOpcode d) [ toJSON canvasGradientType+                                                                                                 , toJSON canvasColorStops+                                                                                                 ]++    toJSON d@(CanvasPattern canvasImage patternRepetition) = operationObject (toOpcode d) [ toJSON canvasImage+                                                                                          , toJSON patternRepetition+                                                                                          ]+++instance ToJSON CanvasImage where+    toJSON d@(CanvasElement canvasId screenPoint screenDimensions) = operationObject (toOpcode d) [ toJSON canvasId+                                                                                                  , toJSON screenPoint+                                                                                                  , toJSON screenDimensions+                                                                                                  ]++    toJSON d@(ImageData screenDimensions screenPixels) = operationObject (toOpcode d) [ toJSON screenDimensions+                                                                                      , toJSON screenPixels+                                                                                      ]++instance ToJSON PatternRepetition where+    toJSON d = operationObject (toOpcode d) []+++instance ToJSON CanvasGradientType where+    toJSON d@(RadialGradient screenCircle1 screenCircle2) = operationObject (toOpcode d) [ toJSON screenCircle1+                                                                                         , toJSON screenCircle2+                                                                                         ]++    toJSON d@(LinearGradient screenPoint1 screenPoint2) = operationObject (toOpcode d) [ toJSON screenPoint1+                                                                                       , toJSON screenPoint2+                                                                                       ]+++instance ToJSON CanvasText where+    toJSON d@(CanvasText text font alignment) = operationObject (toOpcode d) [ toJSON text+                                                                             , toJSON font+                                                                             , toJSON alignment+                                                                             ]+++instance ToJSON Font where+    toJSON d@(Font fontFamily fontSize) = operationObject (toOpcode d) [ toJSON fontFamily+                                                                       , toJSON fontSize+                                                                       ]+++instance ToJSON TextStroke where+    toJSON d@(TextStroke screenLineThickness textRenderStyle) = operationObject (toOpcode d) [ toJSON screenLineThickness+                                                                                             , toJSON textRenderStyle+                                                                                             ]+    toJSON d@(NoTextStroke) = operationObject (toOpcode d) []++instance ToJSON TextFill where+    toJSON d@(TextFill textRenderStyle) = operationObject (toOpcode d) [ toJSON textRenderStyle+                                                                       ]+    toJSON d@(NoTextFill) = operationObject (toOpcode d) []+++instance ToJSON Alignment where+    toJSON d = operationObject (toOpcode d) []+++instance ToJSON CanvasTransform where+    toJSON d@(Translate screenPoint) = operationObject (toOpcode d) [toJSON screenPoint]+    toJSON d@(Rotate screenAngle)    = operationObject (toOpcode d) [toJSON screenAngle]+    toJSON d@(Scale x y)             = operationObject (toOpcode d) [toJSON x, toJSON y]+    toJSON d@(Transform tm)          = operationObject (toOpcode d) [toJSON tm]+    toJSON d@(SetTransform tm)       = operationObject (toOpcode d) [toJSON tm]+    toJSON d                         = operationObject (toOpcode d) []+++instance ToJSON CSSPosition where+    toJSON d@(CSSPosition cssBindPoint cssMeasurements) = operationObject (toOpcode d) [ toJSON cssBindPoint+                                                                                       , toJSON cssMeasurements+                                                                                       ]++instance ToJSON CSSBindPoint where+    toJSON d = operationObject (toOpcode d) []++instance ToJSON CSSUnit where+    toJSON d@(CSSPixels i)     = operationObject (toOpcode d) [toJSON i]+    toJSON d@(CSSPercentage i) = operationObject (toOpcode d) [toJSON i]+++instance ToJSON ClearPart where+    toJSON d@(ClearRectangle screenPoint screenDimensions) = operationObject (toOpcode d) [ toJSON screenPoint+                                                                                          , toJSON screenDimensions+                                                                                          ]     toJSON d = operationObject (toOpcode d) []

@@ -1,104 +1,104 @@-module Eventloop.Module.Websocket.Canvas.Opcode where
-
-import Eventloop.Module.Websocket.Canvas.Types
-
-class ToOpcode a where
-    toOpcode :: a -> Opcode
-
-    
-instance ToOpcode SystemCanvasOut where
-    toOpcode (SystemMeasureText _) = 2001
-
-instance ToOpcode CanvasOut where
-    toOpcode (SetupCanvas _ _ _ _)  = 201
-    toOpcode (TeardownCanvas _)     = 202
-    toOpcode (CanvasOperations _ _) = 203
-    toOpcode (MeasureText _)        = 204
-
-instance ToOpcode CanvasOperation where
-    toOpcode (DrawPath _ _ _ _) = 301
-    toOpcode (DrawText _ _ _ _) = 302
-    toOpcode (DoTransform _)    = 303
-    toOpcode (Clear _)          = 304
-    toOpcode (Frame)            = 305
-
-instance ToOpcode ScreenPathPart where
-    toOpcode (MoveTo _)              = 401
-    toOpcode (LineTo _)              = 402
-    toOpcode (BezierCurveTo _ _ _)   = 403
-    toOpcode (QuadraticCurveTo _ _)  = 404
-    toOpcode (ArcTo _ _ _)           = 405
-    toOpcode (Arc _ _ _)             = 406
-    toOpcode (Rectangle _ _)         = 407
-    toOpcode (ClosePath)             = 408
-
-instance ToOpcode PathStroke where
-    toOpcode (PathStroke _ _) = 501
-    toOpcode (NoPathStroke) = 502
-
-instance ToOpcode PathFill where
-    toOpcode (PathFill _) = 601
-    toOpcode (NoPathFill) = 602
-
-instance ToOpcode RenderStyle where
-    toOpcode (CanvasColor _)      = 701
-    toOpcode (CanvasGradient _ _) = 702
-    toOpcode (CanvasPattern _ _)  = 703
-
-instance ToOpcode CanvasImage where
-    toOpcode (CanvasElement _ _ _) = 801
-    toOpcode (ImageData _ _)       = 802
-
-instance ToOpcode PatternRepetition where
-    toOpcode (Repeat)   = 901
-    toOpcode (RepeatX)  = 902
-    toOpcode (RepeatY)  = 903
-    toOpcode (NoRepeat) = 0904
-    
-instance ToOpcode CanvasGradientType where
-    toOpcode (RadialGradient _ _) = 1001
-    toOpcode (LinearGradient _ _) = 1002
-    
-instance ToOpcode CanvasText where
-    toOpcode (CanvasText _ _ _) = 1201
-    
-instance ToOpcode Font where
-    toOpcode (Font _ _) = 1301
-    
-instance ToOpcode TextStroke where
-    toOpcode (TextStroke _ _) = 1401
-    toOpcode (NoTextStroke)   = 1402
-    
-instance ToOpcode TextFill where
-    toOpcode (TextFill _) = 2401
-    toOpcode (NoTextFill) = 2402
-    
-instance ToOpcode Alignment where
-    toOpcode (AlignLeft)   = 1501
-    toOpcode (AlignRight)  = 1502
-    toOpcode (AlignCenter) = 1503
-    
-instance ToOpcode CanvasTransform where
-    toOpcode (Save)           = 1601
-    toOpcode (Restore)        = 1602
-    toOpcode (Translate _)    = 1603
-    toOpcode (Rotate _)       = 1604
-    toOpcode (Scale _ _)      = 1605
-    toOpcode (Transform _)    = 1606
-    toOpcode (SetTransform _) = 1607
-    toOpcode (ResetTransform) = 1608
-    
-instance ToOpcode CSSUnit where
-    toOpcode (CSSPixels _)     = 1801
-    toOpcode (CSSPercentage _) = 1802
-    
-instance ToOpcode ClearPart where
-    toOpcode (ClearRectangle _ _) = 1901
-    toOpcode (ClearCanvas)        = 1902
-    
-instance ToOpcode CSSPosition where
-    toOpcode (CSSPosition _ _) = 2201
-    
-instance ToOpcode CSSBindPoint where
-    toOpcode (CSSFromCenter)  = 2301
-    toOpcode (CSSFromDefault) = 2302 +module Eventloop.Module.Websocket.Canvas.Opcode where++import Eventloop.Module.Websocket.Canvas.Types++class ToOpcode a where+    toOpcode :: a -> Opcode+++instance ToOpcode SystemCanvasOut where+    toOpcode (SystemMeasureText _) = 2001++instance ToOpcode CanvasOut where+    toOpcode (SetupCanvas _ _ _ _)  = 201+    toOpcode (TeardownCanvas _)     = 202+    toOpcode (CanvasOperations _ _) = 203+    toOpcode (MeasureText _)        = 204++instance ToOpcode CanvasOperation where+    toOpcode (DrawPath _ _ _ _) = 301+    toOpcode (DrawText _ _ _ _) = 302+    toOpcode (DoTransform _)    = 303+    toOpcode (Clear _)          = 304+    toOpcode (Frame)            = 305++instance ToOpcode ScreenPathPart where+    toOpcode (MoveTo _)              = 401+    toOpcode (LineTo _)              = 402+    toOpcode (BezierCurveTo _ _ _)   = 403+    toOpcode (QuadraticCurveTo _ _)  = 404+    toOpcode (ArcTo _ _ _)           = 405+    toOpcode (Arc _ _ _)             = 406+    toOpcode (Rectangle _ _)         = 407+    toOpcode (ClosePath)             = 408++instance ToOpcode PathStroke where+    toOpcode (PathStroke _ _) = 501+    toOpcode (NoPathStroke) = 502++instance ToOpcode PathFill where+    toOpcode (PathFill _) = 601+    toOpcode (NoPathFill) = 602++instance ToOpcode RenderStyle where+    toOpcode (CanvasColor _)      = 701+    toOpcode (CanvasGradient _ _) = 702+    toOpcode (CanvasPattern _ _)  = 703++instance ToOpcode CanvasImage where+    toOpcode (CanvasElement _ _ _) = 801+    toOpcode (ImageData _ _)       = 802++instance ToOpcode PatternRepetition where+    toOpcode (Repeat)   = 901+    toOpcode (RepeatX)  = 902+    toOpcode (RepeatY)  = 903+    toOpcode (NoRepeat) = 0904++instance ToOpcode CanvasGradientType where+    toOpcode (RadialGradient _ _) = 1001+    toOpcode (LinearGradient _ _) = 1002++instance ToOpcode CanvasText where+    toOpcode (CanvasText _ _ _) = 1201++instance ToOpcode Font where+    toOpcode (Font _ _) = 1301++instance ToOpcode TextStroke where+    toOpcode (TextStroke _ _) = 1401+    toOpcode (NoTextStroke)   = 1402++instance ToOpcode TextFill where+    toOpcode (TextFill _) = 2401+    toOpcode (NoTextFill) = 2402++instance ToOpcode Alignment where+    toOpcode (AlignLeft)   = 1501+    toOpcode (AlignRight)  = 1502+    toOpcode (AlignCenter) = 1503++instance ToOpcode CanvasTransform where+    toOpcode (Save)           = 1601+    toOpcode (Restore)        = 1602+    toOpcode (Translate _)    = 1603+    toOpcode (Rotate _)       = 1604+    toOpcode (Scale _ _)      = 1605+    toOpcode (Transform _)    = 1606+    toOpcode (SetTransform _) = 1607+    toOpcode (ResetTransform) = 1608++instance ToOpcode CSSUnit where+    toOpcode (CSSPixels _)     = 1801+    toOpcode (CSSPercentage _) = 1802++instance ToOpcode ClearPart where+    toOpcode (ClearRectangle _ _) = 1901+    toOpcode (ClearCanvas)        = 1902++instance ToOpcode CSSPosition where+    toOpcode (CSSPosition _ _) = 2201++instance ToOpcode CSSBindPoint where+    toOpcode (CSSFromCenter)  = 2301+    toOpcode (CSSFromDefault) = 2302

@@ -1,229 +1,229 @@-{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
-module Eventloop.Module.Websocket.Canvas.Types where
-
-import Control.Concurrent.MVar
-import GHC.Generics (Generic)
-import Control.DeepSeq
-
-import Eventloop.Types.Common
-
-type CanvasSystemReceiveBuffer = MVar SystemCanvasIn
-
-instance Show (MVar a) where
-    show _ = "CanvasSystemReceiveBuffer"
-
-
-type Opcode = Int
-
-type ScreenMetric = Int
-type ScreenX = ScreenMetric
-type ScreenY = ScreenMetric
-type ScreenWidth = ScreenMetric
-type ScreenHeight = ScreenMetric
-type ScreenRadius = ScreenMetric
-type ScreenAngle = ScreenMetric -- ^In degrees
-
-type ScreenPoint = (ScreenX, ScreenY)
-type ScreenDimensions = (ScreenWidth, ScreenHeight)
-
-type ScreenStartingPoint = ScreenPoint
-type ScreenControlPoint = ScreenPoint
-type ScreenEndPoint = ScreenPoint
-
-type ScreenStartingAngle = ScreenAngle
-type ScreenEndAngle = ScreenAngle
-
-type CanvasId = NumericId
-type ZIndex = Int
-
-type ScreenColorMetric = Int
-type ScreenRed = ScreenColorMetric
-type ScreenGreen = ScreenColorMetric
-type ScreenBlue = ScreenColorMetric
-type ScreenAlpha = Float
-type ScreenColor = (ScreenRed, ScreenGreen, ScreenBlue, ScreenAlpha)
-type ScreenPixel = ScreenColor
-
-type ColorStopOffset = Float
-
-type ScreenCircle = (ScreenPoint, ScreenRadius)
-
-type ScaleUnit = Float
-type ScaleX = ScaleUnit
-type ScaleY = ScaleUnit
-
-type ScreenLineThickness = Float
-
-type FontFamily = [Char]
-type FontSize = Int -- In Pixels
-
-
-data RoutedMessageIn = InUserCanvas CanvasIn
-                     | InSystemCanvas SystemCanvasIn
-                     deriving (Eq, Show)
-                      
-data RoutedMessageOut = OutUserCanvas CanvasOut
-                      | OutSystemCanvas SystemCanvasOut
-                      deriving (Eq, Show, Generic, NFData)
-
-{- |Opcode: 2100-}
-data SystemCanvasIn = SystemMeasuredText CanvasText ScreenDimensions {- ^Opcode: 2101-}
-                    deriving (Eq, Show)
-                      
-{- |Opcode: 2000-}
-data SystemCanvasOut = SystemMeasureText CanvasText  {- ^Opcode: 2001-}
-                     deriving (Eq, Show, Generic, NFData)
-                      
-{- |Opcode: 0100-}
-data CanvasIn = MeasuredText CanvasText ScreenDimensions {- ^Opcode: 0101-}
-              deriving (Eq, Show)
-
-
-{- Main types -}
-{- | Reserved type words
-     Type: t      | Opcode
-     Arguments: a | List of arguments for that data type
-     Route: r     | Either 's' for system or 'u' for user
-     Object: o    | The object that is beneath
-     
-     Example:
-     {'r': 's', 'o': {SystemMeasuredText object}}
-     
-     SystemMeasuredText object: {'t':2102, 'a':[CanvasId, CanvasText object, ScreenDimensions]}
--}
-
-{- |Opcode: 0200-}
-data CanvasOut = SetupCanvas CanvasId ZIndex ScreenDimensions CSSPosition {- ^Opcode: 0201-}
-               | TeardownCanvas CanvasId {- ^Opcode: 0202-}
-               | CanvasOperations CanvasId [CanvasOperation] {- ^Opcode: 0203-}
-               | MeasureText CanvasText {- ^Opcode: 0204-}
-               deriving (Eq, Show, Generic, NFData)
-               
-{- |Opcode: 0300-}
-data CanvasOperation = DrawPath ScreenStartingPoint [ScreenPathPart] PathStroke PathFill {- ^Opcode: 0301 -}
-                     | DrawText CanvasText ScreenPoint TextStroke TextFill {- ^Opcode: 0302 -}
-                     | DoTransform CanvasTransform {- ^Opcode: 0303 -}
-                     | Clear ClearPart {- ^Opcode: 0304 -}
-                     | Frame {- ^Opcode: 0305 -}
-                     deriving (Eq, Show, Generic, NFData)
-
-{- |Opcode: 0400-}
-data ScreenPathPart = MoveTo ScreenPoint {- ^Opcode: 0401-}
-                    | LineTo ScreenPoint {- ^Opcode: 0402-}
-                    | BezierCurveTo ScreenControlPoint ScreenControlPoint ScreenEndPoint {- ^Opcode: 0403-}
-                    | QuadraticCurveTo ScreenControlPoint ScreenEndPoint {- ^Opcode: 0404-}
-                    | ArcTo ScreenControlPoint ScreenControlPoint ScreenRadius {- ^Opcode: 0405-}
-                    | Arc ScreenCircle ScreenStartingAngle ScreenEndAngle {- ^Opcode: 0406-}
-                    | Rectangle ScreenPoint ScreenDimensions {- ^Opcode: 0407-}
-                    | ClosePath {- ^Opcode: 0408-}
-                    deriving (Eq, Show, Generic, NFData)
-
-{- Styling of Shapes -}
-{- |Opcode: 0500-}
-type PathRenderStrokeStyle = RenderStyle
-
-data PathStroke = PathStroke ScreenLineThickness PathRenderStrokeStyle {- ^Opcode: 0501-}
-                | NoPathStroke {- ^Opcode: 0502-}
-                deriving (Eq, Show, Generic, NFData)
-
-{- |Opcode: 0600-}
-type PathRenderFillStyle = RenderStyle
-
-data PathFill = PathFill PathRenderFillStyle {- ^Opcode: 0601-}
-              | NoPathFill {- ^Opcode: 0602-}
-              deriving (Eq, Show, Generic, NFData)
-
-{- |Opcode: 0700-}
-type CanvasColorStop = (ColorStopOffset, ScreenColor)
-
-data RenderStyle = CanvasColor ScreenColor {- ^Opcode: 0701-}
-                 | CanvasGradient CanvasGradientType [CanvasColorStop] {- ^Opcode:0702-}
-                 | CanvasPattern CanvasImage PatternRepetition {- ^Opcode: 0703-}
-                     deriving (Eq, Show, Generic, NFData)
-
-{- |Opcode: 0800-}                     
-data CanvasImage = CanvasElement CanvasId ScreenPoint ScreenDimensions {- ^Opcode: 0801-}
-                 | ImageData ScreenDimensions [ScreenPixel] {- ^Opcode: 0802 
-                                                            [ScreenPixel] should be as long as width * height * 4. Each quad is red,green,blue,alpha
-                                                            -}
-                 deriving (Eq, Show, Generic, NFData)
-{- |Opcode: 0900-}                 
-data PatternRepetition = Repeat {- ^Opcode: 0901-}
-                       | RepeatX {- ^Opcode: 0902-}
-                       | RepeatY {- ^Opcode: 0903-} 
-                       | NoRepeat {- ^Opcode: 0904-}
-                       deriving (Eq, Show, Generic, NFData)
-
-{- |Opcode: 1000-}
-data CanvasGradientType = RadialGradient ScreenCircle ScreenCircle {- ^Opcode: 1001
-                                                                       First circle = inner circle, Second circle is enclosing circle
-                                                                   -}
-                        | LinearGradient ScreenPoint ScreenPoint {- ^Opcode: 1002-}
-                        deriving (Eq, Show, Generic, NFData)
-
-{- To Draw Text -}
-{- |Opcode: 1200-}
-data CanvasText = CanvasText [Char] Font Alignment {- ^Opcode: 1201-}
-                deriving (Eq, Show, Generic, NFData)
-
-{- |Opcode: 1300-}
-data Font = Font FontFamily FontSize {- ^Opcode: 1301-}
-          deriving (Eq, Show, Generic, NFData)
-
-{- |Opcode: 1400-}
-type TextStrokeRenderStyle = RenderStyle
-type TextFillRenderStyle = RenderStyle
-
-data TextStroke = TextStroke ScreenLineThickness TextStrokeRenderStyle {- ^Opcode: 1401-}
-                | NoTextStroke {- ^Opcode: 1402-}
-                deriving (Eq, Show, Generic, NFData)
-
-{- |Opcode: 2400-}
-data TextFill = TextFill TextFillRenderStyle {- ^Opcode: 2401-}
-              | NoTextFill {- ^Opcode: 2402-}
-              deriving (Eq, Show, Generic, NFData)
-
-{- |Opcode: 1500-}
-data Alignment = AlignLeft {- ^Opcode: 1501-}
-               | AlignRight {- ^Opcode: 1502-}
-               | AlignCenter {- ^Opcode: 1503-}
-               deriving (Eq, Show, Generic, NFData)
-               
-{- Transform The Canvas -}
-{- |Opcode: 1600-}
-type TransformUnit = Float                        
-type TransformationMatrix  = (TransformUnit, TransformUnit, TransformUnit, TransformUnit, TransformUnit, TransformUnit)
-
-data CanvasTransform = Save {- ^Opcode: 1601-}
-                     | Restore {- ^Opcode: 1602-}
-                     | Translate ScreenPoint {- ^Opcode: 1603-}
-                     | Rotate ScreenAngle {- ^Opcode: 1604-}
-                     | Scale ScaleX ScaleY {- ^Opcode: 1605-}
-                     | Transform TransformationMatrix {- ^Opcode: 1606-}
-                     | SetTransform TransformationMatrix {- ^Opcode: 1607-}
-                     | ResetTransform {- ^Opcode: 1608-}
-                     deriving (Eq, Show, Generic, NFData)
-
-{- CSS Position of DOM elements -}
-{- |Opcode: 2200-}
-type CSSLeftOffset = CSSUnit
-type CSSTopOffset = CSSUnit
-type CSSMeasurements = (CSSLeftOffset, CSSTopOffset)
-
-data CSSPosition = CSSPosition CSSBindPoint CSSMeasurements {- ^Opcode: 2201-}
-                 deriving (Eq, Show, Generic, NFData)
-
-{- |Opcode: 2300-}
-data CSSBindPoint = CSSFromCenter {- ^Opcode: 2301-}
-                  | CSSFromDefault {- ^Opcode: 2302 Usually this is the top left corner of the element -}
-                  deriving (Eq, Show, Generic, NFData)
-                     
-{- |Opcode: 1800-}
-data CSSUnit = CSSPixels Int {- ^Opcode: 1801-}
-             | CSSPercentage Int {- ^Opcode: 1802-}
-             deriving (Eq, Show, Generic, NFData)
-             
-{- |Opcode: 1900 -}
-data ClearPart = ClearRectangle ScreenPoint ScreenDimensions {- ^Opcode: 1901-}
-               | ClearCanvas {- ^Opcode: 1902-}
+{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}+module Eventloop.Module.Websocket.Canvas.Types where++import Control.Concurrent.MVar+import GHC.Generics (Generic)+import Control.DeepSeq++import Eventloop.Types.Common++type CanvasSystemReceiveBuffer = MVar SystemCanvasIn++instance Show (MVar a) where+    show _ = "CanvasSystemReceiveBuffer"+++type Opcode = Int++type ScreenMetric = Int+type ScreenX = ScreenMetric+type ScreenY = ScreenMetric+type ScreenWidth = ScreenMetric+type ScreenHeight = ScreenMetric+type ScreenRadius = ScreenMetric+type ScreenAngle = ScreenMetric -- ^In degrees++type ScreenPoint = (ScreenX, ScreenY)+type ScreenDimensions = (ScreenWidth, ScreenHeight)++type ScreenStartingPoint = ScreenPoint+type ScreenControlPoint = ScreenPoint+type ScreenEndPoint = ScreenPoint++type ScreenStartingAngle = ScreenAngle+type ScreenEndAngle = ScreenAngle++type CanvasId = NumericId+type ZIndex = Int++type ScreenColorMetric = Int+type ScreenRed = ScreenColorMetric+type ScreenGreen = ScreenColorMetric+type ScreenBlue = ScreenColorMetric+type ScreenAlpha = Float+type ScreenColor = (ScreenRed, ScreenGreen, ScreenBlue, ScreenAlpha)+type ScreenPixel = ScreenColor++type ColorStopOffset = Float++type ScreenCircle = (ScreenPoint, ScreenRadius)++type ScaleUnit = Float+type ScaleX = ScaleUnit+type ScaleY = ScaleUnit++type ScreenLineThickness = Float++type FontFamily = [Char]+type FontSize = Int -- In Pixels+++data RoutedMessageIn = InUserCanvas CanvasIn+                     | InSystemCanvas SystemCanvasIn+                     deriving (Eq, Show)++data RoutedMessageOut = OutUserCanvas CanvasOut+                      | OutSystemCanvas SystemCanvasOut+                      deriving (Eq, Show, Generic, NFData)++{- |Opcode: 2100-}+data SystemCanvasIn = SystemMeasuredText CanvasText ScreenDimensions {- ^Opcode: 2101-}+                    deriving (Eq, Show)++{- |Opcode: 2000-}+data SystemCanvasOut = SystemMeasureText CanvasText  {- ^Opcode: 2001-}+                     deriving (Eq, Show, Generic, NFData)++{- |Opcode: 0100-}+data CanvasIn = MeasuredText CanvasText ScreenDimensions {- ^Opcode: 0101-}+              deriving (Eq, Show)+++{- Main types -}+{- | Reserved type words+     Type: t      | Opcode+     Arguments: a | List of arguments for that data type+     Route: r     | Either 's' for system or 'u' for user+     Object: o    | The object that is beneath++     Example:+     {'r': 's', 'o': {SystemMeasuredText object}}++     SystemMeasuredText object: {'t':2102, 'a':[CanvasId, CanvasText object, ScreenDimensions]}+-}++{- |Opcode: 0200-}+data CanvasOut = SetupCanvas CanvasId ZIndex ScreenDimensions CSSPosition {- ^Opcode: 0201-}+               | TeardownCanvas CanvasId {- ^Opcode: 0202-}+               | CanvasOperations CanvasId [CanvasOperation] {- ^Opcode: 0203-}+               | MeasureText CanvasText {- ^Opcode: 0204-}+               deriving (Eq, Show, Generic, NFData)++{- |Opcode: 0300-}+data CanvasOperation = DrawPath ScreenStartingPoint [ScreenPathPart] PathStroke PathFill {- ^Opcode: 0301 -}+                     | DrawText CanvasText ScreenPoint TextStroke TextFill {- ^Opcode: 0302 -}+                     | DoTransform CanvasTransform {- ^Opcode: 0303 -}+                     | Clear ClearPart {- ^Opcode: 0304 -}+                     | Frame {- ^Opcode: 0305 -}+                     deriving (Eq, Show, Generic, NFData)++{- |Opcode: 0400-}+data ScreenPathPart = MoveTo ScreenPoint {- ^Opcode: 0401-}+                    | LineTo ScreenPoint {- ^Opcode: 0402-}+                    | BezierCurveTo ScreenControlPoint ScreenControlPoint ScreenEndPoint {- ^Opcode: 0403-}+                    | QuadraticCurveTo ScreenControlPoint ScreenEndPoint {- ^Opcode: 0404-}+                    | ArcTo ScreenControlPoint ScreenControlPoint ScreenRadius {- ^Opcode: 0405-}+                    | Arc ScreenCircle ScreenStartingAngle ScreenEndAngle {- ^Opcode: 0406-}+                    | Rectangle ScreenPoint ScreenDimensions {- ^Opcode: 0407-}+                    | ClosePath {- ^Opcode: 0408-}+                    deriving (Eq, Show, Generic, NFData)++{- Styling of Shapes -}+{- |Opcode: 0500-}+type PathRenderStrokeStyle = RenderStyle++data PathStroke = PathStroke ScreenLineThickness PathRenderStrokeStyle {- ^Opcode: 0501-}+                | NoPathStroke {- ^Opcode: 0502-}+                deriving (Eq, Show, Generic, NFData)++{- |Opcode: 0600-}+type PathRenderFillStyle = RenderStyle++data PathFill = PathFill PathRenderFillStyle {- ^Opcode: 0601-}+              | NoPathFill {- ^Opcode: 0602-}+              deriving (Eq, Show, Generic, NFData)++{- |Opcode: 0700-}+type CanvasColorStop = (ColorStopOffset, ScreenColor)++data RenderStyle = CanvasColor ScreenColor {- ^Opcode: 0701-}+                 | CanvasGradient CanvasGradientType [CanvasColorStop] {- ^Opcode:0702-}+                 | CanvasPattern CanvasImage PatternRepetition {- ^Opcode: 0703-}+                     deriving (Eq, Show, Generic, NFData)++{- |Opcode: 0800-}+data CanvasImage = CanvasElement CanvasId ScreenPoint ScreenDimensions {- ^Opcode: 0801-}+                 | ImageData ScreenDimensions [ScreenPixel] {- ^Opcode: 0802+                                                            [ScreenPixel] should be as long as width * height * 4. Each quad is red,green,blue,alpha+                                                            -}+                 deriving (Eq, Show, Generic, NFData)+{- |Opcode: 0900-}+data PatternRepetition = Repeat {- ^Opcode: 0901-}+                       | RepeatX {- ^Opcode: 0902-}+                       | RepeatY {- ^Opcode: 0903-}+                       | NoRepeat {- ^Opcode: 0904-}+                       deriving (Eq, Show, Generic, NFData)++{- |Opcode: 1000-}+data CanvasGradientType = RadialGradient ScreenCircle ScreenCircle {- ^Opcode: 1001+                                                                       First circle = inner circle, Second circle is enclosing circle+                                                                   -}+                        | LinearGradient ScreenPoint ScreenPoint {- ^Opcode: 1002-}+                        deriving (Eq, Show, Generic, NFData)++{- To Draw Text -}+{- |Opcode: 1200-}+data CanvasText = CanvasText [Char] Font Alignment {- ^Opcode: 1201-}+                deriving (Eq, Show, Generic, NFData)++{- |Opcode: 1300-}+data Font = Font FontFamily FontSize {- ^Opcode: 1301-}+          deriving (Eq, Show, Generic, NFData)++{- |Opcode: 1400-}+type TextStrokeRenderStyle = RenderStyle+type TextFillRenderStyle = RenderStyle++data TextStroke = TextStroke ScreenLineThickness TextStrokeRenderStyle {- ^Opcode: 1401-}+                | NoTextStroke {- ^Opcode: 1402-}+                deriving (Eq, Show, Generic, NFData)++{- |Opcode: 2400-}+data TextFill = TextFill TextFillRenderStyle {- ^Opcode: 2401-}+              | NoTextFill {- ^Opcode: 2402-}+              deriving (Eq, Show, Generic, NFData)++{- |Opcode: 1500-}+data Alignment = AlignLeft {- ^Opcode: 1501-}+               | AlignRight {- ^Opcode: 1502-}+               | AlignCenter {- ^Opcode: 1503-}+               deriving (Eq, Show, Generic, NFData)++{- Transform The Canvas -}+{- |Opcode: 1600-}+type TransformUnit = Float+type TransformationMatrix  = (TransformUnit, TransformUnit, TransformUnit, TransformUnit, TransformUnit, TransformUnit)++data CanvasTransform = Save {- ^Opcode: 1601-}+                     | Restore {- ^Opcode: 1602-}+                     | Translate ScreenPoint {- ^Opcode: 1603-}+                     | Rotate ScreenAngle {- ^Opcode: 1604-}+                     | Scale ScaleX ScaleY {- ^Opcode: 1605-}+                     | Transform TransformationMatrix {- ^Opcode: 1606-}+                     | SetTransform TransformationMatrix {- ^Opcode: 1607-}+                     | ResetTransform {- ^Opcode: 1608-}+                     deriving (Eq, Show, Generic, NFData)++{- CSS Position of DOM elements -}+{- |Opcode: 2200-}+type CSSLeftOffset = CSSUnit+type CSSTopOffset = CSSUnit+type CSSMeasurements = (CSSLeftOffset, CSSTopOffset)++data CSSPosition = CSSPosition CSSBindPoint CSSMeasurements {- ^Opcode: 2201-}+                 deriving (Eq, Show, Generic, NFData)++{- |Opcode: 2300-}+data CSSBindPoint = CSSFromCenter {- ^Opcode: 2301-}+                  | CSSFromDefault {- ^Opcode: 2302 Usually this is the top left corner of the element -}+                  deriving (Eq, Show, Generic, NFData)++{- |Opcode: 1800-}+data CSSUnit = CSSPixels Int {- ^Opcode: 1801-}+             | CSSPercentage Int {- ^Opcode: 1802-}+             deriving (Eq, Show, Generic, NFData)++{- |Opcode: 1900 -}+data ClearPart = ClearRectangle ScreenPoint ScreenDimensions {- ^Opcode: 1901-}+               | ClearCanvas {- ^Opcode: 1902-}                deriving (Eq, Show, Generic, NFData)

@@ -1,7 +1,7 @@-module Eventloop.Module.Websocket.Keyboard
-    ( module Eventloop.Module.Websocket.Keyboard.Keyboard
-    , module Eventloop.Module.Websocket.Keyboard.Types
-    ) where
-    
-import Eventloop.Module.Websocket.Keyboard.Keyboard
+module Eventloop.Module.Websocket.Keyboard+    ( module Eventloop.Module.Websocket.Keyboard.Keyboard+    , module Eventloop.Module.Websocket.Keyboard.Types+    ) where+    +import Eventloop.Module.Websocket.Keyboard.Keyboard import Eventloop.Module.Websocket.Keyboard.Types

@@ -1,92 +1,92 @@- {-# LANGUAGE OverloadedStrings #-}
-module Eventloop.Module.Websocket.Keyboard.Keyboard
-    ( setupKeyboardModuleConfiguration
-    , keyboardModuleIdentifier
-    , keyboardInitializer
-    , keyboardEventRetriever
-    , keyboardEventSender
-    ) where
-
-import Data.Aeson
-import Data.Maybe
-import Control.Applicative
-import Control.Concurrent.MVar
-import Control.Concurrent.SafePrint
-import qualified Data.ByteString.Lazy.Char8 as BL
-
-import Eventloop.Types.Common
-import Eventloop.Types.Events
-import Eventloop.Types.System
-import Eventloop.Module.Websocket.Keyboard.Types
-import Eventloop.Utility.Config
-import Eventloop.Utility.Websockets
-
-
-setupKeyboardModuleConfiguration :: EventloopSetupModuleConfiguration
-setupKeyboardModuleConfiguration = ( EventloopSetupModuleConfiguration 
-                                        keyboardModuleIdentifier
-                                        (Just keyboardInitializer)
-                                        (Just keyboardEventRetriever)
-                                        Nothing
-                                        Nothing
-                                        (Just keyboardEventSender)
-                                        Nothing
-                                      )
-
-                                      
-keyboardModuleIdentifier :: EventloopModuleIdentifier
-keyboardModuleIdentifier = "keyboard"
-
-                  
-instance FromJSON Keyboard where
-    parseJSON (Object v) = Key <$> v .: "key"
-
-    
-keyboardInitializer :: Initializer
-keyboardInitializer sharedConst sharedIO
-    = do
-        (clientSocket, clientConn, serverSock) <- setupWebsocketConnection iNADDR_ANY  keyboardPort
-        safePrintLn (safePrintToken sharedConst) "Keyboard connection successfull"
-        return (sharedConst, sharedIO, KeyboardConstants clientSocket clientConn serverSock, NoState)
-
-                            
-keyboardEventRetriever :: EventRetriever
-keyboardEventRetriever sharedConst sharedIOT ioConst ioStateT
-    = do
-        isConnected <- isConnected sock
-        case isConnected of
-            False -> return []
-            True -> do
-                messageM <- takeMessage safePrintToken_ sock conn
-                case messageM of
-                    Nothing -> return []
-                    (Just message) -> return [InKeyboard $ messageToKeyboardIn message]
-    where
-        sock = clientSocket ioConst
-        conn = clientConnection ioConst
-        safePrintToken_ = safePrintToken sharedConst
-
-
-messageToKeyboardIn :: Message -> Keyboard
-messageToKeyboardIn message = fromJust.decode $ BL.pack message
-
-
-keyboardEventSender :: EventSender
-keyboardEventSender sharedConst sharedIOT ioConst ioStateT Stop
-    = do
-        closeWebsocketConnection safePrintToken_ serverSock clientSock conn
-    where
-        serverSock = serverSocket ioConst
-        clientSock = clientSocket ioConst
-        conn = clientConnection ioConst
-        safePrintToken_ = safePrintToken sharedConst
-
-keyboardTeardown :: Teardown
-keyboardTeardown sharedConst sharedIO ioConst ioState
-    = do
-        destroyWebsocketConnection serverSock clientSock
-        return sharedIO
-    where
-        serverSock = serverSocket ioConst
-        clientSock = clientSocket ioConst
+ {-# LANGUAGE OverloadedStrings #-}+module Eventloop.Module.Websocket.Keyboard.Keyboard+    ( setupKeyboardModuleConfiguration+    , keyboardModuleIdentifier+    , keyboardInitializer+    , keyboardEventRetriever+    , keyboardEventSender+    ) where++import Data.Aeson+import Data.Maybe+import Control.Applicative+import Control.Concurrent.MVar+import Control.Concurrent.SafePrint+import qualified Data.ByteString.Lazy.Char8 as BL++import Eventloop.Types.Common+import Eventloop.Types.Events+import Eventloop.Types.System+import Eventloop.Module.Websocket.Keyboard.Types+import Eventloop.Utility.Config+import Eventloop.Utility.Websockets+++setupKeyboardModuleConfiguration :: EventloopSetupModuleConfiguration+setupKeyboardModuleConfiguration = ( EventloopSetupModuleConfiguration +                                        keyboardModuleIdentifier+                                        (Just keyboardInitializer)+                                        (Just keyboardEventRetriever)+                                        Nothing+                                        Nothing+                                        (Just keyboardEventSender)+                                        Nothing+                                      )++                                      +keyboardModuleIdentifier :: EventloopModuleIdentifier+keyboardModuleIdentifier = "keyboard"++                  +instance FromJSON Keyboard where+    parseJSON (Object v) = Key <$> v .: "key"++    +keyboardInitializer :: Initializer+keyboardInitializer sharedConst sharedIO+    = do+        (clientSocket, clientConn, serverSock) <- setupWebsocketConnection iNADDR_ANY  keyboardPort+        safePrintLn (safePrintToken sharedConst) "Keyboard connection successfull"+        return (sharedConst, sharedIO, KeyboardConstants clientSocket clientConn serverSock, NoState)++                            +keyboardEventRetriever :: EventRetriever+keyboardEventRetriever sharedConst sharedIOT ioConst ioStateT+    = do+        isConnected <- isConnected sock+        case isConnected of+            False -> return []+            True -> do+                messageM <- takeMessage safePrintToken_ sock conn+                case messageM of+                    Nothing -> return []+                    (Just message) -> return [InKeyboard $ messageToKeyboardIn message]+    where+        sock = clientSocket ioConst+        conn = clientConnection ioConst+        safePrintToken_ = safePrintToken sharedConst+++messageToKeyboardIn :: Message -> Keyboard+messageToKeyboardIn message = fromJust.decode $ BL.pack message+++keyboardEventSender :: EventSender+keyboardEventSender sharedConst sharedIOT ioConst ioStateT Stop+    = do+        closeWebsocketConnection safePrintToken_ serverSock clientSock conn+    where+        serverSock = serverSocket ioConst+        clientSock = clientSocket ioConst+        conn = clientConnection ioConst+        safePrintToken_ = safePrintToken sharedConst++keyboardTeardown :: Teardown+keyboardTeardown sharedConst sharedIO ioConst ioState+    = do+        destroyWebsocketConnection serverSock clientSock+        return sharedIO+    where+        serverSock = serverSocket ioConst+        clientSock = clientSocket ioConst         conn = clientConnection ioConst

@@ -1,14 +1,14 @@-{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
-module Eventloop.Module.Websocket.Keyboard.Types where
-
-import GHC.Generics (Generic)
-import Control.DeepSeq
-
-{-| Almost all key presses are registered including modifier keys.
- Expect character keys to come in as their character. Press a c, get
- a "c". If a modifier is used and a different character is expected,
- it will be that instead. Press shift + c, get a "C". Modifiers are also
- sent as their string representation: "shift", "ctrl" or "alt". Space is
- expected as "space". -}
-data Keyboard = Key [Char]
+{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}+module Eventloop.Module.Websocket.Keyboard.Types where++import GHC.Generics (Generic)+import Control.DeepSeq++{-| Almost all key presses are registered including modifier keys.+ Expect character keys to come in as their character. Press a c, get+ a "c". If a modifier is used and a different character is expected,+ it will be that instead. Press shift + c, get a "C". Modifiers are also+ sent as their string representation: "shift", "ctrl" or "alt". Space is+ expected as "space". -}+data Keyboard = Key [Char]                 deriving (Eq, Show, Generic, NFData)

@@ -1,7 +1,7 @@-module Eventloop.Module.Websocket.Mouse
-    ( module Eventloop.Module.Websocket.Mouse.Mouse
-    , module Eventloop.Module.Websocket.Mouse.Types
-    ) where
-    
-import Eventloop.Module.Websocket.Mouse.Mouse
+module Eventloop.Module.Websocket.Mouse+    ( module Eventloop.Module.Websocket.Mouse.Mouse+    , module Eventloop.Module.Websocket.Mouse.Types+    ) where+    +import Eventloop.Module.Websocket.Mouse.Mouse import Eventloop.Module.Websocket.Mouse.Types

@@ -1,137 +1,137 @@-{-# LANGUAGE OverloadedStrings #-}
-module Eventloop.Module.Websocket.Mouse.Mouse
-    ( setupMouseModuleConfiguration
-    , mouseModuleIdentifier
-    , mouseInitializer
-    , mouseEventRetriever
-    , mouseEventSender
-    ) where
-
-import Control.Applicative
-import Control.Monad
-import Control.Concurrent.MVar
-import Control.Concurrent.SafePrint
-import Data.Aeson
-import Data.Aeson.Types
-import qualified Data.ByteString.Lazy.Char8 as BL
-import Data.Maybe
-
-import Eventloop.Module.Websocket.Mouse.Types
-import Eventloop.Types.Common
-import Eventloop.Types.Events
-import Eventloop.Types.System
-import Eventloop.Utility.Websockets
-import Eventloop.Utility.Config
-import Eventloop.Utility.Vectors
-
-setupMouseModuleConfiguration :: EventloopSetupModuleConfiguration
-setupMouseModuleConfiguration = ( EventloopSetupModuleConfiguration 
-                                    mouseModuleIdentifier
-                                    (Just mouseInitializer)
-                                    (Just mouseEventRetriever)
-                                    Nothing
-                                    Nothing
-                                    (Just mouseEventSender)
-                                    Nothing
-                                  )
-     
-
-mouseModuleIdentifier :: EventloopModuleIdentifier
-mouseModuleIdentifier = "mouse"
-
-
-instance FromJSON MouseIn where
-    parseJSON vO@(Object v)
-        = do
-            mouseEvent <- parseJSON vO :: Parser MouseEvent
-            mouseType  <- parseJSON vO :: Parser MouseType
-            point      <- parseJSON vO :: Parser Point
-            id         <- v .: "id"    :: Parser NumericId
-            return $ Mouse mouseType id mouseEvent point
-    
-    
-instance FromJSON MouseType where
-    parseJSON (Object v)
-        = do
-            type' <- v .: "elementType" :: Parser String
-            return $ case type' of "canvas" -> MouseCanvas
-                                   "svg"    -> MouseSVG
-    
-instance FromJSON MouseEvent where
-    parseJSON (Object v)
-        =   do
-                eventType <- v .: "mouseEventType" :: Parser String
-                button <- parseJSON (Object v) :: Parser MouseButton
-                return $ case eventType of "click"      -> Click button
-                                           "dblclick"   -> DoubleClick button
-                                           "mousedown"  -> MouseDown button
-                                           "mouseup"    -> MouseUp button
-                                           "mouseenter" -> MouseEnter
-                                           "mouseleave" -> MouseLeave
-                                           "mousemove"  -> MouseMove
-   
-instance FromJSON MouseButton where
-    parseJSON (Object v)
-        = do
-            button <- v .: "button" :: Parser String
-            return $ case button of "left"   -> MouseLeft
-                                    "middle" -> MouseMiddle
-                                    "right"  -> MouseRight
-
-instance FromJSON Point where
-    parseJSON (Object v)
-        = do
-            x <- v .: "x"
-            y <- v .: "y"
-            return $ Point (x, y)
-    
-    
-mouseInitializer :: Initializer
-mouseInitializer sharedConst sharedIO
-    = do
-        (clientSocket, clientConn, serverSock) <- setupWebsocketConnection iNADDR_ANY  mousePort
-        safePrintLn (safePrintToken sharedConst) "Mouse connection succesfull"
-        return (sharedConst, sharedIO, MouseConstants clientSocket clientConn serverSock, NoState)
-
-
-mouseEventRetriever :: EventRetriever
-mouseEventRetriever sharedConst sharedIOT ioConst ioStateT
-    = do
-        isConnected <- isConnected sock
-        case isConnected of
-            False -> return []
-            True -> do
-                messageM <- takeMessage safePrintToken_ sock conn
-                case messageM of
-                    Nothing        -> return []
-                    (Just message) -> return [InMouse $ messageToMouseIn message]
-    where
-        sock = clientSocket ioConst
-        conn = clientConnection ioConst
-        safePrintToken_ = safePrintToken sharedConst
-
-
-messageToMouseIn :: Message -> MouseIn
-messageToMouseIn message = fromJust.decode $ BL.pack message
-
-
-mouseEventSender :: EventSender
-mouseEventSender sharedConst sharedIOT ioConst ioStateT Stop
-    = do
-        closeWebsocketConnection safePrintToken_ serverSock clientSock conn
-    where
-        serverSock = serverSocket ioConst
-        clientSock = clientSocket ioConst
-        conn = clientConnection ioConst
-        safePrintToken_ = safePrintToken sharedConst
-
-
-mouseTeardown :: Teardown
-mouseTeardown sharedConst sharedIO ioConst ioState
-    = do
-        destroyWebsocketConnection serverSock clientSock
-        return sharedIO
-    where
-        serverSock = serverSocket ioConst
-        clientSock = clientSocket ioConst
+{-# LANGUAGE OverloadedStrings #-}+module Eventloop.Module.Websocket.Mouse.Mouse+    ( setupMouseModuleConfiguration+    , mouseModuleIdentifier+    , mouseInitializer+    , mouseEventRetriever+    , mouseEventSender+    ) where++import Control.Applicative+import Control.Monad+import Control.Concurrent.MVar+import Control.Concurrent.SafePrint+import Data.Aeson+import Data.Aeson.Types+import qualified Data.ByteString.Lazy.Char8 as BL+import Data.Maybe++import Eventloop.Module.Websocket.Mouse.Types+import Eventloop.Types.Common+import Eventloop.Types.Events+import Eventloop.Types.System+import Eventloop.Utility.Websockets+import Eventloop.Utility.Config+import Eventloop.Utility.Vectors++setupMouseModuleConfiguration :: EventloopSetupModuleConfiguration+setupMouseModuleConfiguration = ( EventloopSetupModuleConfiguration +                                    mouseModuleIdentifier+                                    (Just mouseInitializer)+                                    (Just mouseEventRetriever)+                                    Nothing+                                    Nothing+                                    (Just mouseEventSender)+                                    Nothing+                                  )+     ++mouseModuleIdentifier :: EventloopModuleIdentifier+mouseModuleIdentifier = "mouse"+++instance FromJSON MouseIn where+    parseJSON vO@(Object v)+        = do+            mouseEvent <- parseJSON vO :: Parser MouseEvent+            mouseType  <- parseJSON vO :: Parser MouseType+            point      <- parseJSON vO :: Parser Point+            id         <- v .: "id"    :: Parser NumericId+            return $ Mouse mouseType id mouseEvent point+    +    +instance FromJSON MouseType where+    parseJSON (Object v)+        = do+            type' <- v .: "elementType" :: Parser String+            return $ case type' of "canvas" -> MouseCanvas+                                   "svg"    -> MouseSVG+    +instance FromJSON MouseEvent where+    parseJSON (Object v)+        =   do+                eventType <- v .: "mouseEventType" :: Parser String+                button <- parseJSON (Object v) :: Parser MouseButton+                return $ case eventType of "click"      -> Click button+                                           "dblclick"   -> DoubleClick button+                                           "mousedown"  -> MouseDown button+                                           "mouseup"    -> MouseUp button+                                           "mouseenter" -> MouseEnter+                                           "mouseleave" -> MouseLeave+                                           "mousemove"  -> MouseMove+   +instance FromJSON MouseButton where+    parseJSON (Object v)+        = do+            button <- v .: "button" :: Parser String+            return $ case button of "left"   -> MouseLeft+                                    "middle" -> MouseMiddle+                                    "right"  -> MouseRight++instance FromJSON Point where+    parseJSON (Object v)+        = do+            x <- v .: "x"+            y <- v .: "y"+            return $ Point (x, y)+    +    +mouseInitializer :: Initializer+mouseInitializer sharedConst sharedIO+    = do+        (clientSocket, clientConn, serverSock) <- setupWebsocketConnection iNADDR_ANY  mousePort+        safePrintLn (safePrintToken sharedConst) "Mouse connection succesfull"+        return (sharedConst, sharedIO, MouseConstants clientSocket clientConn serverSock, NoState)+++mouseEventRetriever :: EventRetriever+mouseEventRetriever sharedConst sharedIOT ioConst ioStateT+    = do+        isConnected <- isConnected sock+        case isConnected of+            False -> return []+            True -> do+                messageM <- takeMessage safePrintToken_ sock conn+                case messageM of+                    Nothing        -> return []+                    (Just message) -> return [InMouse $ messageToMouseIn message]+    where+        sock = clientSocket ioConst+        conn = clientConnection ioConst+        safePrintToken_ = safePrintToken sharedConst+++messageToMouseIn :: Message -> MouseIn+messageToMouseIn message = fromJust.decode $ BL.pack message+++mouseEventSender :: EventSender+mouseEventSender sharedConst sharedIOT ioConst ioStateT Stop+    = do+        closeWebsocketConnection safePrintToken_ serverSock clientSock conn+    where+        serverSock = serverSocket ioConst+        clientSock = clientSocket ioConst+        conn = clientConnection ioConst+        safePrintToken_ = safePrintToken sharedConst+++mouseTeardown :: Teardown+mouseTeardown sharedConst sharedIO ioConst ioState+    = do+        destroyWebsocketConnection serverSock clientSock+        return sharedIO+    where+        serverSock = serverSocket ioConst+        clientSock = clientSocket ioConst         conn = clientConnection ioConst

@@ -1,29 +1,29 @@-{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
-module Eventloop.Module.Websocket.Mouse.Types where
-
-import GHC.Generics (Generic)
-import Control.DeepSeq
-
-import Eventloop.Types.Common
-import Eventloop.Utility.Vectors
-
-data MouseIn = Mouse MouseType NumericId MouseEvent Point
-             deriving (Eq, Show)
-
-data MouseType = MouseCanvas
-               | MouseSVG
-               deriving (Eq, Show)
-
-data MouseEvent = Click MouseButton
-                | DoubleClick MouseButton
-                | MouseMove
-                | MouseDown MouseButton
-                | MouseUp MouseButton
-                | MouseEnter
-                | MouseLeave
-                deriving (Eq, Show)
-         
-data MouseButton = MouseLeft 
-                 | MouseRight 
-                 | MouseMiddle
+{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}+module Eventloop.Module.Websocket.Mouse.Types where++import GHC.Generics (Generic)+import Control.DeepSeq++import Eventloop.Types.Common+import Eventloop.Utility.Vectors++data MouseIn = Mouse MouseType NumericId MouseEvent Point+             deriving (Eq, Show)++data MouseType = MouseCanvas+               | MouseSVG+               deriving (Eq, Show)++data MouseEvent = Click MouseButton+                | DoubleClick MouseButton+                | MouseMove+                | MouseDown MouseButton+                | MouseUp MouseButton+                | MouseEnter+                | MouseLeave+                deriving (Eq, Show)+         +data MouseButton = MouseLeft +                 | MouseRight +                 | MouseMiddle                  deriving (Eq, Show, Generic, NFData)

@@ -1,21 +1,21 @@-module Eventloop.OutRouter where
-
-import Eventloop.Types.Events
-import Eventloop.Types.System
-
-import Eventloop.Module.File
-import Eventloop.Module.Timer
-import Eventloop.Module.StatefulGraphics
-import Eventloop.Module.StdIn
-import Eventloop.Module.StdOut
-import Eventloop.Module.Websocket.Canvas
-
-routeOutEvent :: OutEventRouter
-routeOutEvent out = case out of
-                            (OutFile _) -> fileModuleIdentifier
-                            (OutTimer _) -> timerModuleIdentifier
-                            (OutStdOut _) -> stdOutModuleIdentifier
-                            (OutStdIn _) -> stdInModuleIdentifier
-                            (OutCanvas _) -> canvasModuleIdentifier
-                            (OutStatefulGraphics _ _) -> statefulGraphicsModuleIdentifier
+module Eventloop.OutRouter where++import Eventloop.Types.Events+import Eventloop.Types.System++import Eventloop.Module.File+import Eventloop.Module.Timer+import Eventloop.Module.StatefulGraphics+import Eventloop.Module.StdIn+import Eventloop.Module.StdOut+import Eventloop.Module.Websocket.Canvas++routeOutEvent :: OutEventRouter+routeOutEvent out = case out of+                            (OutFile _) -> fileModuleIdentifier+                            (OutTimer _) -> timerModuleIdentifier+                            (OutStdOut _) -> stdOutModuleIdentifier+                            (OutStdIn _) -> stdInModuleIdentifier+                            (OutCanvas _) -> canvasModuleIdentifier+                            (OutStatefulGraphics _ _) -> statefulGraphicsModuleIdentifier                             _ -> error ("Could not find route for out event: " ++ show out)

@@ -1,26 +1,26 @@-module Eventloop.System.DisplayExceptionThread
-    ( startDisplayingExceptions
-    ) where
-
-import qualified Control.Exception as E
-import Control.Concurrent.ExceptionCollection
-import Control.Concurrent.SafePrint
-
-import Eventloop.Types.Exception
-import Eventloop.Types.System
-
-
-startDisplayingExceptions :: EventloopSystemConfiguration progstateT
-                          -> IO ()
-startDisplayingExceptions systemConfig
-    = do
-        exceptions_ <- collectExceptions (exceptions systemConfig)
-        mapM_ (displayException safePrintToken_) exceptions_
-    where
-        safePrintToken_ = safePrintToken (sharedIOConstants systemConfig)
-          
-          
-displayException :: SafePrintToken
-                 -> E.SomeException
-                 -> IO ()
+module Eventloop.System.DisplayExceptionThread+    ( startDisplayingExceptions+    ) where++import qualified Control.Exception as E+import Control.Concurrent.ExceptionCollection+import Control.Concurrent.SafePrint++import Eventloop.Types.Exception+import Eventloop.Types.System+++startDisplayingExceptions :: EventloopSystemConfiguration progstateT+                          -> IO ()+startDisplayingExceptions systemConfig+    = do+        exceptions_ <- collectExceptions (exceptions systemConfig)+        mapM_ (displayException safePrintToken_) exceptions_+    where+        safePrintToken_ = safePrintToken (sharedIOConstants systemConfig)+++displayException :: SafePrintToken+                 -> E.SomeException+                 -> IO () displayException safePrintToken exception = safePrintLn safePrintToken (show exception)

@@ -1,80 +1,80 @@-module Eventloop.System.EventloopThread where
-
-import Control.DeepSeq
-import Control.Exception
-import Control.Monad
-import Control.Concurrent.ExceptionUtility
-import Control.Concurrent.MVar
-import Control.Concurrent.STM
-import Control.Concurrent.Datastructures.BlockingConcurrentQueue
-import Data.Maybe
-
-import Eventloop.System.Processing
-import Eventloop.Types.Common
-import Eventloop.Types.Exception
-import Eventloop.Types.Events
-import Eventloop.Types.System
-
-startEventlooping :: EventloopSystemConfiguration progstateT 
-                  -> IO ()
-startEventlooping systemConfig
-    = handle
-        ( \exception ->
-            case (fromException exception) of
-                (Just RequestShutdownException) -> throwIO RequestShutdownException
-                _                               -> throwIO (EventloopException exception)
-        )
-        ( do
-            putInBlockingConcurrentQueue inEventQueue_ Start
-            forever $ do
-              inEvent <- takeFromBlockingConcurrentQueue inEventQueue_ -- Take an In event
-              processedInEvents <- processEvents "Preprocessing" systemConfig modulePreprocessors [inEvent] -- Preprocess it
-              outEvents <- eventloopSteps eventloop progstateT_ processedInEvents  -- Eventloop over the preprocessed In events
-              processedOutEvents <- processEvents "Postprocessing" systemConfig modulePostprocessors outEvents -- Postprocess the Out events
-              evaluatedOutEvents <- evaluate $ force processedOutEvents
-              putAllInBlockingConcurrentQueue outEventQueue_ processedOutEvents -- Send the processed Out events to the OutRouter
-        )
-    where
-        eventloopConfig_ = eventloopConfig systemConfig
-        eventloop = eventloopFunc eventloopConfig_
-        progstateT_ = progstateT eventloopConfig_
-        inEventQueue_ = inEventQueue eventloopConfig_
-        outEventQueue_ = outEventQueue eventloopConfig_
-        moduleConfigurations_ = moduleConfigs systemConfig
-        modulePreprocessors = findProcessors moduleConfigurations_ preprocessorM
-        modulePostprocessors = findProcessors moduleConfigurations_ postprocessorM
-
-        
-findProcessors :: [EventloopModuleConfiguration]
-               -> (EventloopModuleConfiguration -> Maybe (SharedIOConstants -> TVar SharedIOState -> IOConstants -> TVar IOState -> event -> IO [event])) -- Pre-/Postprocessor function
-               -> [(EventloopModuleIdentifier, IOConstants, TVar IOState, (SharedIOConstants -> TVar SharedIOState -> IOConstants -> TVar IOState -> event -> IO [event]))]
-findProcessors moduleConfigs getProcessorFunc
-    = moduleProcessors
-    where
-        moduleProcessorsM = map (\moduleConfig -> (moduleId moduleConfig, ioConstants moduleConfig, ioStateT moduleConfig, getProcessorFunc moduleConfig)) moduleConfigs
-        moduleProcessorsJ = filter (\(_, _, _, processFuncM) -> isJust processFuncM) moduleProcessorsM
-        moduleProcessors = map (\(id, ioConst, iostate, (Just processFunc)) -> (id, ioConst, iostate, processFunc)) moduleProcessorsJ
-
-        
-eventloopSteps :: (progstateT -> In -> (progstateT, [Out])) {-^ eventloop function -}
-               -> TVar progstateT
-               -> [In]
-               -> IO [Out]
-eventloopSteps eventloop progstateT inEvents
-    =  sequencedSteps >>= (return.concat)
-    where
-        inEventSteps = map (eventloopStep eventloop progstateT) inEvents
-        sequencedSteps = sequence inEventSteps
-    
-        
-eventloopStep :: (progstateT -> In -> (progstateT, [Out])) {-^ eventloop function -}
-              -> TVar progstateT
-              -> In
-              -> IO [Out]
-eventloopStep eventloop progStateT inEvent
-    = do
-        progState <- readTVarIO progStateT
-        let
-            (progState', outEvents) = eventloop progState inEvent
-        atomically $ writeTVar progStateT progState'
+module Eventloop.System.EventloopThread where++import Control.DeepSeq+import Control.Exception+import Control.Monad+import Control.Concurrent.ExceptionUtility+import Control.Concurrent.MVar+import Control.Concurrent.STM+import Control.Concurrent.Datastructures.BlockingConcurrentQueue+import Data.Maybe++import Eventloop.System.Processing+import Eventloop.Types.Common+import Eventloop.Types.Exception+import Eventloop.Types.Events+import Eventloop.Types.System++startEventlooping :: EventloopSystemConfiguration progstateT+                  -> IO ()+startEventlooping systemConfig+    = handle+        ( \exception ->+            case (fromException exception) of+                (Just RequestShutdownException) -> throwIO RequestShutdownException+                _                               -> throwIO (EventloopException exception)+        )+        ( do+            putInBlockingConcurrentQueue inEventQueue_ Start+            forever $ do+              inEvent <- takeFromBlockingConcurrentQueue inEventQueue_ -- Take an In event+              processedInEvents <- processEvents "Preprocessing" systemConfig modulePreprocessors [inEvent] -- Preprocess it+              outEvents <- eventloopSteps eventloop progstateT_ processedInEvents  -- Eventloop over the preprocessed In events+              processedOutEvents <- processEvents "Postprocessing" systemConfig modulePostprocessors outEvents -- Postprocess the Out events+              evaluatedOutEvents <- evaluate $ force processedOutEvents+              putAllInBlockingConcurrentQueue outEventQueue_ processedOutEvents -- Send the processed Out events to the OutRouter+        )+    where+        eventloopConfig_ = eventloopConfig systemConfig+        eventloop = eventloopFunc eventloopConfig_+        progstateT_ = progstateT eventloopConfig_+        inEventQueue_ = inEventQueue eventloopConfig_+        outEventQueue_ = outEventQueue eventloopConfig_+        moduleConfigurations_ = moduleConfigs systemConfig+        modulePreprocessors = findProcessors moduleConfigurations_ preprocessorM+        modulePostprocessors = findProcessors moduleConfigurations_ postprocessorM+++findProcessors :: [EventloopModuleConfiguration]+               -> (EventloopModuleConfiguration -> Maybe (SharedIOConstants -> TVar SharedIOState -> IOConstants -> TVar IOState -> event -> IO [event])) -- Pre-/Postprocessor function+               -> [(EventloopModuleIdentifier, IOConstants, TVar IOState, (SharedIOConstants -> TVar SharedIOState -> IOConstants -> TVar IOState -> event -> IO [event]))]+findProcessors moduleConfigs getProcessorFunc+    = moduleProcessors+    where+        moduleProcessorsM = map (\moduleConfig -> (moduleId moduleConfig, ioConstants moduleConfig, ioStateT moduleConfig, getProcessorFunc moduleConfig)) moduleConfigs+        moduleProcessorsJ = filter (\(_, _, _, processFuncM) -> isJust processFuncM) moduleProcessorsM+        moduleProcessors = map (\(id, ioConst, iostate, (Just processFunc)) -> (id, ioConst, iostate, processFunc)) moduleProcessorsJ+++eventloopSteps :: (progstateT -> In -> (progstateT, [Out])) {-^ eventloop function -}+               -> TVar progstateT+               -> [In]+               -> IO [Out]+eventloopSteps eventloop progstateT inEvents+    =  sequencedSteps >>= (return.concat)+    where+        inEventSteps = map (eventloopStep eventloop progstateT) inEvents+        sequencedSteps = sequence inEventSteps+++eventloopStep :: (progstateT -> In -> (progstateT, [Out])) {-^ eventloop function -}+              -> TVar progstateT+              -> In+              -> IO [Out]+eventloopStep eventloop progStateT inEvent+    = do+        progState <- readTVarIO progStateT+        let+            (progState', outEvents) = eventloop progState inEvent+        atomically $ writeTVar progStateT progState'         return outEvents

@@ -1,59 +1,59 @@-module Eventloop.System.InitializationThread
-    ( startInitializing
-    ) where
-
-import Control.Exception
-import Control.Concurrent.STM
-import Data.List
-
-import Eventloop.Types.Exception
-import Eventloop.Types.System
-
-
-startInitializing :: EventloopSystemConfiguration progstateT
-                  -> IO (EventloopSystemConfiguration progstateT)
-startInitializing systemConfig
-    = do
-        sharedIO <- readTVarIO sharedIOT_
-        (sharedConst', sharedIO', moduleConfigs_') <- initializeModules sharedConst sharedIO moduleConfigs_
-        atomically $ writeTVar sharedIOT_ sharedIO'
-        return systemConfig{moduleConfigs = reverse $ moduleConfigs_', sharedIOConstants = sharedConst'}
-    where
-        sharedConst = sharedIOConstants systemConfig
-        sharedIOT_ = sharedIOStateT systemConfig
-        moduleConfigs_ = reverse $ moduleConfigs systemConfig
-
-
-initializeModules :: SharedIOConstants
-                  -> SharedIOState
-                  -> [EventloopModuleConfiguration]
-                  -> IO (SharedIOConstants, SharedIOState, [EventloopModuleConfiguration])
-initializeModules sharedConst sharedIO [] = return (sharedConst, sharedIO, [])
-initializeModules sharedConst sharedIO (moduleConfig:configs)
-    = do
-        (sharedConst', sharedIO', moduleConfig') <- initializeModule sharedConst sharedIO moduleConfig
-        (sharedConst'', sharedIO'', configs') <- initializeModules sharedConst' sharedIO' configs
-        return (sharedConst'', sharedIO'', moduleConfig':configs')
-
-
-initializeModule :: SharedIOConstants
-                 -> SharedIOState
-                 -> EventloopModuleConfiguration
-                 -> IO (SharedIOConstants, SharedIOState, EventloopModuleConfiguration)
-initializeModule sharedConst sharedIO moduleConfig
-    = case (initializerM moduleConfig) of
-        Nothing            -> return (sharedConst, sharedIO, moduleConfig)
-        (Just initializer) -> handle
-            ( \exception ->
-                throwIO (InitializationException moduleId_ exception)
-            )
-            ( do
-                ioState <- readTVarIO ioStateT_
-                (sharedConst', sharedIO', ioConst', ioState') <- initializer sharedConst sharedIO
-                atomically $ writeTVar ioStateT_ ioState'
-                return (sharedConst', sharedIO', moduleConfig {ioConstants = ioConst'})
-            )
-    where
-        moduleId_ = moduleId moduleConfig
-        ioConst = ioConstants moduleConfig
+module Eventloop.System.InitializationThread+    ( startInitializing+    ) where++import Control.Exception+import Control.Concurrent.STM+import Data.List++import Eventloop.Types.Exception+import Eventloop.Types.System+++startInitializing :: EventloopSystemConfiguration progstateT+                  -> IO (EventloopSystemConfiguration progstateT)+startInitializing systemConfig+    = do+        sharedIO <- readTVarIO sharedIOT_+        (sharedConst', sharedIO', moduleConfigs_') <- initializeModules sharedConst sharedIO moduleConfigs_+        atomically $ writeTVar sharedIOT_ sharedIO'+        return systemConfig{moduleConfigs = reverse $ moduleConfigs_', sharedIOConstants = sharedConst'}+    where+        sharedConst = sharedIOConstants systemConfig+        sharedIOT_ = sharedIOStateT systemConfig+        moduleConfigs_ = reverse $ moduleConfigs systemConfig+++initializeModules :: SharedIOConstants+                  -> SharedIOState+                  -> [EventloopModuleConfiguration]+                  -> IO (SharedIOConstants, SharedIOState, [EventloopModuleConfiguration])+initializeModules sharedConst sharedIO [] = return (sharedConst, sharedIO, [])+initializeModules sharedConst sharedIO (moduleConfig:configs)+    = do+        (sharedConst', sharedIO', moduleConfig') <- initializeModule sharedConst sharedIO moduleConfig+        (sharedConst'', sharedIO'', configs') <- initializeModules sharedConst' sharedIO' configs+        return (sharedConst'', sharedIO'', moduleConfig':configs')+++initializeModule :: SharedIOConstants+                 -> SharedIOState+                 -> EventloopModuleConfiguration+                 -> IO (SharedIOConstants, SharedIOState, EventloopModuleConfiguration)+initializeModule sharedConst sharedIO moduleConfig+    = case (initializerM moduleConfig) of+        Nothing            -> return (sharedConst, sharedIO, moduleConfig)+        (Just initializer) -> handle+            ( \exception ->+                throwIO (InitializationException moduleId_ exception)+            )+            ( do+                ioState <- readTVarIO ioStateT_+                (sharedConst', sharedIO', ioConst', ioState') <- initializer sharedConst sharedIO+                atomically $ writeTVar ioStateT_ ioState'+                return (sharedConst', sharedIO', moduleConfig {ioConstants = ioConst'})+            )+    where+        moduleId_ = moduleId moduleConfig+        ioConst = ioConstants moduleConfig         ioStateT_ = ioStateT moduleConfig

@@ -1,68 +1,68 @@-module Eventloop.System.OutRouterThread where
-
-import Control.Exception
-import Control.Monad
-import Control.Concurrent
-import Control.Concurrent.Datastructures.BlockingConcurrentQueue
-
-import Eventloop.OutRouter
-import Eventloop.Types.Common
-import Eventloop.Types.Events
-import Eventloop.Types.Exception
-import Eventloop.Types.System
-
-{- | Grab an outEvent from the outEventQueue and route it to the correct module sender if any.
-If there isn't one, throw a NoOutRouteException. The router will continue until it:
-- Comes across a Stop outEvent: Raises a RequestShutdownException
-- Raises an exception
-- Receives an exception (Only possibility is ShutdownException)
-In all cases, a Stop outEvent is sent to all module senders.
--}
-startOutRouting :: EventloopSystemConfiguration progstateT
-                -> IO ()
-startOutRouting systemConfig
-    = catch (forever $ do
-                outEvent <- takeFromBlockingConcurrentQueue outEventQueue_
-                case outEvent of
-                    Stop -> throwIO RequestShutdownException
-                    _    -> outRouteOne moduleIdsSenderQueues outEvent
-            )
-            (\exception -> do
-                outRouteBroadcastStop moduleIdsSenderQueues
-                throwIO (exception :: SomeException)
-            )
-    where
-        moduleIdsSenderQueues = outRoutes (moduleConfigs systemConfig)
-        outEventQueue_ = outEventQueue (eventloopConfig systemConfig)
-        
-
-outRoutes :: [EventloopModuleConfiguration] -> [(EventloopModuleIdentifier, SenderEventQueue)]
-outRoutes [] = []
-outRoutes (moduleConfig:mcs) = case (senderConfigM moduleConfig) of
-                                    Nothing                   -> outRoutes mcs
-                                    (Just moduleSenderConfig) -> (moduleId moduleConfig, senderEventQueue moduleSenderConfig):(outRoutes mcs)
-        
-        
-outRouteOne :: [(EventloopModuleIdentifier, SenderEventQueue)]
-            -> Out
-            -> IO ()
-outRouteOne targetIdsSenderQueues outEvent
-    = case targetSenderQueueM of
-        Nothing                  -> 
-            throwIO (NoOutRouteException outEvent)
-        (Just targetSenderQueue) ->
-            putInBlockingConcurrentQueue targetSenderQueue outEvent
-    where
-        targetModuleIdentifier = routeOutEvent outEvent
-        targetSenderQueueM = lookup targetModuleIdentifier targetIdsSenderQueues
-
-
-outRouteBroadcastStop :: [(EventloopModuleIdentifier, SenderEventQueue)]
-                      -> IO ()
-outRouteBroadcastStop []
-    = return ()
-outRouteBroadcastStop targetIdsSenderQueues
-    = mapM_ broadcastAction (map snd targetIdsSenderQueues)
-    where
-        broadcastAction targetSenderQueue =
+module Eventloop.System.OutRouterThread where++import Control.Exception+import Control.Monad+import Control.Concurrent+import Control.Concurrent.Datastructures.BlockingConcurrentQueue++import Eventloop.OutRouter+import Eventloop.Types.Common+import Eventloop.Types.Events+import Eventloop.Types.Exception+import Eventloop.Types.System++{- | Grab an outEvent from the outEventQueue and route it to the correct module sender if any.+If there isn't one, throw a NoOutRouteException. The router will continue until it:+- Comes across a Stop outEvent: Raises a RequestShutdownException+- Raises an exception+- Receives an exception (Only possibility is ShutdownException)+In all cases, a Stop outEvent is sent to all module senders.+-}+startOutRouting :: EventloopSystemConfiguration progstateT+                -> IO ()+startOutRouting systemConfig+    = catch (forever $ do+                outEvent <- takeFromBlockingConcurrentQueue outEventQueue_+                case outEvent of+                    Stop -> throwIO RequestShutdownException+                    _    -> outRouteOne moduleIdsSenderQueues outEvent+            )+            (\exception -> do+                outRouteBroadcastStop moduleIdsSenderQueues+                throwIO (exception :: SomeException)+            )+    where+        moduleIdsSenderQueues = outRoutes (moduleConfigs systemConfig)+        outEventQueue_ = outEventQueue (eventloopConfig systemConfig)+++outRoutes :: [EventloopModuleConfiguration] -> [(EventloopModuleIdentifier, SenderEventQueue)]+outRoutes [] = []+outRoutes (moduleConfig:mcs) = case (senderConfigM moduleConfig) of+                                    Nothing                   -> outRoutes mcs+                                    (Just moduleSenderConfig) -> (moduleId moduleConfig, senderEventQueue moduleSenderConfig):(outRoutes mcs)+++outRouteOne :: [(EventloopModuleIdentifier, SenderEventQueue)]+            -> Out+            -> IO ()+outRouteOne targetIdsSenderQueues outEvent+    = case targetSenderQueueM of+        Nothing                  ->+            throwIO (NoOutRouteException outEvent)+        (Just targetSenderQueue) ->+            putInBlockingConcurrentQueue targetSenderQueue outEvent+    where+        targetModuleIdentifier = routeOutEvent outEvent+        targetSenderQueueM = lookup targetModuleIdentifier targetIdsSenderQueues+++outRouteBroadcastStop :: [(EventloopModuleIdentifier, SenderEventQueue)]+                      -> IO ()+outRouteBroadcastStop []+    = return ()+outRouteBroadcastStop targetIdsSenderQueues+    = mapM_ broadcastAction (map snd targetIdsSenderQueues)+    where+        broadcastAction targetSenderQueue =             putInBlockingConcurrentQueue targetSenderQueue Stop

@@ -1,73 +1,73 @@-module Eventloop.System.Processing where
-
-import Control.Exception
-import Control.Concurrent.ExceptionUtility
-import Control.Concurrent.STM
-
-import Eventloop.Types.Common
-import Eventloop.Types.Exception
-import Eventloop.Types.Events
-import Eventloop.Types.System
-
-{-
-    To handle the pre-/postprocessing of in/out events
-    Per module is needed: (moduleIdentifier, ioStateT, processFunc)
-    Only modules with the appropriate processFunc are included if they exist
--}
-
-processEventWithModule :: ProcessingDescription
-                   -> SharedIOConstants
-                   -> TVar SharedIOState
-                   -> ( EventloopModuleIdentifier
-                      , IOConstants
-                      , TVar IOState
-                      , (SharedIOConstants -> TVar SharedIOState -> IOConstants -> TVar IOState -> event -> IO [event])
-                      )
-                   -> event
-                   -> IO [event]
-processEventWithModule processingDescription sharedConst sharedIOT (moduleId, ioConst, ioStateT, processFunc) event
-    = handle
-        ( \exception ->
-            throwIO (ProcessingException processingDescription moduleId exception)
-        )
-        ( do
-            processFunc sharedConst sharedIOT ioConst ioStateT event
-        )
-
-
-processEventsWithModules :: ProcessingDescription
-                         -> SharedIOConstants
-                         -> TVar SharedIOState
-                         -> [( EventloopModuleIdentifier
-                             , IOConstants
-                             , TVar IOState
-                             , (SharedIOConstants -> TVar SharedIOState -> IOConstants -> TVar IOState -> event -> IO [event])
-                             )]
-                         -> [event] 
-                         -> IO [event]
-processEventsWithModules _ _ _ _ []
-    = return []
-processEventsWithModules _ _ _ [] events
-    = return events
-processEventsWithModules processingDescription sharedConst sharedIOT (moduleProcessor:mps) (event:events)
-    = do
-        generatedEvents <- processEventWithModule processingDescription sharedConst sharedIOT moduleProcessor event
-        processedEvents <- processEventsWithModules processingDescription sharedConst sharedIOT mps generatedEvents
-        restProcessedEvents <- processEventsWithModules processingDescription sharedConst sharedIOT (moduleProcessor:mps) events
-        return (processedEvents ++ restProcessedEvents)       
-                                  
-                                  
-processEvents :: ProcessingDescription
-              -> EventloopSystemConfiguration progstateT
-              -> [( EventloopModuleIdentifier
-                  , IOConstants
-                  , TVar IOState
-                  , (SharedIOConstants -> TVar SharedIOState -> IOConstants -> TVar IOState -> event -> IO [event])
-                  )]
-              -> [event] 
-              -> IO [event]
-processEvents processingDescription systemConfig moduleProcessors events
-    = processEventsWithModules processingDescription sharedConst sharedIOT moduleProcessors events
-    where
-        sharedIOT = sharedIOStateT systemConfig
+module Eventloop.System.Processing where++import Control.Exception+import Control.Concurrent.ExceptionUtility+import Control.Concurrent.STM++import Eventloop.Types.Common+import Eventloop.Types.Exception+import Eventloop.Types.Events+import Eventloop.Types.System++{-+    To handle the pre-/postprocessing of in/out events+    Per module is needed: (moduleIdentifier, ioStateT, processFunc)+    Only modules with the appropriate processFunc are included if they exist+-}++processEventWithModule :: ProcessingDescription+                   -> SharedIOConstants+                   -> TVar SharedIOState+                   -> ( EventloopModuleIdentifier+                      , IOConstants+                      , TVar IOState+                      , (SharedIOConstants -> TVar SharedIOState -> IOConstants -> TVar IOState -> event -> IO [event])+                      )+                   -> event+                   -> IO [event]+processEventWithModule processingDescription sharedConst sharedIOT (moduleId, ioConst, ioStateT, processFunc) event+    = handle+        ( \exception ->+            throwIO (ProcessingException processingDescription moduleId exception)+        )+        ( do+            processFunc sharedConst sharedIOT ioConst ioStateT event+        )+++processEventsWithModules :: ProcessingDescription+                         -> SharedIOConstants+                         -> TVar SharedIOState+                         -> [( EventloopModuleIdentifier+                             , IOConstants+                             , TVar IOState+                             , (SharedIOConstants -> TVar SharedIOState -> IOConstants -> TVar IOState -> event -> IO [event])+                             )]+                         -> [event]+                         -> IO [event]+processEventsWithModules _ _ _ _ []+    = return []+processEventsWithModules _ _ _ [] events+    = return events+processEventsWithModules processingDescription sharedConst sharedIOT (moduleProcessor:mps) (event:events)+    = do+        generatedEvents <- processEventWithModule processingDescription sharedConst sharedIOT moduleProcessor event+        processedEvents <- processEventsWithModules processingDescription sharedConst sharedIOT mps generatedEvents+        restProcessedEvents <- processEventsWithModules processingDescription sharedConst sharedIOT (moduleProcessor:mps) events+        return (processedEvents ++ restProcessedEvents)+++processEvents :: ProcessingDescription+              -> EventloopSystemConfiguration progstateT+              -> [( EventloopModuleIdentifier+                  , IOConstants+                  , TVar IOState+                  , (SharedIOConstants -> TVar SharedIOState -> IOConstants -> TVar IOState -> event -> IO [event])+                  )]+              -> [event]+              -> IO [event]+processEvents processingDescription systemConfig moduleProcessors events+    = processEventsWithModules processingDescription sharedConst sharedIOT moduleProcessors events+    where+        sharedIOT = sharedIOStateT systemConfig         sharedConst = sharedIOConstants systemConfig

@@ -1,45 +1,45 @@-module Eventloop.System.RetrieverThread where
-
-import Control.Exception
-import Control.Monad
-import Control.Concurrent.STM
-import Control.Concurrent.Datastructures.BlockingConcurrentQueue
-
-import Eventloop.Types.Common
-import Eventloop.Types.Exception
-import Eventloop.Types.System
-
-startRetrieving :: EventloopSystemConfiguration progstateT
-                -> (EventloopModuleConfiguration, EventRetriever)
-                -> IO ()
-startRetrieving systemConfig (moduleConfig, retriever)
-    = forever (retrieveOne moduleId_ sharedConst sharedIOStateT_ ioConst ioStateT_ retriever inEventQueue_)
-    where
-        moduleId_ = moduleId moduleConfig
-        eventloopConfiguration = eventloopConfig systemConfig
-        sharedConst = sharedIOConstants systemConfig
-        sharedIOStateT_ = sharedIOStateT systemConfig
-        inEventQueue_ = inEventQueue eventloopConfiguration
-        ioConst = ioConstants moduleConfig
-        ioStateT_ = ioStateT moduleConfig
-
-
-retrieveOne :: EventloopModuleIdentifier ->
-               SharedIOConstants ->
-               TVar SharedIOState ->
-               IOConstants ->
-               TVar IOState ->
-               EventRetriever ->
-               InEventQueue ->
-               IO ()
-retrieveOne moduleId sharedConst sharedIOT ioConst iostateT retriever inEventQueue
-    = handle ( \exception ->
-                -- Wrap the exception if it isn't a ShuttingDownException
-                case (fromException exception) of
-                    (Just ShuttingDownException) -> throwIO ShuttingDownException
-                    _                            -> throwIO (RetrievingException moduleId exception)
-            )
-            ( do
-                inEvents <- retriever sharedConst sharedIOT ioConst iostateT
-                putAllInBlockingConcurrentQueue inEventQueue inEvents
+module Eventloop.System.RetrieverThread where++import Control.Exception+import Control.Monad+import Control.Concurrent.STM+import Control.Concurrent.Datastructures.BlockingConcurrentQueue++import Eventloop.Types.Common+import Eventloop.Types.Exception+import Eventloop.Types.System++startRetrieving :: EventloopSystemConfiguration progstateT+                -> (EventloopModuleConfiguration, EventRetriever)+                -> IO ()+startRetrieving systemConfig (moduleConfig, retriever)+    = forever (retrieveOne moduleId_ sharedConst sharedIOStateT_ ioConst ioStateT_ retriever inEventQueue_)+    where+        moduleId_ = moduleId moduleConfig+        eventloopConfiguration = eventloopConfig systemConfig+        sharedConst = sharedIOConstants systemConfig+        sharedIOStateT_ = sharedIOStateT systemConfig+        inEventQueue_ = inEventQueue eventloopConfiguration+        ioConst = ioConstants moduleConfig+        ioStateT_ = ioStateT moduleConfig+++retrieveOne :: EventloopModuleIdentifier ->+               SharedIOConstants ->+               TVar SharedIOState ->+               IOConstants ->+               TVar IOState ->+               EventRetriever ->+               InEventQueue ->+               IO ()+retrieveOne moduleId sharedConst sharedIOT ioConst iostateT retriever inEventQueue+    = handle ( \exception ->+                -- Wrap the exception if it isn't a ShuttingDownException+                case (fromException exception) of+                    (Just ShuttingDownException) -> throwIO ShuttingDownException+                    _                            -> throwIO (RetrievingException moduleId exception)+            )+            ( do+                inEvents <- retriever sharedConst sharedIOT ioConst iostateT+                putAllInBlockingConcurrentQueue inEventQueue inEvents             )

@@ -1,50 +1,50 @@-module Eventloop.System.SenderThread where
-
-import Control.Exception
-import Control.Monad
-import Control.Concurrent.STM
-import Control.Concurrent.Datastructures.BlockingConcurrentQueue
-
-import Eventloop.Types.Common
-import Eventloop.Types.Events
-import Eventloop.Types.Exception
-import Eventloop.Types.System
-
-startSending :: EventloopSystemConfiguration progstateT 
-             -> (EventloopModuleConfiguration, EventloopModuleSenderConfiguration)
-             -> IO ()
-startSending systemConfig (moduleConfig, moduleSenderConfig)
-    = forever $ do
-        outEvent <- takeFromBlockingConcurrentQueue senderEventQueue_
-        case outEvent of
-            Stop -> do
-                        sendOne moduleId_ sharedConst sharedIOT ioConst ioStateT_ sender_ Stop
-                        throwIO RequestShutdownException
-            _    -> sendOne moduleId_ sharedConst sharedIOT ioConst ioStateT_ sender_ outEvent
-    where
-        moduleId_ = moduleId moduleConfig
-        sharedConst = sharedIOConstants systemConfig
-        sharedIOT = sharedIOStateT systemConfig
-        ioConst = ioConstants moduleConfig
-        ioStateT_ = ioStateT moduleConfig
-        sender_ = sender moduleSenderConfig
-        senderEventQueue_ = senderEventQueue moduleSenderConfig
-
-                
-sendOne :: EventloopModuleIdentifier
-        -> SharedIOConstants
-        -> TVar SharedIOState
-        -> IOConstants
-        -> TVar IOState
-        -> EventSender
-        -> Out
-        -> IO ()
-sendOne moduleId sharedConst sharedIOT ioConst ioStateT sender outEvent
-    = handle ( \exception ->
-                -- Wrap the exception if it isn't a ShuttingDownException
-                case (fromException exception) of
-                    (Just ShuttingDownException) -> throwIO ShuttingDownException
-                    _                            -> throwIO (SendingException moduleId outEvent exception)
-            )
-            ( sender sharedConst sharedIOT ioConst ioStateT outEvent
+module Eventloop.System.SenderThread where++import Control.Exception+import Control.Monad+import Control.Concurrent.STM+import Control.Concurrent.Datastructures.BlockingConcurrentQueue++import Eventloop.Types.Common+import Eventloop.Types.Events+import Eventloop.Types.Exception+import Eventloop.Types.System++startSending :: EventloopSystemConfiguration progstateT+             -> (EventloopModuleConfiguration, EventloopModuleSenderConfiguration)+             -> IO ()+startSending systemConfig (moduleConfig, moduleSenderConfig)+    = forever $ do+        outEvent <- takeFromBlockingConcurrentQueue senderEventQueue_+        case outEvent of+            Stop -> do+                        sendOne moduleId_ sharedConst sharedIOT ioConst ioStateT_ sender_ Stop+                        throwIO RequestShutdownException+            _    -> sendOne moduleId_ sharedConst sharedIOT ioConst ioStateT_ sender_ outEvent+    where+        moduleId_ = moduleId moduleConfig+        sharedConst = sharedIOConstants systemConfig+        sharedIOT = sharedIOStateT systemConfig+        ioConst = ioConstants moduleConfig+        ioStateT_ = ioStateT moduleConfig+        sender_ = sender moduleSenderConfig+        senderEventQueue_ = senderEventQueue moduleSenderConfig+++sendOne :: EventloopModuleIdentifier+        -> SharedIOConstants+        -> TVar SharedIOState+        -> IOConstants+        -> TVar IOState+        -> EventSender+        -> Out+        -> IO ()+sendOne moduleId sharedConst sharedIOT ioConst ioStateT sender outEvent+    = handle ( \exception ->+                -- Wrap the exception if it isn't a ShuttingDownException+                case (fromException exception) of+                    (Just ShuttingDownException) -> throwIO ShuttingDownException+                    _                            -> throwIO (SendingException moduleId outEvent exception)+            )+            ( sender sharedConst sharedIOT ioConst ioStateT outEvent             )

@@ -1,91 +1,91 @@-module Eventloop.System.Setup
-    ( setupEventloopSystemConfig
-    ) where
-
-import Control.Concurrent
-import Control.Concurrent.ExceptionCollection
-import Control.Concurrent.MVar
-import Control.Concurrent.STM
-import Control.Concurrent.Datastructures.BlockingConcurrentQueue
-
-import Eventloop.DefaultConfiguration
-import Eventloop.Types.System
-
-
-setupEventloopSystemConfig :: EventloopSetupConfiguration progstateT 
-                           -> IO (EventloopSystemConfiguration progstateT)
-setupEventloopSystemConfig setupConfig
-    = do
-        eventloopConfig_ <- setupEventloopConfiguration setupConfig
-        moduleConfigurations_ <- mapM setupEventloopModuleConfig (setupModuleConfigurations setupConfig)
-        sharedIOConst <- setupSharedIOConstants
-        sharedIOState_ <- setupSharedIOState
-        sharedIOStateT_ <- newTVarIO sharedIOState_
-        systemThreadId_ <- myThreadId
-        retrieverThreadsM_ <- newMVar []
-        outRouterThreadM_ <- newEmptyMVar
-        senderThreadsM_ <- newMVar []
-        exceptionCollection <- createExceptionCollection
-        isStoppingM_ <- newMVar False
-        
-        return ( EventloopSystemConfiguration
-                    eventloopConfig_
-                    moduleConfigurations_
-                    sharedIOConst
-                    sharedIOStateT_
-                    systemThreadId_
-                    retrieverThreadsM_
-                    outRouterThreadM_
-                    senderThreadsM_
-                    exceptionCollection
-                    isStoppingM_
-               )
-        
-
-setupEventloopConfiguration :: EventloopSetupConfiguration progstateT
-                            -> IO (EventloopConfiguration progstateT)
-setupEventloopConfiguration setupConfig
-    = do
-        progStateT_ <- newTVarIO (beginProgstate setupConfig)
-        inEventQueue_ <- createBlockingConcurrentQueue
-        outEventQueue_ <- createBlockingConcurrentQueue
-        
-        return ( EventloopConfiguration
-                    progStateT_
-                    (eventloopF setupConfig)
-                    inEventQueue_
-                    outEventQueue_
-               )
-        
-        
-setupEventloopModuleConfig :: EventloopSetupModuleConfiguration
-                           -> IO EventloopModuleConfiguration
-setupEventloopModuleConfig setupModuleConfig
-    = do
-        ioStateT <- newTVarIO NoState
-        senderConfig <- setupEventloopModuleSenderConfiguration (eventSenderF setupModuleConfig)
-        
-        return ( EventloopModuleConfiguration
-                    (moduleIdentifier setupModuleConfig)
-                    NoConstants
-                    ioStateT
-                    (initializerF setupModuleConfig)
-                    (eventRetrieverF setupModuleConfig)
-                    (preprocessorF setupModuleConfig)
-                    (postprocessorF setupModuleConfig)
-                    senderConfig
-                    (teardownF setupModuleConfig)
-               )
-    where
-        moduleId_ = moduleIdentifier setupModuleConfig
-        
-
-
-setupEventloopModuleSenderConfiguration :: Maybe EventSender 
-                                        -> IO (Maybe EventloopModuleSenderConfiguration)
-setupEventloopModuleSenderConfiguration Nothing = return Nothing
-setupEventloopModuleSenderConfiguration (Just eventSender_)
-    = do
-        senderEventQueue_ <- createBlockingConcurrentQueue
-        
+module Eventloop.System.Setup+    ( setupEventloopSystemConfig+    ) where++import Control.Concurrent+import Control.Concurrent.ExceptionCollection+import Control.Concurrent.MVar+import Control.Concurrent.STM+import Control.Concurrent.Datastructures.BlockingConcurrentQueue++import Eventloop.DefaultConfiguration+import Eventloop.Types.System+++setupEventloopSystemConfig :: EventloopSetupConfiguration progstateT+                           -> IO (EventloopSystemConfiguration progstateT)+setupEventloopSystemConfig setupConfig+    = do+        eventloopConfig_ <- setupEventloopConfiguration setupConfig+        moduleConfigurations_ <- mapM setupEventloopModuleConfig (setupModuleConfigurations setupConfig)+        sharedIOConst <- setupSharedIOConstants+        sharedIOState_ <- setupSharedIOState+        sharedIOStateT_ <- newTVarIO sharedIOState_+        systemThreadId_ <- myThreadId+        retrieverThreadsM_ <- newMVar []+        outRouterThreadM_ <- newEmptyMVar+        senderThreadsM_ <- newMVar []+        exceptionCollection <- createExceptionCollection+        isStoppingM_ <- newMVar False++        return ( EventloopSystemConfiguration+                    eventloopConfig_+                    moduleConfigurations_+                    sharedIOConst+                    sharedIOStateT_+                    systemThreadId_+                    retrieverThreadsM_+                    outRouterThreadM_+                    senderThreadsM_+                    exceptionCollection+                    isStoppingM_+               )+++setupEventloopConfiguration :: EventloopSetupConfiguration progstateT+                            -> IO (EventloopConfiguration progstateT)+setupEventloopConfiguration setupConfig+    = do+        progStateT_ <- newTVarIO (beginProgstate setupConfig)+        inEventQueue_ <- createBlockingConcurrentQueue+        outEventQueue_ <- createBlockingConcurrentQueue++        return ( EventloopConfiguration+                    progStateT_+                    (eventloopF setupConfig)+                    inEventQueue_+                    outEventQueue_+               )+++setupEventloopModuleConfig :: EventloopSetupModuleConfiguration+                           -> IO EventloopModuleConfiguration+setupEventloopModuleConfig setupModuleConfig+    = do+        ioStateT <- newTVarIO NoState+        senderConfig <- setupEventloopModuleSenderConfiguration (eventSenderF setupModuleConfig)++        return ( EventloopModuleConfiguration+                    (moduleIdentifier setupModuleConfig)+                    NoConstants+                    ioStateT+                    (initializerF setupModuleConfig)+                    (eventRetrieverF setupModuleConfig)+                    (preprocessorF setupModuleConfig)+                    (postprocessorF setupModuleConfig)+                    senderConfig+                    (teardownF setupModuleConfig)+               )+    where+        moduleId_ = moduleIdentifier setupModuleConfig++++setupEventloopModuleSenderConfiguration :: Maybe EventSender+                                        -> IO (Maybe EventloopModuleSenderConfiguration)+setupEventloopModuleSenderConfiguration Nothing = return Nothing+setupEventloopModuleSenderConfiguration (Just eventSender_)+    = do+        senderEventQueue_ <- createBlockingConcurrentQueue+         return (Just (EventloopModuleSenderConfiguration eventSender_ senderEventQueue_))