use of existential types for plugin support

This patch, which *changes the configuration format*, adds easy plugin support
by using an existential type for storing the list of commands to be
executed. Adding a plugin is just a matter of writing the appropriate
instance of the Exec class, after importing Commands.hs.
I must thank Claus Reinke for the help in understanding the mysteries of
reading existential types. The Read instance of Runnable must be credited to
him. See here:
http://www.haskell.org/pipermail/haskell-cafe/2007-July/028227.html

darcs-hash:20070712175034-d6583-f10174bb3b0a9b4f6e08d05052c18f30e539b319.gz

7 files changed, 139 insertions, 67 deletions

diff --git a/Commands.hs b/Commands.hs
index 7c0985e..459892b 100644
--- a/Commands.hs
+++ b/Commands.hs
@@ -1,3 +1,4 @@
+{-# OPTIONS -fglasgow-exts #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  XMobar.Commands
@@ -26,48 +27,59 @@ import Monitors.Swap
 import Monitors.Cpu
 import Monitors.Batt
 
-data Command = Exec Program Args Alias 
-             | Weather Station Args 
-             | Network Interface Args
-             | Memory Args
-             | Swap Args
-             | Cpu Args
-             | Battery Args
-               deriving (Read,Eq)
+data Command = Com Program Args Alias Rate
+             | Weather Station Args Rate
+             | Network Interface Args Rate
+             | Memory Args Rate
+             | Swap Args Rate
+             | Cpu Args Rate
+             | Battery Args Rate
+               deriving (Show,Read,Eq)
 
 type Args = [String]
 type Program = String
 type Alias = String
 type Station = String
 type Interface = String
+type Rate = Int
 
-instance Show Command where
-    show (Weather s _) = s
-    show (Network i _) = i
-    show (Memory _) = "memory"
-    show (Swap _) = "swap"
-    show (Cpu _) = "cpu"
-    show (Battery _) = "battery"
-    show (Exec p _ a) | p /= "" = if  a == "" then p else a
-                      | otherwise = ""
 class Exec e where
     run :: e -> IO String
+    rate :: e -> Int
+    alias :: e -> String
 
 instance Exec Command where
-    run (Weather s a) = runM (a ++ [s]) weatherConfig runWeather 
-    run (Network i a) = runM (a ++ [i]) netConfig runNet
-    run (Memory args) = runM args memConfig runMem
-    run (Swap args) = runM args swapConfig runSwap
-    run (Cpu args) = runM args cpuConfig runCpu
-    run (Battery args) = runM args battConfig runBatt
-    run (Exec prog args _) = do (i,o,e,p) <- runInteractiveCommand (prog ++ concat (map (' ':) args))
-                                exit <- waitForProcess p
-                                let closeHandles = do hClose o
-                                                      hClose i
-                                                      hClose e
-                                case exit of
-                                  ExitSuccess -> do str <- hGetLine o
-                                                    closeHandles
-                                                    return str
-                                  _ -> do closeHandles
-                                          return $ "Could not execute command " ++ prog
+    alias (Weather s _ _) = s
+    alias (Network i _ _) = i
+    alias (Memory _ _) = "memory"
+    alias (Swap _ _) = "swap"
+    alias (Cpu _ _) = "cpu"
+    alias (Battery _ _) = "battery"
+    alias (Com p _ a _) | p /= "" = if  a == "" then p else a
+                      | otherwise = ""
+    rate (Weather _ _ r) = r
+    rate (Network _ _ r) = r
+    rate (Memory _ r) = r
+    rate (Swap _ r) = r
+    rate (Cpu _ r) = r
+    rate (Battery _ r) = r
+    rate (Com _ _ _ r) = r
+    run (Weather s a _) = runM (a ++ [s]) weatherConfig runWeather 
+    run (Network i a _) = runM (a ++ [i]) netConfig runNet
+    run (Memory args _) = runM args memConfig runMem
+    run (Swap args _) = runM args swapConfig runSwap
+    run (Cpu args _) = runM args cpuConfig runCpu
+    run (Battery args _) = runM args battConfig runBatt
+    run (Com prog args _ _) = do (i,o,e,p) <- runInteractiveCommand (prog ++ concat (map (' ':) args))
+                                 exit <- waitForProcess p
+                                 let closeHandles = do hClose o
+                                                       hClose i
+                                                       hClose e
+                                 case exit of
+                                   ExitSuccess -> do str <- hGetLine o
+                                                     closeHandles
+                                                     return str
+                                   _ -> do closeHandles
+                                           return $ "Could not execute command " ++ prog
+
+
diff --git a/Config.hs b/Config.hs
index 1ab01c9..b2aae29 100644
--- a/Config.hs
+++ b/Config.hs
@@ -16,9 +16,12 @@ module Config ( -- * Configuration
                 -- $config
                 Config (..)
               , defaultConfig
+              , runnableTypes
               ) where
 
 import Commands
+import {-# SOURCE #-} Runnable
+
 -- $config
 -- Configuration data type and default configuration
 
@@ -33,7 +36,7 @@ data Config =
            , height         :: Int      -- ^ Window height
            , align          :: String   -- ^ text alignment
            , refresh        :: Int      -- ^ Refresh rate in tenth of seconds
-           , commands       :: [(Command,Int)] -- ^ For setting the command, the command argujments 
+           , commands       :: [Runnable] -- ^ For setting the command, the command argujments 
                                                -- and refresh rate for the programs to run (optional)
            , sepChar        :: String -- ^ The character to be used for indicating
                                       -- commands in the output template (default '%')
@@ -52,7 +55,10 @@ defaultConfig =
            , height = 15
            , align = "left"
            , refresh = 10
-           , commands = [(Memory [],10)]
+           , commands = [Run $ Memory [] 10]
            , sepChar = "%"
            , template = "Uptime: <fc=#00FF00>%uptime%</fc> ** <fc=#FF0000>%date%</fc> %memory%"
            }
+
+runnableTypes :: (Command,())
+runnableTypes = undefined :: (Command,())
diff --git a/Parsers.hs b/Parsers.hs
index fa85193..8c25004 100644
--- a/Parsers.hs
+++ b/Parsers.hs
@@ -27,6 +27,7 @@ module Parsers (
 
 import Config
 import Commands
+import Runnable
 import Text.ParserCombinators.Parsec
 import qualified Data.Map as Map
 
@@ -103,20 +104,20 @@ templateParser :: Config -> Parser [(String,String,String)]
 templateParser c = many (templateStringParser c)
 
 -- | Actually runs the template parsers
-parseTemplate :: Config -> String -> IO [(Command,String,String)]
+parseTemplate :: Config -> String -> IO [(Runnable,String,String)]
 parseTemplate config s = 
     do str <- case (parse (templateParser config) "" s) of
                 Left _ -> return [("","","")]
                 Right x  -> return x
-       let comList = map (show . fst) $ commands config
-           m = Map.fromList . zip comList . map fst $ (commands config)
-       return $ combine m str
+       let comList = map alias (commands config)
+           m = Map.fromList $ zip comList (commands config)
+       return $ combine config m str
 
 -- | Given a finite "Map" and a parsed templatet produces the
 -- | resulting output string.
-combine :: Map.Map String Command -> [(String, String, String)] -> [(Command,String,String)]
-combine _ [] = []
-combine m ((ts,s,ss):xs) = 
-    [(com, s, ss)] ++ combine m xs
+combine :: Config -> Map.Map String Runnable -> [(String, String, String)] -> [(Runnable,String,String)]
+combine _ _ [] = []
+combine config m ((ts,s,ss):xs) = 
+    [(com, s, ss)] ++ combine config m xs
         where com = Map.findWithDefault dflt ts m
-              dflt = Exec ts [] [] --"<" ++ ts ++ " not found!>"
+              dflt = Run $ Com ts [] [] (refresh config) --"<" ++ ts ++ " not found!>"
diff --git a/Runnable.hs b/Runnable.hs
new file mode 100644
index 0000000..90e01af
--- /dev/null
+++ b/Runnable.hs
@@ -0,0 +1,50 @@
+{-# OPTIONS -fglasgow-exts #-}
+module Runnable where
+
+import Control.Monad
+import Text.Read
+import Text.ParserCombinators.ReadPrec
+import Config (runnableTypes)
+import Commands
+
+data Runnable = forall r . (Exec r,Show r, Read r) => Run r
+
+instance Show Runnable where
+    show (Run a) = "Run " ++ show a
+
+instance Exec Runnable where
+     run (Run a) = run a
+     rate (Run a) = rate a
+     alias (Run a) = alias a
+
+instance Read Runnable where
+    readPrec = readRunnable
+
+-- read an existential as any of hidden types ts
+class ReadAsAnyOf ts ex where
+    readAsAnyOf :: ts -> ReadPrec ex
+
+instance ReadAsAnyOf () ex where 
+    readAsAnyOf ~() = mzero
+
+instance (Read t, Show t, Exec t, ReadAsAnyOf ts Runnable) => ReadAsAnyOf (t,ts) Runnable where 
+    readAsAnyOf ~(t,ts) = r t `mplus` readAsAnyOf ts
+              where r ty = do { m <- readPrec; return (Run (m `asTypeOf` ty)) }
+
+
+
+readRunnable :: ReadPrec Runnable
+readRunnable = prec 10 $ do
+                 Ident "Run" <- lexP
+                 parens $ readAsAnyOf runnableTypes
+
+
+-- | Reads the configuration files or quits with an error
+readConfig :: FilePath -> IO Runnable
+readConfig f = 
+    do s <- readFile f
+       case reads s of
+         [(config,_)] -> return config
+         [] -> error ("Corrupt config file: " ++ f)
+         _ -> error ("Some problem occured. Aborting...")
+
diff --git a/Runnable.hs-boot b/Runnable.hs-boot
new file mode 100644
index 0000000..90dbe81
--- /dev/null
+++ b/Runnable.hs-boot
@@ -0,0 +1,11 @@
+{-# OPTIONS -fglasgow-exts #-}
+module Runnable where
+import Commands
+
+data Runnable = forall r . (Exec r,Show r, Read r) => Run r
+
+instance Read Runnable
+instance Exec Runnable
+instance Show Runnable
+
+
diff --git a/XMobar.hs b/XMobar.hs
index 6e9b142..593c7cb 100644
--- a/XMobar.hs
+++ b/XMobar.hs
@@ -47,6 +47,7 @@ import Control.Concurrent
 import Config
 import Parsers
 import Commands
+import Runnable
 
 -- $main
 --
@@ -163,31 +164,22 @@ printStrings p gc fontst offs sl@((s,c,l):xs) =
 
 -- $commands
 
--- | Gets the refresh rate set in configuration for a given command.
-getRefRate :: Config -> Command -> Int
-getRefRate c com =
-    let l = commands c
-        p = filter (\(s,_) -> s == com) l
-    in case p of
-         [(_,int)] -> int
-         _ -> refresh c
-
 -- | Runs a list of programs as independent threads and returns their thread id
 -- and the MVar they will be writing to.
-execCommands :: Config -> [(Command,String,String)] -> IO [(ThreadId, MVar String)]
+execCommands :: Config -> [(Runnable,String,String)] -> IO [(ThreadId, MVar String)]
 execCommands _ [] = return []
 execCommands c (x:xs) =
     do i <- execCommand c x
        is <- execCommands c xs
        return $ i : is
 
-execCommand :: Config -> (Command,String,String) -> IO (ThreadId, MVar String)
+execCommand :: Config -> (Runnable,String,String) -> IO (ThreadId, MVar String)
 execCommand c com = 
     do var <- newMVar "Updating..."
        h <- forkIO $ runCommandLoop var c com
        return (h,var)
 
-runCommandLoop :: MVar String -> Config -> (Command,String,String) -> IO ()
+runCommandLoop :: MVar String -> Config -> (Runnable,String,String) -> IO ()
 runCommandLoop var conf c@(com,s,ss)
     | show com == "" = 
         do modifyMVar_ var (\_ -> return $ "Could not parse the template")
@@ -196,7 +188,7 @@ runCommandLoop var conf c@(com,s,ss)
     | otherwise =
         do str <- run com
            modifyMVar_ var (\_ -> return $ s ++ str ++ ss)
-           tenthSeconds (getRefRate conf com)
+           tenthSeconds (rate com) 
            runCommandLoop var conf c
 
 -- | Reads MVars set by 'runCommandLoop'
diff --git a/xmobar.config-sample b/xmobar.config-sample
index e2d54a6..3092cbc 100644
--- a/xmobar.config-sample
+++ b/xmobar.config-sample
@@ -7,15 +7,15 @@ Config { font = "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*"
        , height = 15
        , align = "right"
        , refresh = 10
-       , commands = [ (Weather "EGPF" ["-t","<station>: <tempC>C","-L","18","-H","25","--normal","green","--high","red","--low","lightblue"], 36000)
-                    , (Network "eth0" ["-L","0","-H","32","--normal","green","--high","red"], 10)
-                    , (Network "eth1" ["-L","0","-H","32","--normal","green","--high","red"], 10)
-                    , (Cpu ["-L","3","-H","50","--normal","green","--high","red"], 10)
-                    , (Exec "date" ["+\"%a %b %_d %H:%M\""] "mydate", 600)
-                    , (Exec "date" ["+%Y"] "year", 304128000)
-                    , (Memory ["-t","Mem: <usedratio>%"], 10)
-                    , (Swap [], 10)
-                    , (Exec "uname" ["-s","-r"] "", 36000)
+       , commands = [ Run Weather "EGPF" ["-t","<station>: <tempC>C","-L","18","-H","25","--normal","green","--high","red","--low","lightblue"] 36000
+                    , Run Network "eth0" ["-L","0","-H","32","--normal","green","--high","red"] 10
+                    , Run Network "eth1" ["-L","0","-H","32","--normal","green","--high","red"] 10
+                    , Run Cpu ["-L","3","-H","50","--normal","green","--high","red"] 10
+                    , Run Com "date" ["+\"%a %b %_d %H:%M\""] "mydate" 600
+                    , Run Com "date" ["+%Y"] "year" 304128000
+                    , Run Memory ["-t","Mem: <usedratio>%"] 10
+                    , Run Swap [] 10
+                    , Run Com "uname" ["-s","-r"] "" 36000
                     ]
        , sepChar = "%"
        , template = "%cpu% | %memory% * %swap% | %eth0% - %eth1% | %EGPF% | <fc=#ee9a00>%mydate% of %year%</fc> %uname%"