better ordering of alerts

Assistant/Alert.hs

@@ -17,8 +17,8 @@ import Yesod
 type Widget = forall sub master. GWidget sub master ()
 
 {- Different classes of alerts are displayed differently. -}
-data AlertClass = Activity | Warning | Error | Success | Message
-	deriving (Eq)
+data AlertClass = Success | Message | Activity | Warning | Error
+	deriving (Eq, Ord)
 
 {- An alert can be a simple message, or an arbitrary Yesod Widget -}
 data AlertMessage = StringAlert String | WidgetAlert Widget
@@ -28,19 +28,53 @@ data Alert = Alert
 	, alertHeader :: Maybe String
 	, alertMessage :: AlertMessage
 	, alertBlockDisplay :: Bool
+	, alertPriority :: AlertPriority
 	}
 
+{- Higher AlertId indicates a more recent alert. -}
+type AlertId = Integer
+
+type AlertPair = (AlertId, Alert)
+
+data AlertPriority = Low | Medium | High
+	deriving (Eq, Ord)
+
+{- The desired order is the reverse of:
+ -
+ - - High priority alerts, newest first
+ - - Medium priority Activity, newest first (mostly used for Activity)
+ - - Low priority alwerts, newest first
+ - - Ties are broken by the AlertClass, with Errors etc coming first.
+ -}
+compareAlertPairs :: AlertPair -> AlertPair -> Ordering
+compareAlertPairs
+	(aid, Alert {alertClass = aclass, alertPriority = aprio})
+	(bid, Alert {alertClass = bclass, alertPriority = bprio})
+	 = compare aprio bprio
+		`thenOrd` compare aid bid
+			`thenOrd` compare aclass bclass
+
+sortAlertPairs :: [AlertPair] -> [AlertPair]
+sortAlertPairs = reverse . sortBy compareAlertPairs
+
 activityAlert :: Maybe String -> String -> Alert
 activityAlert header message = Alert
 	{ alertClass = Activity
 	, alertHeader = header
 	, alertMessage = StringAlert message
 	, alertBlockDisplay = False
+	, alertPriority = Medium
 	}
 
 startupScanAlert :: Alert
 startupScanAlert = activityAlert Nothing "Performing startup scan"
 
+runningAlert :: Alert
+runningAlert = (activityAlert Nothing "Running")
+	{ alertClass = Success
+	, alertPriority = High -- pin above the other activity alerts
+	}
+
 pushAlert :: [Remote] -> Alert
 pushAlert rs = activityAlert Nothing $
 	"Syncing with " ++ unwords (map Remote.name rs)
@@ -59,6 +93,7 @@ syncMountAlert dir rs = Alert
 		, " -- let's get it in sync!"
 		]
 	, alertBlockDisplay = True
+	, alertPriority = Low
         }
 
 scanAlert :: Remote -> Alert
@@ -69,6 +104,7 @@ scanAlert r = Alert
 		[ "Ensuring that ", Remote.name r
 		, "is fully in sync." ]
 	, alertBlockDisplay = True
+	, alertPriority = Low
 	}
 
 sanityCheckAlert :: Alert
@@ -85,4 +121,5 @@ sanityCheckFixAlert msg = Alert
 		, "If these problems persist, consider filing a bug report."
 		]
 	, alertBlockDisplay = True
+	, alertPriority = High
 	}

Assistant/DaemonStatus.hs

@@ -51,7 +51,6 @@ data DaemonStatus = DaemonStatus
 type TransferMap = M.Map Transfer TransferInfo
 
 type AlertMap = M.Map AlertId Alert
-type AlertId = Integer
 
 {- This TMVar is never left empty, so accessing it will never block. -}
 type DaemonStatusHandle = TMVar DaemonStatus

Assistant/Threads/Watcher.hs

@@ -75,13 +75,18 @@ watchThread st dstatus transferqueue changechan = do
 startupScan :: ThreadState -> DaemonStatusHandle -> IO a -> IO a
 startupScan st dstatus scanner = do
 	runThreadState st $ showAction "scanning"
-	r <- alertWhile dstatus startupScanAlert scanner
-	modifyDaemonStatus_ dstatus $ \s -> s { scanComplete = True }
+	r <- alertWhile dstatus startupScanAlert $ do
+		r <- scanner
+		modifyDaemonStatus_ dstatus $ \s -> s { scanComplete = True }
 
-	-- Notice any files that were deleted before watching was started.
-	runThreadState st $ do
-		inRepo $ Git.Command.run "add" [Param "--update"]
-		showAction "started"
+		-- Notice any files that were deleted before
+		-- watching was started.
+		runThreadState st $ do
+			inRepo $ Git.Command.run "add" [Param "--update"]
+			showAction "started"
+		return r
+	
+	void $ addAlert dstatus runningAlert
 
 	return r
 

Assistant/Threads/WebApp.hs

@@ -34,7 +34,6 @@ import Network.Socket (PortNumber)
 import Text.Blaze.Renderer.String
 import Data.Text (Text, pack, unpack)
 import qualified Data.Map as M
-import Data.Function
 
 thisThread :: String
 thisThread = "WebApp"
@@ -158,10 +157,9 @@ sideBarDisplay noScript = do
 	
 		{- Add newest 10 alerts to the sidebar. -}
 		webapp <- lift getYesod
-		alerts <- M.toList . alertMap
+		alertpairs <- M.toList . alertMap
 			<$> liftIO (getDaemonStatus $ daemonStatus webapp)
-		mapM_ renderalert $
-			take 10 $ reverse $ sortBy (compare `on` fst) alerts
+		mapM_ renderalert $ take 10 $ sortAlertPairs alertpairs
 	ident <- lift newIdent
 	$(widgetFile "sidebar")
 
@@ -180,7 +178,7 @@ sideBarDisplay noScript = do
 		renderalert (alertid, alert) = addalert
 			(show alertid)
 			-- Activity alerts auto-close
-			(not noScript && alertClass alert /= Activity)
+			(alertClass alert /= Activity)
 			(alertBlockDisplay alert)
 			(bootstrapclass $ alertClass alert)
 			(alertHeader alert)

Utility/Misc.hs

@@ -45,3 +45,10 @@ segment p l = map reverse $ go [] [] l
 		go c r (i:is)
 			| p i = go [] (c:r) is
 			| otherwise = go (i:c) r is
+
+{- Given two orderings, returns the second if the first is EQ and returns
+ - the first otherwise. -}
+thenOrd :: Ordering -> Ordering -> Ordering
+thenOrd EQ x = x
+thenOrd x _ = x
+{-# INLINE thenOrd #-}

templates/transfers.hamlet

@@ -1,6 +1,5 @@
 <div .span9 ##{ident}>
   $if null transfers
-    <h2>No current transfers
   $else
     <h2>Transfers
     $forall (transfer, info) <- transfers