WIP use intelligent logging messages

bin/xmobar.hs

@@ -178,6 +178,7 @@ rightPlugins DBusState { dbSesClient = ses, dbSysClient = sys }
 
 type BarFeature = Sometimes CmdSpec
 
+-- TODO what if I don't have a wireless card?
 getWireless :: BarFeature
 getWireless = sometimes1 "wireless status indicator" "sysfs path"
   $ IORoot wirelessCmd
@@ -194,7 +195,7 @@ getBattery :: BarFeature
 getBattery = iconIO_ "battery level indicator" root tree
   where
     root useIcon = IORoot_ (batteryCmd useIcon)
-    tree = Only_ $ IOTest_ "Test if battery is present" hasBattery
+    tree = Only_ $ IOTest_ "Test if battery is present" $ fmap (Msg Error) <$> hasBattery
 
 getVPN :: Maybe Client -> BarFeature
 getVPN cl = iconDBus_ "VPN status indicator" root $ toAnd_ vpnDep test
@@ -413,20 +414,22 @@ readInterface n f = IORead n go
     go = io $ do
       ns <- filter f <$> listInterfaces
       case ns of
-        [] -> return $ Left ["no interfaces found"]
+        [] -> return $ Left [Msg Error "no interfaces found"]
         (x:xs) -> do
-          return $ Right $ PostPass x $ fmap ("ignoring extra interface: "++) xs
+          return $ Right $ PostPass x
+            $ fmap (Msg Warn . ("ignoring extra interface: " ++)) xs
 
-vpnPresent :: IO (Maybe String)
+vpnPresent :: IO (Maybe Msg)
 vpnPresent =
   go <$> tryIOError (readCreateProcessWithExitCode' (proc' "nmcli" args) "")
   where
     args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"]
     go (Right (ExitSuccess, out, _))   = if "vpn" `elem` lines out then Nothing
-                                         else Just "vpn not found"
+                                         else Just $ Msg Error "vpn not found"
-    go (Right (ExitFailure c, _, err)) = Just $ "vpn search exited with code "
+    go (Right (ExitFailure c, _, err)) = Just $ Msg Error
+                                         $ "vpn search exited with code "
                                          ++ show c ++ ": " ++ err
-    go (Left e)                        = Just $ show e
+    go (Left e)                        = Just $ Msg Error $ show e
 
 --------------------------------------------------------------------------------
 -- | text font

lib/XMonad/Internal/Command/DMenu.hs

@@ -74,6 +74,7 @@ myDmenuMatchingArgs = ["-i"] -- case insensitivity
 --------------------------------------------------------------------------------
 -- | Exported Commands
 
+-- TODO test that veracrypt and friends are installed
 runDevMenu :: SometimesX
 runDevMenu = sometimesIO_ "device manager" "rofi devices" t x
   where
@@ -85,11 +86,12 @@ runDevMenu = sometimesIO_ "device manager" "rofi devices" t x
         ++ "--" : themeArgs "#999933"
         ++ myDmenuMatchingArgs
 
+-- TODO test that bluetooth interface exists
 runBTMenu :: SometimesX
 runBTMenu = sometimesExeArgs "bluetooth selector" "rofi bluetooth" False
   myDmenuBluetooth $ "-c":themeArgs "#0044bb"
 
-
+-- TODO test that expressVPN is actually running (/var/lib/expressvpn/expressvpnd.socket)
 runVPNMenu :: SometimesX
 runVPNMenu = sometimesIO_ "VPN selector" "rofi VPN"
   (Only_ $ localExe myDmenuVPN) $ spawnCmd myDmenuVPN
@@ -104,7 +106,7 @@ runAppMenu = spawnDmenuCmd "app launcher" ["-show", "drun"]
 runWinMenu :: SometimesX
 runWinMenu = spawnDmenuCmd "window switcher" ["-show", "window"]
 
