Self-compilation a la xmonad

8 files changed, 153 insertions, 100 deletions

diff --git a/src/Xmobar.hs b/src/Xmobar.hs
index f6a8463..4f912a2 100644
--- a/src/Xmobar.hs
+++ b/src/Xmobar.hs
@@ -16,8 +16,8 @@
 -----------------------------------------------------------------------------
 
 module Xmobar (xmobar
+              , xmobarMain
               , defaultConfig
-              , xmobarConfigFile
               , Runnable (..)
               , Exec (..)
               , module Xmobar.Config.Types
@@ -63,5 +63,5 @@ import Xmobar.Plugins.PipeReader
 import Xmobar.Plugins.StdinReader
 import Xmobar.Plugins.XMonadLog
 
-import Xmobar.App.Main(xmobar)
-import Xmobar.App.Config(defaultConfig, xmobarConfigFile)
+import Xmobar.App.Main(xmobar, xmobarMain)
+import Xmobar.App.Config(defaultConfig)
diff --git a/src/Xmobar/App/Compile.hs b/src/Xmobar/App/Compile.hs
index c3f52f9..3332c45 100644
--- a/src/Xmobar/App/Compile.hs
+++ b/src/Xmobar/App/Compile.hs
@@ -15,7 +15,7 @@
 ------------------------------------------------------------------------------
 
 
-module Xmobar.App.Compile(recompile) where
+module Xmobar.App.Compile(recompile, xmessage) where
 
 import Control.Monad.IO.Class
 import Control.Monad.Fix (fix)
@@ -33,25 +33,23 @@ import System.Posix.Process(executeFile, forkProcess, getAnyProcessStatus)
 import System.Posix.Types(ProcessID)
 import System.Posix.Signals
 
-import Xmobar.App.Config
-
 isExecutable :: FilePath -> IO Bool
 isExecutable f =
   E.catch (executable <$> getPermissions f) (\(SomeException _) -> return False)
 
-checkBuildScript :: FilePath -> IO Bool
-checkBuildScript buildscript = do
+checkBuildScript :: Bool -> FilePath -> IO Bool
+checkBuildScript verb buildscript = do
   exists <- doesFileExist buildscript
   if exists
     then do
       isExe <- isExecutable buildscript
       if isExe
         then do
-          trace $ "Xmobar will use build script at "
-                  ++ show buildscript ++ " to recompile."
+          trace verb $ "Xmobar will use build script at "
+                       ++ show buildscript ++ " to recompile."
           return True
         else do
-          trace $ unlines
+          trace verb $ unlines
             [ "Xmobar will not use build script, because "
               ++ show buildscript ++ " is not executable."
             , "Suggested resolution to use it: chmod u+x "
@@ -59,23 +57,23 @@ checkBuildScript buildscript = do
             ]
           return False
     else do
-      trace $ "Xmobar will use ghc to recompile, because "
-              ++ show buildscript ++ " does not exist."
+      trace verb $ "Xmobar will use ghc to recompile, because "
+                   ++ show buildscript ++ " does not exist."
       return False
 
-shouldRecompile :: FilePath -> FilePath -> FilePath -> IO Bool
-shouldRecompile src bin lib = do
+shouldRecompile :: Bool -> FilePath -> FilePath -> FilePath -> IO Bool
+shouldRecompile verb src bin lib = do
   libTs <- mapM getModTime . filter isSource =<< allFiles lib
   srcT <- getModTime src
   binT <- getModTime bin
   if any (binT <) (srcT : libTs)
     then do
-      trace "Xmobar doing recompile because some files have changed."
+      trace verb "Xmobar doing recompile because some files have changed."
       return True
     else do
-      trace "Xmobar skipping recompile because it is not forced \
-            \ (e.g. via --recompile), and not any *.hs / *.lhs / *.hsc \
-            \ files in lib/ have been changed."
+      trace verb "Xmobar skipping recompile because it is not forced \
+                 \ (e.g. via --recompile), and not any *.hs / *.lhs / *.hsc \
+                 \ files in lib/ have been changed."
       return False
   where isSource = flip elem [".hs",".lhs",".hsc"] . takeExtension
         allFiles t = do
@@ -109,8 +107,8 @@ ghcErrorMsg src status ghcErr = return . unlines $
 
 -- | A 'trace' for the 'X' monad. Logs a string to stderr. The result may
 -- be found in your .xsession-errors file
-trace :: MonadIO m => String -> m ()
-trace = liftIO . hPutStrLn stderr
+trace :: MonadIO m => Bool -> String -> m ()
+trace verb msg = when verb (liftIO $ hPutStrLn stderr msg)
 
 -- | 'recompile force', recompile the xmobar configuration file when
 -- any of the following apply:
@@ -126,24 +124,22 @@ trace = liftIO . hPutStrLn stderr
 -- and any files in the aforementioned @lib@ directory.
 --
 -- Compilation errors (if any) are logged to the @xmobar.errors@ file
--- in the xmobar data directory.  If GHC indicates failure with a
+-- in the given directory.  If GHC indicates failure with a
 -- non-zero exit code, an xmessage displaying that file is spawned.
 --
 -- 'False' is returned if there are compilation errors.
 --
-recompile :: MonadIO m => String -> Bool -> m Bool
-recompile execName force = liftIO $ do
-    cfgdir  <- xmobarConfigDir
-    datadir <- xmobarDataDir
-    let bin  = datadir </> execName
-        err  = datadir </> (execName ++ ".errors")
-        src  = cfgdir </> (execName ++ ".hs")
-        lib  = cfgdir </> "lib"
-        script = cfgdir </> "build"
-    useScript <- checkBuildScript script
+recompile :: MonadIO m => String -> String -> Bool -> Bool -> m Bool
+recompile dir execName force verb = liftIO $ do
+    let bin  = dir </> execName
+        err  = dir </> (execName ++ ".errors")
+        src  = dir </> (execName ++ ".hs")
+        lib  = dir </> "lib"
+        script = dir </> "build"
+    useScript <- checkBuildScript verb script
     sc <- if useScript || force
           then return True
-          else shouldRecompile src bin lib
+          else shouldRecompile verb src bin lib
     if sc
       then do
         uninstallSignalHandlers
@@ -151,16 +147,15 @@ recompile execName force = liftIO $ do
                     \errHandle ->
                       waitForProcess =<<
                         if useScript
-                        then runScript script bin cfgdir errHandle
-                        else runGHC bin cfgdir errHandle
+                        then runScript script bin dir errHandle
+                        else runGHC bin dir errHandle
         installSignalHandlers
         if status == ExitSuccess
-            then trace "Xmobar recompilation process exited with success!"
+            then trace verb "Xmobar recompilation process exited with success!"
             else do
                 msg <- readFile err >>= ghcErrorMsg src status
                 hPutStrLn stderr msg
-                xmessage msg
-                return ()
+                exitWith (ExitFailure 1)
         return (status == ExitSuccess)
       else return True
  where opts bin = ["--make" , execName ++ ".hs" , "-i" , "-ilib"
diff --git a/src/Xmobar/App/Config.hs b/src/Xmobar/App/Config.hs
index 7b1171f..431ee10 100644
--- a/src/Xmobar/App/Config.hs
+++ b/src/Xmobar/App/Config.hs
@@ -61,6 +61,7 @@ defaultConfig =
            , alignSep = "}{"
            , template = "%StdinReader% }{ " ++
                         "<fc=#00FF00>%uname%</fc> * <fc=#FF0000>%theDate%</fc>"
+           , verbose = False
            }
 
 -- | Return the path to the xmobar configuration directory.  This
@@ -136,8 +137,11 @@ findFirstDirWithEnv envName paths = do
       Nothing -> findFirstDirOf paths
       Just envPath -> findFirstDirOf (return envPath:paths)
 
-xmobarConfigFile :: IO FilePath
-xmobarConfigFile = do
-  f <- fmap (</> "xmobarrc") xmobarConfigDir
-  fe <- fileExist f
-  if fe then return f else fmap (</> ".xmobarrc") getHomeDirectory
+xmobarConfigFile :: IO (Maybe FilePath)
+xmobarConfigFile =
+  ffirst [ xdg "xmobar.hs", xdg "xmobarrc", home ".xmobarrc"]
+  where xdg p = fmap (</> p) xmobarConfigDir
+        home p = fmap (</> p) getHomeDirectory
+        ffirst [] = return Nothing
+        ffirst (f:fs) =
+          f >>= fileExist >>= \e -> if e then fmap Just f else ffirst fs
diff --git a/src/Xmobar/App/EventLoop.hs b/src/Xmobar/App/EventLoop.hs
index 0d96578..7a76ee6 100644
--- a/src/Xmobar/App/EventLoop.hs
+++ b/src/Xmobar/App/EventLoop.hs
@@ -99,7 +99,8 @@ startLoop xcfg@(XConf _ _ w _ _ _ _) sig vs = do
             ConfigureEvent {} -> atomically $ putTMVar signal Reposition
             ExposeEvent {} -> atomically $ putTMVar signal Wakeup
             RRScreenChangeNotifyEvent {} -> atomically $ putTMVar signal Reposition
-            ButtonEvent {} -> atomically $ putTMVar signal (Action (ev_button ev) (fi $ ev_x ev))
+            ButtonEvent {} -> atomically $
+                   putTMVar signal (Action (ev_button ev) (fi $ ev_x ev))
             _ -> return ()
 
 -- | Send signal to eventLoop every time a var is updated
diff --git a/src/Xmobar/App/Main.hs b/src/Xmobar/App/Main.hs
index efc2753..b5de2ef 100644
--- a/src/Xmobar/App/Main.hs
+++ b/src/Xmobar/App/Main.hs
@@ -15,18 +15,24 @@
 ------------------------------------------------------------------------------
 
 
-module Xmobar.App.Main (xmobar, doOpts) where
+module Xmobar.App.Main (xmobar, xmobarMain) where
+
+import Control.Concurrent.Async (Async, cancel)
+import Control.Exception (bracket)
+import Control.Monad (unless)
 
 import Data.Foldable (for_)
 import qualified Data.Map as Map
-import System.Exit
-import Text.Read (readMaybe)
+import Data.List (intercalate)
+import System.Posix.Process (executeFile)
+import System.Environment (getArgs)
+import System.FilePath
+import System.FilePath.Posix (takeBaseName, takeDirectory)
 
 import Graphics.X11.Xlib
-import Control.Concurrent.Async (Async, cancel)
-import Control.Exception (bracket)
 
 import Xmobar.Config.Types
+import Xmobar.Config.Parse
 import Xmobar.System.Signal (setupSignalHandler, withDeferSignals)
 import Xmobar.Run.Template
 import Xmobar.X11.Types
@@ -34,6 +40,8 @@ import Xmobar.X11.Text
 import Xmobar.X11.Window
 import Xmobar.App.Opts
 import Xmobar.App.EventLoop (startLoop, startCommand)
+import Xmobar.App.Compile (recompile)
+import Xmobar.App.Config
 
 xmobar :: Config -> IO ()
 xmobar conf = withDeferSignals $ do
@@ -58,45 +66,32 @@ cleanupThreads vars =
   for_ (concat vars) $ \(asyncs, _) ->
     for_ asyncs cancel
 
-doOpts :: Config -> [Opts] -> IO Config
-doOpts conf [] =
-  return (conf {lowerOnStart = lowerOnStart conf && overrideRedirect conf})
-doOpts conf (o:oo) =
-  case o of
-    Help -> putStr   usage >> exitSuccess
-    Version -> putStrLn info  >> exitSuccess
-    Debug -> doOpts' conf
-    Font s -> doOpts' (conf {font = s})
-    WmClass s -> doOpts' (conf {wmClass = s})
-    WmName s -> doOpts' (conf {wmName = s})
-    BgColor s -> doOpts' (conf {bgColor = s})
-    FgColor s -> doOpts' (conf {fgColor = s})
-    Alpha n -> doOpts' (conf {alpha = read n})
-    T -> doOpts' (conf {position = Top})
-    B -> doOpts' (conf {position = Bottom})
-    D -> doOpts' (conf {overrideRedirect = False})
-    AlignSep s -> doOpts' (conf {alignSep = s})
-    SepChar s -> doOpts' (conf {sepChar = s})
-    Template s -> doOpts' (conf {template = s})
-    IconRoot s -> doOpts' (conf {iconRoot = s})
-    OnScr n -> doOpts' (conf {position = OnScreen (read n) $ position conf})
-    Commands s -> case readCom 'c' s of
-                    Right x -> doOpts' (conf {commands = x})
-                    Left e -> putStr (e ++ usage) >> exitWith (ExitFailure 1)
-    AddCommand s -> case readCom 'C' s of
-                      Right x -> doOpts' (conf {commands = commands conf ++ x})
-                      Left e -> putStr (e ++ usage) >> exitWith (ExitFailure 1)
-    Position s -> readPosition s
-  where readCom c str =
-          case readStr str of
-            [x] -> Right x
-            _  -> Left ("xmobar: cannot read list of commands " ++
-                        "specified with the -" ++ c:" option\n")
-        readStr str = [x | (x,t) <- reads str, ("","") <- lex t]
-        doOpts' c = doOpts c oo
-        readPosition string =
-            case readMaybe string of
-                Just x  -> doOpts' (conf { position = x })
-                Nothing -> do
-                    putStrLn "Can't parse position option, ignoring"
-                    doOpts' conf
+buildLaunch :: Bool -> Bool -> FilePath -> IO ()
+buildLaunch verb force p = do
+  let exec = takeBaseName p
+      dir = takeDirectory p
+  recompile dir exec force verb
+  executeFile (dir </> exec) False [] Nothing
+
+xmobar' :: Config -> [String] -> IO ()
+xmobar' cfg defs = do
+  unless (null defs || not (verbose cfg)) $ putStrLn $
+    "Fields missing from config defaulted: " ++ intercalate "," defs
+  xmobar cfg
+
+xmobarMain :: IO ()
+xmobarMain = do
+  args <- getArgs
+  (flags, rest) <- getOpts args
+  cf <- case rest of
+          (c:_) -> return (Just c)
+          _ -> xmobarConfigFile
+  case cf of
+    Nothing -> case rest of
+                (c:_) -> error $ c ++ ": file not found"
+                _ -> xmobar defaultConfig
+    Just p -> do d <- doOpts defaultConfig flags
+                 r <- readConfig d p
+                 case r of
+                   Left _ -> buildLaunch (verbose d) (forceRecompile flags) p
+                   Right (c, defs) -> xmobar' c defs
diff --git a/src/Xmobar/App/Opts.hs b/src/Xmobar/App/Opts.hs
index 842744b..34e2c9e 100644
--- a/src/Xmobar/App/Opts.hs
+++ b/src/Xmobar/App/Opts.hs
@@ -14,16 +14,21 @@
 --
 ------------------------------------------------------------------------------
 
-
 module Xmobar.App.Opts where
 
+import Control.Monad (when)
 import System.Console.GetOpt
+import System.Exit (exitSuccess, exitWith, ExitCode(..))
 import Data.Version (showVersion)
+import Text.Read (readMaybe)
 
 import Paths_xmobar (version)
 
+import Xmobar.Config.Types
+
 data Opts = Help
-          | Debug
+          | Verbose
+          | Recompile
           | Version
           | Font       String
           | BgColor    String
@@ -47,7 +52,8 @@ data Opts = Help
 options :: [OptDescr Opts]
 options =
     [ Option "h?" ["help"] (NoArg Help) "This help"
-    , Option "D" ["debug"] (NoArg Debug) "Emit verbose debugging messages"
+    , Option "v" ["verbose"] (NoArg Verbose) "Emit verbose debugging messages"
+    , Option "r" ["recompile"] (NoArg Recompile) "Force recompilation"
     , Option "V" ["version"] (NoArg Version) "Show version information"
     , Option "f" ["font"] (ReqArg Font "font name") "Font name"
     , Option "w" ["wmclass"] (ReqArg WmClass "class") "X11 WM_CLASS property"
@@ -83,10 +89,13 @@ options =
     ]
 
 getOpts :: [String] -> IO ([Opts], [String])
-getOpts argv =
-    case getOpt Permute options argv of
-      (o,n,[])   -> return (o,n)
-      (_,_,errs) -> error (concat errs ++ usage)
+getOpts argv = do
+   (o,n) <-  case getOpt Permute options argv of
+               (o,n,[])   -> return (o,n)
+               (_,_,errs) -> error (concat errs ++ usage)
+   when (Help `elem` o) (putStr usage >> exitSuccess)
+   when (Version `elem` o) (putStr info >> exitSuccess)
+   return (o, n)
 
 usage :: String
 usage = usageInfo header options ++ footer
@@ -107,3 +116,50 @@ license = "\nThis program is distributed in the hope that it will be useful," ++
           "\nbut WITHOUT ANY WARRANTY; without even the implied warranty of" ++
           "\nMERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." ++
           "\nSee the License for more details."
+
+doOpts :: Config -> [Opts] -> IO Config
+doOpts conf [] =
+  return (conf {lowerOnStart = lowerOnStart conf && overrideRedirect conf})
+doOpts conf (o:oo) =
+  case o of
+    Help -> doOpts' conf
+    Version -> doOpts' conf
+    Recompile -> doOpts' conf
+    Verbose -> doOpts' (conf {verbose = True})
+    Font s -> doOpts' (conf {font = s})
+    WmClass s -> doOpts' (conf {wmClass = s})
+    WmName s -> doOpts' (conf {wmName = s})
+    BgColor s -> doOpts' (conf {bgColor = s})
+    FgColor s -> doOpts' (conf {fgColor = s})
+    Alpha n -> doOpts' (conf {alpha = read n})
+    T -> doOpts' (conf {position = Top})
+    B -> doOpts' (conf {position = Bottom})
+    D -> doOpts' (conf {overrideRedirect = False})
+    AlignSep s -> doOpts' (conf {alignSep = s})
+    SepChar s -> doOpts' (conf {sepChar = s})
+    Template s -> doOpts' (conf {template = s})
+    IconRoot s -> doOpts' (conf {iconRoot = s})
+    OnScr n -> doOpts' (conf {position = OnScreen (read n) $ position conf})
+    Commands s -> case readCom 'c' s of
+                    Right x -> doOpts' (conf {commands = x})
+                    Left e -> putStr (e ++ usage) >> exitWith (ExitFailure 1)
+    AddCommand s -> case readCom 'C' s of
+                      Right x -> doOpts' (conf {commands = commands conf ++ x})
+                      Left e -> putStr (e ++ usage) >> exitWith (ExitFailure 1)
+    Position s -> readPosition s
+  where readCom c str =
+          case readStr str of
+            [x] -> Right x
+            _  -> Left ("xmobar: cannot read list of commands " ++
+                        "specified with the -" ++ c:" option\n")
+        readStr str = [x | (x,t) <- reads str, ("","") <- lex t]
+        doOpts' c = doOpts c oo
+        readPosition string =
+            case readMaybe string of
+                Just x  -> doOpts' (conf { position = x })
+                Nothing -> do
+                    putStrLn "Can't parse position option, ignoring"
+                    doOpts' conf
+
+forceRecompile :: [Opts] -> Bool
+forceRecompile = elem Recompile
diff --git a/src/Xmobar/Config/Parse.hs b/src/Xmobar/Config/Parse.hs
index 1a57ffa..00ce99c 100644
--- a/src/Xmobar/Config/Parse.hs
+++ b/src/Xmobar/Config/Parse.hs
@@ -67,7 +67,7 @@ parseConfig defaultConfig =
               <|?> pAllDesktops <|?> pOverrideRedirect <|?> pPickBroadest
               <|?> pLowerOnStart <|?> pPersistent <|?> pIconRoot
               <|?> pCommands <|?> pSepChar <|?> pAlignSep <|?> pTemplate
-
+              <|?> pVerbose
 
       fields    = [ "font", "additionalFonts","bgColor", "fgColor"
                   , "wmClass", "wmName", "sepChar"
@@ -75,7 +75,7 @@ parseConfig defaultConfig =
                   , "position" , "textOffset", "textOffsets", "iconOffset"
                   , "allDesktops", "overrideRedirect", "pickBroadest"
                   , "hideOnStart", "lowerOnStart", "persistent", "iconRoot"
-                  , "alpha", "commands"
+                  , "alpha", "commands", "verbose"
                   ]
 
       pFont = strField font "font"
@@ -103,6 +103,7 @@ parseConfig defaultConfig =
       pPickBroadest = readField pickBroadest "pickBroadest"
       pIconRoot = readField iconRoot "iconRoot"
       pAlpha = readField alpha "alpha"
+      pVerbose = readField verbose "verbose"
 
       pCommands = field commands "commands" readCommands
 
diff --git a/src/Xmobar/Config/Types.hs b/src/Xmobar/Config/Types.hs
index ab85d5b..d59c993 100644
--- a/src/Xmobar/Config/Types.hs
+++ b/src/Xmobar/Config/Types.hs
@@ -64,6 +64,7 @@ data Config =
            , alignSep :: String     -- ^ Separators for left, center and
                                     --   right text alignment
            , template :: String     -- ^ The output template
+           , verbose :: Bool        -- ^ Emit additional debug messages
            } deriving (Read)
 
 data XPosition = Top