packages feed

codemonitor 0.1 → 0.2

raw patch · 15 files changed

+367/−234 lines, 15 filesdep +MissingH

Dependencies added: MissingH

Files

LICENSE view
@@ -1,10 +1,30 @@-Copyright (c) 2012, Rickard Lindberg+Copyright (c)2012, Rickard Lindberg+ All rights reserved. -Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:+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 the author nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.+    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer. -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 HOLDER 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.+    * 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 Rickard Lindberg 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.
codemonitor.cabal view
@@ -1,5 +1,5 @@ name:           codemonitor-version:        0.1+version:        0.2 synopsis:       Tool that automatically runs arbitrary commands when files change on disk. description:    Tool that automatically runs arbitrary commands when files change on disk. category:       Tool@@ -17,17 +17,18 @@  source-repository head   type:     git-  location: http://github.com/rickardlindberg/codemonitor+  location: git://github.com/rickardlindberg/codemonitor.git  executable codemonitor   main-is:            Main.hs   other-modules:      Config                ,      Job-               ,      Layout+               ,      Job.Types                ,      Monitor                ,      Notifier-               ,      Rect-               ,      Render+               ,      Render.Graphics+               ,      Render.Layout+               ,      Render.Rect   hs-source-dirs:     src   if flag(dev)     ghc-options:      -fwarn-unused-imports -Werror@@ -42,3 +43,4 @@                ,      filepath                ,      directory                ,      time+               ,      MissingH
src/Config.hs view
@@ -1,11 +1,13 @@ module Config where -import Job+import Job.Types import Monitor  create :: FilePath -> IO (String, Jobs, [Monitor])-create configPath = do-    content <- readFile configPath+create configPath = readFile configPath >>= createFromConfig++createFromConfig :: String -> IO (String, Jobs, [Monitor])+createFromConfig content = do     let (watchDir:rest) = lines content     let jobs = map jobDefToJob rest     let monitors = map jobToMonitor jobs@@ -14,6 +16,9 @@ jobDefToJob :: String -> Job jobDefToJob def =     let (id:pattern:command:args) = words def-    in processJob id command args pattern+    in createJob id command args pattern -jobToMonitor job = JobMonitor (jobId job) 0 (fullName job) (status job)+jobToMonitor job =+    case jobId job of+        'o':'m':_ -> StdoutMonitor (jobId job) 0 (fullName job) ""+        _         -> StatusCodeMonitor (jobId job) 0 (fullName job) (status job) ""
src/Job.hs view
@@ -1,43 +1,17 @@ module Job where  import Control.Concurrent+import Job.Types import System.Exit import System.Process import Text.Regex.Posix -data Jobs = Jobs [Job]--createJobs :: [Job] -> Jobs-createJobs = Jobs--jobWithId :: Jobs -> String -> Job-jobWithId (Jobs jobs) id = find jobs-    where-        find [] = error "gaaah"-        find (x:xs) | jobId x == id = x-                    | otherwise     = find xs--data Job = Job-    { jobId     :: String-    , name      :: String-    , args      :: [String]-    , matchExpr :: String-    , status    :: Status-    , thread    :: Maybe ThreadId-    }--data Status = Idle | Working | Fail String deriving (Eq)--fullName :: Job -> String-fullName (Job { name = name, args = args }) = name ++ " " ++ unwords args--processJob :: String -> String -> [String] -> String -> Job-processJob jobId name args expr = Job jobId name args expr Idle Nothing+type Signaller = String -> Status -> String -> IO () -runAllJobs :: (String -> Status -> IO ()) -> Jobs -> IO Jobs+runAllJobs :: Signaller -> Jobs -> IO Jobs runAllJobs signalResult (Jobs jobs) = fmap Jobs (mapM (reRunJob signalResult) jobs) -reRunJobs :: FilePath -> (String -> Status -> IO ()) -> Jobs -> IO Jobs+reRunJobs :: FilePath -> Signaller -> Jobs -> IO Jobs reRunJobs fileChanged signalResult (Jobs jobs) = fmap Jobs (mapM reRunIfMatch jobs)     where         reRunIfMatch job =@@ -45,30 +19,33 @@                 then reRunJob signalResult job                 else return job -reRunJob :: (String -> Status -> IO ()) -> Job -> IO Job+reRunJob :: Signaller -> Job -> IO Job reRunJob signalResult job = do     cancel job     -- NOTE: signalResult must be called asynchronoulsy, otherwise the lock for     -- jobsRef will deadlock.     threadId <- forkIO $ runThread job signalResult-    return $ job { thread = Just threadId, status = Working }+    return $ job { thread = Just threadId, status = Working, output = "" }  cancel :: Job -> IO () cancel Job { thread = Just id } = killThread id cancel _                        = return () -runThread :: Job -> (String -> Status -> IO ()) -> IO ()+runThread :: Job -> Signaller -> IO () runThread job signalResult = do     -- NOTE: Is the process killed if this thread is killed? If not, is that     -- the reason why we get resource exhaustion sometimes?     (exit, stdout, stderr) <- readProcessWithExitCode (name job) (args job) ""     if exit == ExitSuccess-        then signalResult (jobId job) Idle-        else signalResult (jobId job) (Fail $ stderr ++ stdout)+        then signalResult (jobId job) Idle (stderr ++ stdout)+        else signalResult (jobId job) Fail (stderr ++ stdout) -updateJobStatus :: String -> Status -> Jobs -> Jobs-updateJobStatus theId status (Jobs jobs) = Jobs (map updateJobInner jobs)+updateJobStatus :: String -> Status -> String -> Jobs -> Jobs+updateJobStatus theId status newOutput (Jobs jobs) = Jobs (map updateJobInner jobs)     where         updateJobInner job-            | jobId job == theId = job { status = status, thread = Nothing }+            | jobId job == theId = job { status = status+                                       , thread = Nothing+                                       , output = output job ++ newOutput+                                       }             | otherwise          = job
+ src/Job/Types.hs view
@@ -0,0 +1,36 @@+module Job.Types where++import Control.Concurrent++data Status = Idle+            | Working+            | Fail+            deriving (Eq, Show)++data Job = Job+    { jobId     :: String+    , name      :: String+    , args      :: [String]+    , matchExpr :: String+    , status    :: Status+    , output    :: String+    , thread    :: Maybe ThreadId+    }++data Jobs = Jobs [Job]++createJob :: String -> String -> [String] -> String -> Job+createJob jobId name args expr = Job jobId name args expr Idle "" Nothing++createJobs :: [Job] -> Jobs+createJobs = Jobs++jobWithId :: Jobs -> String -> Job+jobWithId (Jobs jobs) id = find jobs+    where+        find [] = error "gaaah"+        find (x:xs) | jobId x == id = x+                    | otherwise     = find xs++fullName :: Job -> String+fullName (Job { name = name, args = args }) = name ++ " " ++ unwords args
− src/Layout.hs 
@@ -1,50 +0,0 @@-module Layout where--import Data.Maybe-import Job-import Monitor-import qualified Data.Map as M-import Rect--data RectType = Small-              | Large-              deriving (Eq, Ord)--type RectMap = M.Map RectType [Rect]--findRects :: Rect -> [Monitor] -> [(Monitor, Rect)]-findRects originalRect monitors = match monitors rectMap-    where-        rectMap           = rectsForTypes originalRect monitors-        match []     _    = []-        match (m:ms) mmap = let (rect, restMap) = rectMapPop (rectType m) mmap-                            in (m, rect):match ms restMap--rectsForTypes :: Rect -> [Monitor] -> RectMap-rectsForTypes originalRect monitors =-    let types     = map rectType monitors-        numSmalle = length $ filter (==Small) types-        numLarge  = length $ filter (==Large) types-        smallArea = if numLarge == 0-                        then snd $ divideVertical originalRect 0.7-                        else snd $ divideVertical originalRect 0.9-        largeArea = if numSmalle == 0-                        then originalRect-                        else fst (divideVertical originalRect 0.9)-    in rectMapCreate-           [ (Small, splitHorizontal smallArea numSmalle)-           , (Large, splitVertical largeArea numLarge)-           ]--rectType :: Monitor -> RectType-rectType (JobMonitor { mJobStatus = Fail _ }) = Large-rectType _                                    = Small--rectMapPop :: RectType -> RectMap -> (Rect, RectMap)-rectMapPop t m = let rects     = fromJust $ M.lookup t m-                     firstRect = head rects-                     restRects = tail rects-                 in (firstRect, M.insert t restRects m)--rectMapCreate :: [(RectType, [Rect])] -> RectMap-rectMapCreate = M.fromList
src/Main.hs view
@@ -6,9 +6,10 @@ import Data.Time.Clock import Graphics.UI.Gtk import Job+import Job.Types import Monitor import Notifier-import Render+import Render.Graphics import System  main :: IO ()@@ -26,7 +27,10 @@     let forceRedraw = postGUIAsync $ widgetQueueDraw canvas      args <- getArgs-    (watchDir, jobs, monitors) <- create (head args)+    (watchDir, jobs, monitors) <-+        case args of+            [path] -> create path+            []     -> getContents >>= createFromConfig      lock <- newEmptyMVar     jobsRef <- newIORef jobs@@ -40,7 +44,7 @@     setupNotifications watchDir (onFileChanged withJobLock forceRedraw)     onInit withJobLock forceRedraw -    timeoutAddFull (forceRedraw >> return True) priorityDefaultIdle 10+    timeoutAddFull (forceRedraw >> return True) priorityDefaultIdle 100      mainWindow `onDestroy` mainQuit     canvas     `onExpose`  redraw canvas timeRef jobsRef monitorsRef@@ -80,7 +84,7 @@     withJobLock (reRunJobs filePath (onStatusChanged withJobLock forceRedraw))     forceRedraw -onStatusChanged :: ((Jobs -> IO Jobs) -> IO ()) -> IO () -> String -> Status -> IO ()-onStatusChanged withJobLock forceRedraw id status = do-    withJobLock (return . updateJobStatus id status)+onStatusChanged :: ((Jobs -> IO Jobs) -> IO ()) -> IO () -> Signaller+onStatusChanged withJobLock forceRedraw id status newOutput = do+    withJobLock (return . updateJobStatus id status newOutput)     forceRedraw
src/Monitor.hs view
@@ -1,21 +1,38 @@ module Monitor where -import Job+import Job.Types -data Monitor = JobMonitor { mJobId          :: String-                          , mSecondsInState :: Double-                          , mJobName        :: String-                          , mJobStatus      :: Status-                          }+data Monitor = StatusCodeMonitor+                { mJobId          :: String+                , mSecondsInState :: Double+                , mJobName        :: String+                , mJobStatus      :: Status+                , mOutput         :: String+                }+             | StdoutMonitor+                { mJobId          :: String+                , mSecondsInState :: Double+                , mJobName        :: String+                , mOutput         :: String+                }+             deriving (Show, Eq)  updateMonitors :: Double -> Jobs -> [Monitor] -> [Monitor] updateMonitors secondsSinceLastUpdate jobs = map updateMonitor     where-        updateMonitor monitor@(JobMonitor {}) =+        updateMonitor monitor@(StatusCodeMonitor {}) =             let newStatus  = status $ jobWithId jobs (mJobId monitor)+                newOutput  = output $ jobWithId jobs (mJobId monitor)                 newSeconds = if mJobStatus monitor == newStatus                                 then secondsSinceLastUpdate + mSecondsInState monitor                                 else 0-            in monitor { mJobStatus      = newStatus-                       , mSecondsInState = newSeconds+            in monitor { mSecondsInState = newSeconds+                       , mJobStatus      = newStatus+                       , mOutput         = newOutput+                       }+        updateMonitor monitor@(StdoutMonitor {}) =+            let newOutput  = output $ jobWithId jobs (mJobId monitor)+                newSeconds = secondsSinceLastUpdate + mSecondsInState monitor+            in monitor { mSecondsInState = newSeconds+                       , mOutput         = newOutput                        }
− src/Rect.hs 
@@ -1,22 +0,0 @@-module Rect where--data Rect = Rect Double Double Double Double deriving (Eq, Show)--shrink :: Double -> Rect -> Rect-shrink by (Rect x y w h) = Rect (x+by) (y+by) (w-2*by) (h-2*by)--divideVertical :: Rect -> Double -> (Rect, Rect)-divideVertical (Rect x y w h) percent = (Rect x y w splitH, Rect x splitH w (h - splitH))-    where splitH = percent * h--splitVertical :: Rect -> Int -> [Rect]-splitVertical (Rect x y w h) n = map calcNew [1..n]-    where-        calcNew n = Rect x (y+(fromIntegral n-1)*newH) w newH-        newH = h / fromIntegral n--splitHorizontal :: Rect -> Int -> [Rect]-splitHorizontal (Rect x y w h) n = map calcNew [1..n]-    where-        calcNew n = Rect (x+(fromIntegral n -1)*newW) y newW h-        newW = w / fromIntegral n
− src/Render.hs 
@@ -1,91 +0,0 @@-module Render where--import Control.Arrow-import Control.Monad-import Graphics.Rendering.Cairo hiding (status, Status)-import Job-import Layout-import Monitor-import Rect--boxRadius = 10.0-innerSpace = 2-outerSpace = innerSpace/2-fontName = "Monospace"-fontSize = 11.0--renderScreen :: [Monitor] -> Double -> Double -> Render ()-renderScreen monitors w h = do-    renderBackground-    renderMonitors monitors (shrink outerSpace $ Rect 0 0 w h)--renderBackground :: Render ()-renderBackground = do-    setSourceRGB 1 1 0.6-    paint--renderMonitors :: [Monitor] -> Rect -> Render ()-renderMonitors monitors rect = do-    let mr       = findRects rect monitors-    let mrShrunk = map (second $ shrink innerSpace) mr-    forM_ mrShrunk renderMonitor--renderMonitor :: (Monitor, Rect) -> Render ()-renderMonitor (monitor@JobMonitor {}, rect@(Rect x y w h)) = do-    -- Background-    let (r, g, b, a) = statusToBgColor (mSecondsInState monitor) (mJobStatus monitor)-    setSourceRGBA r g b a-    roundRectPath rect-    fillPreserve-    setSourceRGBA 0 0 0 0.4-    setLineWidth 1.5-    stroke-    -- Title-    selectFontFace fontName FontSlantNormal FontWeightBold-    setFontSize fontSize-    setSourceRGBA 0 0 0 0.7-    ex <- textExtents (mJobName monitor)-    moveTo (x + boxRadius - textExtentsXbearing ex) (y + boxRadius - textExtentsYbearing ex)-    showText (mJobName monitor)-    -- Additional text-    selectFontFace fontName FontSlantNormal FontWeightNormal-    setFontSize fontSize-    setSourceRGBA 0 0 0 0.8-    moveTo (x + 10) (y+20)-    ex2 <- fontExtents-    let errors = additionalLines (mJobStatus monitor)-    let ys = map (\x -> fromIntegral x*fontExtentsHeight ex2 + y + boxRadius + 2*textExtentsHeight ex) [1..length errors]-    forM_ (zip errors ys) $ \(e, y) -> do-        moveTo (x + boxRadius + boxRadius) y-        showText e-    return ()--statusToBgColor :: Double -> Status -> (Double, Double, Double, Double)-statusToBgColor t Idle     = (121/255, 245/255, 0, 1)-statusToBgColor t Working  = (0, 204/255, 245/255, circularMovement 1 0.5 2 t)-statusToBgColor t (Fail _) = (245/255, 36/255, 0, circularMovement 1 0.7 0.5 t)--circularMovement :: Double -> Double -> Double -> Double -> Double-circularMovement start end animationTime totalTime = res-    where-        rest    = totalTime - animationTime * fromIntegral (floor $ totalTime / animationTime)-        percent = rest / animationTime-        d1      = end - start-        d2      = start - end-        p2      = percent * 2-        res     = if p2 <= 1-                      then start + d1 * percent-                      else end   + d2 * percent--roundRectPath :: Rect -> Render ()-roundRectPath (Rect x y w h) = do-    newPath-    arc (x+w-boxRadius) (y+  boxRadius) boxRadius ((-90) * pi/180) (0   * pi/180)-    arc (x+w-boxRadius) (y+h-boxRadius) boxRadius (0     * pi/180) (90  * pi/180)-    arc (x+  boxRadius) (y+h-boxRadius) boxRadius (90    * pi/180) (180 * pi/180)-    arc (x+  boxRadius) (y+  boxRadius) boxRadius (180   * pi/180) (270 * pi/180)-    closePath--additionalLines :: Status -> [String]-additionalLines (Fail s) = lines s-additionalLines _        = []
+ src/Render/Graphics.hs view
@@ -0,0 +1,138 @@+module Render.Graphics where++import Control.Arrow+import Control.Monad+import Data.List.Utils+import Graphics.Rendering.Cairo hiding (status, Status)+import Job.Types+import Monitor+import Render.Layout+import Render.Rect++type Color = (Double, Double, Double, Double)++boxRadius = 10.0+innerSpace = 2+outerSpace = innerSpace/2+fontName = "Monospace"+fontSize = 14.0+backgroundColor = (1, 1, 0.6, 1)+runningColor = (0, 204/255, 245/255, 1)+successColor = (121/255, 245/255, 0, 1)+failureColor = (255/255, 173/255, 173/255, 1)+monitorColor = (1, 0, 1, 1)++renderScreen :: [Monitor] -> Double -> Double -> Render ()+renderScreen monitors w h = do+    renderBackground+    renderMonitors monitors (shrink outerSpace $ Rect 0 0 w h)++renderBackground :: Render ()+renderBackground = do+    let (r, g, b, a) = backgroundColor+    setSourceRGBA r g b a+    paint++renderMonitors :: [Monitor] -> Rect -> Render ()+renderMonitors monitors rect = do+    let mr       = findRects rect monitors+    let mrShrunk = map (second $ shrink innerSpace) mr+    forM_ mrShrunk renderMonitor++renderMonitor :: (Monitor, Rect) -> Render ()+renderMonitor (monitor@StatusCodeMonitor {}, rect) =+    renderDocumentBox+        rect+        (statusToBgColor (mJobStatus monitor))+        (mJobName monitor)+        (additionalLines (mJobStatus monitor) (mOutput monitor))+renderMonitor (monitor@StdoutMonitor {}, rect) =+    renderDocumentBox+        rect+        monitorColor+        (mJobName monitor)+        (lines (mOutput monitor))++renderDocumentBox :: Rect -> Color -> String -> [String] -> Render ()+renderDocumentBox rect color heading body = do+    renderRoundedRectangle rect color+    renderDocument (shrink boxRadius rect) heading body++renderRoundedRectangle :: Rect -> Color -> Render ()+renderRoundedRectangle rect (r, g, b, a) = do+    setSourceRGBA r g b a+    roundRectPath rect+    fillPreserve+    setSourceRGBA 0 0 0 0.4+    setLineWidth 1.5+    stroke++roundRectPath :: Rect -> Render ()+roundRectPath (Rect x y w h) = do+    newPath+    arc (x+w-boxRadius) (y+  boxRadius) boxRadius ((-90) * pi/180) (0   * pi/180)+    arc (x+w-boxRadius) (y+h-boxRadius) boxRadius (0     * pi/180) (90  * pi/180)+    arc (x+  boxRadius) (y+h-boxRadius) boxRadius (90    * pi/180) (180 * pi/180)+    arc (x+  boxRadius) (y+  boxRadius) boxRadius (180   * pi/180) (270 * pi/180)+    closePath++renderDocument :: Rect -> String -> [String] -> Render ()+renderDocument rect@(Rect x y w h) heading body =+    withClipRegion rect $ do+        -- Title+        selectFontFace fontName FontSlantNormal FontWeightBold+        setFontSize fontSize+        setSourceRGBA 0 0 0 0.8+        ex <- textExtents heading+        moveTo (x - textExtentsXbearing ex) (y - textExtentsYbearing ex)+        showText heading+        -- Additional text+        let th = textExtentsHeight ex+        let textRect@(Rect x2 y2 w2 h2) = Rect (x+boxRadius) (y+2*th) (w-boxRadius) (h-2*th)+        renderMultilineText textRect body++renderMultilineText :: Rect -> [String] -> Render ()+renderMultilineText rect@(Rect x y w h) text = withClipRegion rect $ do+    selectFontFace fontName FontSlantNormal FontWeightNormal+    setFontSize    fontSize+    setSourceRGBA  0 0 0 0.8+    fontHeight <- fmap fontExtentsHeight fontExtents+    let totalHeight = fromIntegral (length text) * fontHeight+    let startY = if totalHeight <= h+                     then y+                     else y - (totalHeight - h)+    let fontOutsideClipCompensation = 2+    let ys = map (\i -> fromIntegral i*fontHeight + startY - fontOutsideClipCompensation) [1..length text]+    forM_ (zip text ys) $ \(line, y) -> do+        moveTo x y+        showText $ replace "\t" "    " line+    return ()++withClipRegion :: Rect -> Render () -> Render ()+withClipRegion (Rect x y w h) r = do+    save+    rectangle x y w h+    clip+    r+    restore++statusToBgColor :: Status -> Color+statusToBgColor Idle    = successColor+statusToBgColor Working = runningColor+statusToBgColor Fail    = failureColor++circularMovement :: Double -> Double -> Double -> Double -> Double+circularMovement start end animationTime totalTime = res+    where+        rest    = totalTime - animationTime * fromIntegral (floor $ totalTime / animationTime)+        percent = rest / animationTime+        d1      = end - start+        d2      = start - end+        p2      = percent * 2+        res     = if p2 <= 1+                      then start + d1 * percent+                      else end   + d2 * percent++additionalLines :: Status -> String -> [String]+additionalLines Fail s = lines s+additionalLines _    _ = []
+ src/Render/Layout.hs view
@@ -0,0 +1,48 @@+module Render.Layout where++import GHC.Exts+import Job.Types+import Monitor+import Render.Rect++data AttentionLevel = High | Medium | Low deriving (Eq, Ord)++findRects :: Rect -> [Monitor] -> [(Monitor, Rect)]+findRects originalRect monitors = zip orderedMonitors rectangles+    where+        orderedMonitors = orderMonitors monitors+        rectangles+            | orderedMonitors == []+                = []+            | hasHighest+                = let (topArea, bottomArea) = divideVertical originalRect 0.9+                      tops    = splitVertical topArea 1+                      bottoms = splitHorizontal bottomArea (numMonitors - 1)+                  in tops ++ bottoms+            | hasMedium+                = let (topArea, bottomArea) = divideVertical originalRect 0.9+                      tops    = splitVertical topArea numMedium+                      bottoms = splitHorizontal bottomArea (numMonitors - numMedium)+                  in tops ++ bottoms+            | otherwise+                = let (_, bottomArea) = divideVertical originalRect 0.7+                      bottoms = splitHorizontal bottomArea numMonitors+                  in bottoms+        numMonitors = length orderedMonitors+        hasHighest  = countAttentionLevels High   orderedMonitors > 0+        numMedium   = countAttentionLevels Medium orderedMonitors+        hasMedium   = numMedium > 0++orderMonitors :: [Monitor] -> [Monitor]+orderMonitors = sortWith attentionLevel++attentionLevel :: Monitor -> AttentionLevel+attentionLevel (StatusCodeMonitor _ _ _ Fail _) = High+attentionLevel (StdoutMonitor _ _ _ _)          = Medium+attentionLevel _                                = Low++countAttentionLevels :: AttentionLevel -> [Monitor] -> Int+countAttentionLevels level = length . filterAttentionLevel level++filterAttentionLevel :: AttentionLevel -> [Monitor] -> [Monitor]+filterAttentionLevel level = filter ((==level) . attentionLevel)
+ src/Render/Rect.hs view
@@ -0,0 +1,22 @@+module Render.Rect where++data Rect = Rect Double Double Double Double deriving (Eq, Show)++shrink :: Double -> Rect -> Rect+shrink by (Rect x y w h) = Rect (x+by) (y+by) (w-2*by) (h-2*by)++divideVertical :: Rect -> Double -> (Rect, Rect)+divideVertical (Rect x y w h) percent = (Rect x y w splitH, Rect x splitH w (h - splitH))+    where splitH = percent * h++splitVertical :: Rect -> Int -> [Rect]+splitVertical (Rect x y w h) n = map calcNew [1..n]+    where+        calcNew n = Rect x (y+(fromIntegral n-1)*newH) w newH+        newH = h / fromIntegral n++splitHorizontal :: Rect -> Int -> [Rect]+splitHorizontal (Rect x y w h) n = map calcNew [1..n]+    where+        calcNew n = Rect (x+(fromIntegral n -1)*newW) y newW h+        newW = w / fromIntegral n
tests/AllTests.hs view
@@ -1,10 +1,14 @@ import Fixtures-import Rect+import Job.Types+import Monitor+import Render.Layout+import Render.Rect import System.Directory import System.FilePath import Test.Hspec.HUnit() import Test.Hspec.Monadic import Test.Hspec.QuickCheck+import Test.HUnit import Test.QuickCheck  main = hspecX $ do@@ -41,3 +45,26 @@         prop "splitHorizontal preserves total area" $ forAll arbitrary        $ \rect ->                                                       forAll (choose (1, 10)) $ \numTimes ->             area rect `aboutSame` areas (splitHorizontal rect numTimes)++    describe "ordering monitors:" $ do++        describe "does not change when:" $++            it "no monitors require large space failing" $ do+                let monitors = [ StatusCodeMonitor "" 0 "" Idle ""+                               , StatusCodeMonitor "" 0 "" Working ""+                               ]+                orderMonitors monitors @?= monitors++        describe "does change when:" $++            it "a monitor require large space" $ do+                let monitors = [ StatusCodeMonitor "" 0 "" Idle ""+                               , StatusCodeMonitor "" 0 "" Working ""+                               , StdoutMonitor "" 0 "" ""+                               ]+                let expected = [ StdoutMonitor "" 0 "" ""+                               , StatusCodeMonitor "" 0 "" Idle ""+                               , StatusCodeMonitor "" 0 "" Working ""+                               ]+                orderMonitors monitors @?= expected
tests/Fixtures.hs view
@@ -5,7 +5,7 @@ import Control.Exception.Base (bracket) import Data.IORef import Notifier-import Rect+import Render.Rect import System.Directory import System.IO import Test.HUnit