--- TODO test that networkManager is actually running
+-- TODO test that networkManager is actually running (systemd service)
 runNetMenu :: SometimesX
 runNetMenu = sometimesExeArgs "network control menu" "rofi NetworkManager"
   True myDmenuNetworks $ themeArgs "#ff3333"
@@ -125,11 +127,11 @@ runBwMenu = sometimesIO_ "password manager" "rofi bitwarden"
 --------------------------------------------------------------------------------
 -- | Clipboard
 
+-- TODO test that greenclip daemon is actually running (get process id?)
 runClipMenu :: SometimesX
 runClipMenu = sometimesIO_ "clipboard manager" "rofi greenclip" tree act
   where
     act = spawnCmd myDmenuCmd args
-    -- TODO test that greenclip daemon is actually running
     tree = toAnd_ (sysExe myDmenuCmd) $ sysExe myClipboardManager
     args = [ "-modi", "\"clipboard:greenclip print\""
            , "-show", "clipboard"

lib/XMonad/Internal/Command/Desktop.hs

@@ -90,6 +90,7 @@ myNotificationCtrl = "dunstctl"
 volumeChangeSound :: FilePath
 volumeChangeSound = "smb_fireball.wav"
 
+-- TODO make this dynamic (like in xmobar)
 ethernetIface :: String
 ethernetIface = "enp7s0f1"
 
@@ -99,6 +100,7 @@ ethernetIface = "enp7s0f1"
 runTerm :: SometimesX
 runTerm = sometimesExe "terminal" "urxvt" True myTerm
 
+-- TODO test that tmux is actually running (/tmp/tmux-<UID>/default)
 runTMux :: SometimesX
 runTMux = sometimesIO_ "terminal multiplexer" "tmux" deps act
   where
@@ -119,6 +121,7 @@ runCalc = sometimesIO_ "calculator" "R" deps act
 runBrowser :: SometimesX
 runBrowser = sometimesExe "web browser" "brave" False myBrowser
 
+-- TODO test that emacs is actually running (/run/user/1000/emacs/server)
 runEditor :: SometimesX
 runEditor = sometimesExeArgs "text editor" "emacs" True myEditor
   ["-c", "-e", doubleQuote "(select-frame-set-input-focus (selected-frame))"]
@@ -175,7 +178,7 @@ runVolumeMute = featureSound "mute" volumeChangeSound (void toggleMute) $ return
 --------------------------------------------------------------------------------
 -- | Notification control
 
--- TODO test that dunst is actually running
+-- TODO test that dunst is actually running (org.freedesktop.Notifications/org.dunstproject.cmd0)
 runNotificationCmd :: String -> FilePath -> SometimesX
 runNotificationCmd n arg = sometimesIO_ (n ++ " control") "dunstctl" tree cmd
   where
@@ -201,12 +204,14 @@ runNotificationContext =
 -- | System commands
 
 -- this is required for some vpn's to work properly with network-manager
+-- TODO test that network manager is up
 runNetAppDaemon :: Sometimes (IO ProcessHandle)
 runNetAppDaemon = sometimesIO_ "network applet" "NM-applet" tree cmd
   where
     tree = Only_ $ localExe "nm-applet"
     cmd = snd <$> spawnPipe "nm-applet"
 
+-- TODO test that bluetooth dbus interface is up
 runToggleBluetooth :: SometimesX
 runToggleBluetooth =
   sometimesIO_ "bluetooth toggle" "bluetoothctl" (Only_ $ sysExe myBluetooth)
@@ -280,7 +285,7 @@ getCaptureDir = do
   where
     fallback = (</> ".local/share") <$> getHomeDirectory
 
--- TODO test that flameshot is actually running
+-- TODO test that flameshot is actually running (Bus org.flameshot.Flameshot)
 runFlameshot :: String -> String -> SometimesX
 runFlameshot n mode = sometimesIO_ n myCapture
   (Only_ $ sysExe myCapture) $ spawnCmd myCapture [mode]

lib/XMonad/Internal/Command/Power.hs

@@ -135,6 +135,7 @@ runOptimusPrompt' fb = do
       #!&& unwords [myOptimusManager, "--switch", mode, "--no-confirm"]
       #!&& "killall xmonad"
 
+-- TODO test that the socket is open (/tmp/optimus-manager)
 runOptimusPrompt :: SometimesX
 runOptimusPrompt = Sometimes "graphics switcher" [s]
   where

lib/XMonad/Internal/Concurrent/VirtualBox.hs

@@ -12,17 +12,18 @@ import           Text.XML.Light
 
 import           System.Directory
 
+import           XMonad.Internal.Dependency
 import           XMonad.Internal.Shell
 
-vmExists :: String -> IO (Maybe String)
+vmExists :: String -> IO (Maybe Msg)
 vmExists vm = do
   d <- vmDirectory
-  either (return . Just) findVMDir d
+  either (return . Just . Msg Error) findVMDir d
   where
     findVMDir vd = do
       vs <- listDirectory vd
       return $ if vm `elem` vs then Nothing
-        else Just $ "could not find " ++ singleQuote vm
+        else Just $ Msg Error $ "could not find " ++ singleQuote vm
 
 vmDirectory :: IO (Either String String)
 vmDirectory = do

lib/XMonad/Internal/Dependency.hs

@@ -25,6 +25,7 @@ module XMonad.Internal.Dependency
   , Subfeature(..)
   , SubfeatureRoot
   , LogLevel(..)
+  , Msg(..)
 
   -- dependency tree types
   , Root(..)
@@ -153,17 +154,22 @@ evalFeature (Left s)  = evalSometimes s
 evalSometimes :: Sometimes a -> FIO (Maybe a)
 evalSometimes x = either goFail goPass =<< evalSometimesMsg x
   where
-    goPass (PostPass a ws) = putErrors ws >> return (Just a)
+    goPass (a, ws) = putErrors ws >> return (Just a)
     goFail es = putErrors es >> return Nothing
-    putErrors = io . mapM_ putStrLn
+    putErrors = io . mapM_ printMsg
 
 -- | Return the action of an Always
 evalAlways :: Always a -> FIO a
 evalAlways a = do
-  (PostPass x ws) <- evalAlwaysMsg a
+  (x, ws) <- evalAlwaysMsg a
-  io $ mapM_ putStrLn ws
+  io $ mapM_ printMsg ws
   return x
 
+printMsg :: FMsg -> IO ()
+printMsg (FMsg fn n (Msg ll m)) = do
+  p <- getProgName
+  putStrLn $ unwords [bracket p, bracket $ show ll, bracket fn, bracket n, m]
+
 --------------------------------------------------------------------------------
 -- | Feature status
 
@@ -306,7 +312,7 @@ instance Hashable DBusDependency_ where
 
 -- | A dependency that only requires IO to evaluate (no payload)
 data IODependency_ = IOSystem_ SystemDependency
-  | IOTest_ String (IO (Maybe String))
+  | IOTest_ String (IO (Maybe Msg))
   | forall a. IOSometimes_ (Sometimes a)
 
 instance Eq IODependency_ where
@@ -352,6 +358,12 @@ instance Hashable DBusMember where
 -- The main reason I need this is so I have a "result" I can convert to JSON
 -- and dump on the CLI (unless there is a way to make Aeson work inside an IO)
 
+-- | A message with criteria for when to show it
+data Msg = Msg LogLevel String
+
+-- | A message annotated with subfeature and feature name
+data FMsg = FMsg String String Msg
+
 -- | Tested Always feature
 data PostAlways a = Primary (SubfeaturePass a) [SubfeatureFail] (Always_ a)
   | Fallback a [SubfeatureFail]
@@ -369,13 +381,13 @@ type SubfeaturePass a = Subfeature (PostPass a)
 type SubfeatureFail = Subfeature PostFail
 
 -- | An action that passed
-data PostPass a = PostPass a [String] deriving (Functor)
+data PostPass a = PostPass a [Msg] deriving (Functor)
 
-addMsgs :: PostPass a -> [String] -> PostPass a
+addMsgs :: PostPass a -> [Msg] -> PostPass a
 addMsgs (PostPass a ms) ms' = PostPass a $ ms ++ ms'
 
 -- | An action that failed
-data PostFail = PostFail [String] | PostMissing String
+data PostFail = PostFail [Msg] | PostMissing Msg
 
 --------------------------------------------------------------------------------
 -- | Evaluation cache
@@ -438,19 +450,33 @@ memoizeFont f d = do
 --------------------------------------------------------------------------------
 -- | Testing pipeline
 
-evalSometimesMsg :: Sometimes a -> FIO (Result a)
+evalSometimesMsg :: Sometimes a -> FIO (Either [FMsg] (a, [FMsg]))
 evalSometimesMsg (Sometimes n xs) = do
   PostSometimes { psSuccess = s, psFailed = fs } <- testSometimes xs
-  case s of
+  let fs' = failedMsgs n fs
-    (Just (Subfeature { sfData = p })) -> Right . addMsgs p <$> failedMsgsIO False n fs
+  return $ case s of
-    _                                  -> Left <$> failedMsgsIO True n fs
+    (Just p) -> Right $ second (++ fs') $ passActMsg n p
+    _        -> Left fs'
 
-evalAlwaysMsg :: Always a -> FIO (PostPass a)
+evalAlwaysMsg :: Always a -> FIO (a, [FMsg])
 evalAlwaysMsg (Always n x) = do
   r <- testAlways x
-  case r of
+  return $ case r of
-    (Primary (Subfeature { sfData = p }) fs _) -> addMsgs p <$> failedMsgsIO False n fs
+    (Primary p fs _)  -> second (++ failedMsgs n fs) $ passActMsg n p
-    (Fallback act fs) -> PostPass act <$> failedMsgsIO False n fs
+    (Fallback act fs) -> (act, failedMsgs n fs)
+
+passActMsg :: String -> SubfeaturePass a -> (a, [FMsg])
+passActMsg fn Subfeature { sfData = PostPass a ws, sfName = n } = (a, fmap (FMsg fn n) ws)
+
+failedMsgs :: String -> [SubfeatureFail] -> [FMsg]
+failedMsgs n = concatMap (failedMsg n)
+
+failedMsg :: String -> SubfeatureFail -> [FMsg]
+failedMsg fn Subfeature { sfData = d, sfName = n } = case d of
+  (PostFail es)   -> f es
+  (PostMissing e) -> f [e]
+  where
+    f = fmap (FMsg fn n)
 
 testAlways :: Always_ a -> FIO (PostAlways a)
 testAlways = go []
@@ -496,7 +522,8 @@ testRoot r = do
     (IORoot_ a t)             -> go_ a testIODependency_ t
     (DBusRoot a t (Just cl))  -> go (`a` cl) (testDBusDependency_ cl) testIODependency t
     (DBusRoot_ a t (Just cl)) -> go_ (a cl) (testDBusDependency_ cl) t
-    _                         -> return $ Left $ PostMissing "client not available"
+    _                         -> return $ Left $ PostMissing
+                                 $ Msg Error "client not available"
   where
     -- rank N polymorphism is apparently undecidable...gross
     go a f_ (f :: forall q. d q -> FIO (Result q)) t =
@@ -506,13 +533,13 @@ testRoot r = do
 --------------------------------------------------------------------------------
 -- | Payloaded dependency testing
 
-type Result p = Either [String] (PostPass p)
+type Result p = Either [Msg] (PostPass p)
 
 testTree :: forall d d_ p. (d_ -> FIO Result_) -> (forall q. d q -> FIO (Result q))
-  -> Tree d d_ p -> FIO (Either [String] (PostPass p))
+  -> Tree d d_ p -> FIO (Either [Msg] (PostPass p))
 testTree test_ test = go
   where
-    go :: forall q. Tree d d_ q -> FIO (Either [String] (PostPass q))
+    go :: forall q. Tree d d_ q -> FIO (Either [Msg] (PostPass q))
     go (And12 f a b) = do
       ra <- go a
       liftRight (\pa -> (and2nd f pa =<<) <$> go b) ra
@@ -536,15 +563,22 @@ testIODependency (IOConst c)       = return $ Right $ PostPass c []
 -- succeed, which kinda makes this pointless. The only reason I would want this
 -- is if I want to have a built-in logic to "choose" a payload to use in
 -- building a higher-level feature
-testIODependency (IOAlways a f)    = Right . fmap f <$> evalAlwaysMsg a
+testIODependency (IOAlways a f)    = Right . uncurry PostPass
-testIODependency (IOSometimes x f) = second (fmap f) <$> evalSometimesMsg x
+  -- TODO this is wetter than Taco Bell shit
+  . bimap f (fmap stripMsg) <$> evalAlwaysMsg a
+testIODependency (IOSometimes x f) =
+  bimap (fmap stripMsg) (uncurry PostPass . bimap f (fmap stripMsg))
+  <$> evalSometimesMsg x
+
+stripMsg :: FMsg -> Msg
+stripMsg (FMsg _ _ m) = m
 
 --------------------------------------------------------------------------------
 -- | Standalone dependency testing
 
-type Result_ = Either [String] [String]
+type Result_ = Either [Msg] [Msg]
 
-testTree_ :: (d -> FIO Result_) -> Tree_ d -> FIO (Either [String] [String])
+testTree_ :: (d -> FIO Result_) -> Tree_ d -> FIO Result_
 testTree_ test = go
   where
     go (And_ a b) = either (return . Left) (`test2nd` b) =<< go a
@@ -558,16 +592,17 @@ testIODependency_ = memoizeIO_ testIODependency'_
 testIODependency'_ :: IODependency_ -> FIO Result_
 testIODependency'_ (IOSystem_ s) = io $ readResult_ <$> testSysDependency s
 testIODependency'_ (IOTest_ _ t) = io $ readResult_ <$> t
-testIODependency'_ (IOSometimes_ x) = second (\(PostPass _ ws) -> ws) <$> evalSometimesMsg x
+testIODependency'_ (IOSometimes_ x) = bimap (fmap stripMsg) (fmap stripMsg . snd)
+  <$> evalSometimesMsg x
 
 --------------------------------------------------------------------------------
 -- | System Dependency Testing
 
-testSysDependency :: SystemDependency -> IO (Maybe String)
+testSysDependency :: SystemDependency -> IO (Maybe Msg)
 testSysDependency (Executable sys bin) = maybe (Just msg) (const Nothing)
   <$> findExecutable bin
   where
-    msg = unwords [e, "executable", singleQuote bin, "not found"]
+    msg = Msg Error $ unwords [e, "executable", singleQuote bin, "not found"]
     e = if sys then "system" else "local"
 testSysDependency (Systemd t n) = shellTest cmd msg
   where
@@ -577,21 +612,22 @@ testSysDependency (AccessiblePath p r w) = permMsg <$> getPermissionsSafe p
   where
     testPerm False _ _  = Nothing
     testPerm True f res = Just $ f res
-    permMsg NotFoundError            = Just "file not found"
+    mkErr = Just . Msg Error
-    permMsg PermError                = Just "could not get permissions"
+    permMsg NotFoundError            = mkErr "file not found"
+    permMsg PermError                = mkErr "could not get permissions"
     permMsg (PermResult res) =
       case (testPerm r readable res, testPerm w writable res) of
-        (Just False, Just False) -> Just "file not readable or writable"
+        (Just False, Just False) -> mkErr "file not readable or writable"
-        (Just False, _)          -> Just "file not readable"
+        (Just False, _)          -> mkErr "file not readable"
-        (_, Just False)          -> Just "file not writable"
+        (_, Just False)          -> mkErr "file not writable"
         _                        -> Nothing
 
-shellTest :: String -> String -> IO (Maybe String)
+shellTest :: String -> String -> IO (Maybe Msg)
 shellTest cmd msg = do
   (rc, _, _) <- readCreateProcessWithExitCode' (shell cmd) ""
   return $ case rc of
     ExitSuccess -> Nothing
-    _           -> Just msg
+    _           -> Just $ Msg Error msg
 
 unitType :: UnitType -> String
 unitType SystemUnit = "system"
@@ -638,15 +674,12 @@ testFont :: String -> FIO (Result FontBuilder)
 testFont = memoizeFont testFont'
 
 testFont' :: String -> IO (Result FontBuilder)
-testFont' fam = do
+testFont' fam = maybe pass (Left . (:[])) <$> shellTest cmd msg
-  (rc, _, _) <- readCreateProcessWithExitCode' (shell cmd) ""
-  return $ case rc of
-    ExitSuccess -> Right $ PostPass (buildFont $ Just fam) []
-    _           -> Left [msg]
   where
     msg = unwords ["font family", qFam, "not found"]
     cmd = fmtCmd "fc-list" ["-q", qFam]
     qFam = singleQuote fam
+    pass = Right $ PostPass (buildFont $ Just fam) []
 
 --------------------------------------------------------------------------------
 -- | DBus Dependency Testing
@@ -664,10 +697,12 @@ testDBusDependency'_ :: Client -> DBusDependency_ -> FIO Result_
 testDBusDependency'_ client (Bus bus) = io $ do
   ret <- callMethod client queryBus queryPath queryIface queryMem
   return $ case ret of
-        Left e    -> Left [e]
+        Left e    -> Left [Msg Error e]
         Right b -> let ns = bodyGetNames b in
           if bus' `elem` ns then Right []
-          else Left [unwords ["name", singleQuote bus', "not found on dbus"]]
+          else Left [
+            Msg Error $ unwords ["name", singleQuote bus', "not found on dbus"]
+            ]
   where
     bus' = formatBusName bus
     queryBus = busName_ "org.freedesktop.DBus"
@@ -680,14 +715,14 @@ testDBusDependency'_ client (Bus bus) = io $ do
 testDBusDependency'_ client (Endpoint busname objpath iface mem) = io $ do
   ret <- callMethod client busname objpath introspectInterface introspectMethod
   return $ case ret of
-        Left e     -> Left [e]
+        Left e     -> Left [Msg Error e]
         Right body -> procBody body
   where
     procBody body = let res = findMem =<< I.parseXML objpath =<< fromVariant
                           =<< listToMaybe body in
       case res of
         Just True -> Right []
-        _         -> Left [fmtMsg' mem]
+        _         -> Left [Msg Error $ fmtMsg' mem]
     findMem = fmap (matchMem mem)
       . find (\i -> I.interfaceName i == iface)
       . I.objectInterfaces
@@ -794,12 +829,12 @@ voidResult :: Result p -> Result_
 voidResult (Left es)               = Left es
 voidResult (Right (PostPass _ ws)) = Right ws
 
-voidRead :: Result p -> Maybe String
+voidRead :: Result p -> Maybe Msg
-voidRead (Left [])    = Just "unspecified error"
+voidRead (Left [])    = Just $ Msg Error "unspecified error"
 voidRead (Left (e:_)) = Just e
 voidRead (Right _)    = Nothing
 
-readResult_ :: Maybe String -> Result_
+readResult_ :: Maybe Msg -> Result_
 readResult_ (Just w) = Left [w]
 readResult_ _        = Right []
 
@@ -976,11 +1011,16 @@ dataDBusDependency d =
     memberData (Signal_ n)   = ("signal", formatMemberName n)
     memberData (Property_ n) = ("property", n)
 
-fromResult :: Result a -> (Bool, [JSONQuotable])
+fromMsg :: Msg -> JSONUnquotable
-fromResult = second (fmap Q) . either (False,) (\(PostPass _ ws) -> (True, ws))
+fromMsg (Msg e s) = jsonObject [ ("level", JSON_Q $ Q $ show e)
+                               , ("msg", JSON_Q $ Q s)
+                               ]
 
-fromResult_ :: Result_ -> (Bool, [JSONQuotable])
+fromResult :: Result a -> (Bool, [JSONUnquotable])
-fromResult_ = second (fmap Q) . either (False,) (True,)
+fromResult = second (fmap fromMsg) . either (False,) (\(PostPass _ ws) -> (True, ws))
+
+fromResult_ :: Result_ -> (Bool, [JSONUnquotable])
+fromResult_ = second (fmap fromMsg) . either (False,) (True,)
 
 --------------------------------------------------------------------------------
 -- | JSON formatting
@@ -1032,7 +1072,7 @@ jsonRoot isIO tree = jsonObject
 jsonLeafUntested :: JSONQuotable -> [(String, JSONMixed)] -> JSONUnquotable
 jsonLeafUntested = jsonLeaf Nothing
 
-jsonLeaf :: Maybe (Bool, [JSONQuotable]) -> JSONQuotable -> [(String, JSONMixed)]
+jsonLeaf :: Maybe (Bool, [JSONUnquotable]) -> JSONQuotable -> [(String, JSONMixed)]
   -> JSONUnquotable
 jsonLeaf status deptype depdata = jsonObject
   [ ("type", JSON_Q deptype)
@@ -1040,10 +1080,10 @@ jsonLeaf status deptype depdata = jsonObject
   , ("data", JSON_UQ $ jsonObject depdata)
   ]
 
-jsonStatus :: Bool -> [JSONQuotable] -> JSONUnquotable
+jsonStatus :: Bool -> [JSONUnquotable] -> JSONUnquotable
 jsonStatus present messages = jsonObject
   [ ("present", JSON_UQ $ jsonBool present)
-  , ("messages", JSON_UQ $ jsonArray $ fmap JSON_Q messages)
+  , ("messages", JSON_UQ $ jsonArray $ fmap JSON_UQ messages)
   ]
 
 jsonAnd :: JSONUnquotable -> JSONUnquotable -> JSONUnquotable
@@ -1086,19 +1126,19 @@ curly s = "{" ++ s ++ "}"
 --------------------------------------------------------------------------------
 -- | Other random formatting
 
-failedMsgsIO :: Bool -> String -> [SubfeatureFail] -> FIO [String]
+-- failedMsgsIO :: Bool -> String -> [SubfeatureFail] -> FIO [Msg]
-failedMsgsIO err fn = io . failedMsgs err fn
+-- failedMsgsIO err fn = io . failedMsgs err fn
 
-failedMsgs :: Bool -> String -> [SubfeatureFail] -> IO [String]
+-- failedMsgs :: Bool -> String -> [SubfeatureFail] -> IO [Msg]
-failedMsgs err fn = fmap concat . mapM (failedMsg err fn)
+-- failedMsgs err fn = fmap concat . mapM (failedMsg err fn)
 
-failedMsg :: Bool -> String -> SubfeatureFail -> IO [String]
+-- failedMsg :: Bool -> String -> SubfeatureFail -> IO [Msg]
-failedMsg err fn Subfeature { sfData = d, sfName = n } = do
+-- failedMsg err fn Subfeature { sfData = d, sfName = n } = do
-  mapM (fmtMsg err fn n) $ case d of (PostMissing e) -> [e]; (PostFail es) -> es
+--   mapM (fmtMsg err fn n) $ case d of (PostMissing e) -> [e]; (PostFail es) -> es
 
-fmtMsg :: Bool -> String -> String -> String -> IO String
+-- fmtMsg :: Bool -> String -> String -> Msg -> IO Msg
-fmtMsg err fn n msg = do
+-- fmtMsg err fn n msg = do
-  let e = if err then "ERROR" else "WARNING"
+--   let e = if err then "ERROR" else "WARNING"
-  p <- getProgName
+--   p <- getProgName
-  return $ unwords [bracket p, bracket e, bracket fn, bracket n, msg]
+--   return $ unwords [bracket p, bracket e, bracket fn, bracket n, msg]