[Haskell-beginners] Defining ExtensionClass (Maybe a) instance in xmonad.

[Dmitriy Matrosov]

Hi.

Sorry for big delay, rewriting my previous solution takes a lot of time.

On 2015年01月20日 23:14, Brandon Allbery wrote:
  > > then there is no (Show a, Read a) constraint. It will come
  > > up only, when i mention PersistentExtension in one of case
  > > branches, but, on the other hand, may be i can avoid
  > >
  >
  > That would be expected, I believe; if you mentioned it, it must apply to
  > the whole instance, not just one case branch. But I'm not quite clear on
  > what you are saying here.

I mean, that i already have contraint (ExtensionClass a) in e.g.

     instance (ExtensionClass a) => ExtensionClass (Maybe a) where
         initialValue = Nothing

then if type a had Show and Read instances, then (Maybe a) will had them too
and i may define 'extensionType = PersistentExtension' in (Maybe a) 
instance.
If type a had no Show and Read instances, then i may only define (Maybe 
a) to be
a StateExtension . Thus, theoretically, (ExtensionClass a) contraint is
enough, and i want to express above condition on (Maybe a) extensionType 
value
with only that contraint. I can't express it by pattern-matching on type a's
StateExtension data contructor, because that will bring up (Show a, Read a)
constraint on (Maybe a) instance. I.e. i, probably, can't do it with 
condition
at data level. Then, may be, i can make a condition at type level somehow?

  > In particular, remember that the child process "closest" to xmonad in a
  > spawnPipe is a shell, *not* the program you ran. And that shell has the
  > same problem, so killing it will not kill the xmobar it starts!)

Yes, i've noticed that, and that's why i modify spawnPipe from 
XMonad.Util.Run
to run specified process directly, not through the shell. But, perhaps, 
i also
may add 'exec ' before command executed by shell too.

On 2015年01月21日 01:17, Thomas Bach wrote:
  > I had kind of the same problem and went for the this option, i.e. 
defining
  > a data type. But I implemented this via a pid file which gets saved on
  > xmonad start up. This way these program can even survive a restart 
of the
  > XServer properly.

Thanks for answer, i've tried to integrate your solution with my 
(below). But
i don't understand, why may i need to know pid of processes after 
restarting X
server? They all will die anyway, won't they?

  > However, I don't see the point in defining the data type to contain
  > start/stop functions. These will be the same for most of the programs,

Not exactly. Let's consider three of them: xmobar, trayer and feh .  For
xmobar i need to create a pipe and save Handle in extensible state, so i can
access it later from dynamicLogWithPP . For trayer i just need to start a
program with arguments. And for feh i need to check existence of '~/.fehbg'
file and evaluate its content through shell. If file does not exist, i 
need to
use some fallback, like `xsetroot -grey`.  Though, feh finishes right after
setting background and is not very good exameple, still start/stop functions
may not be the same: they may open pipes, check existence of different 
files,
etc. - all that you usually do in shell scripts :) Your PidProg-s implement
only "trayer" case. xmobar in your Config.hs started using `xmobar` function
from XMonad.Hooks.DynamicLog , and, i guess, it restarts correctly with 
xmonad
only, because you have StdinReader in template in your xmobarrc (in other
words, your Config.hs has the same problem with xmobar, as i try to solve
here, you just don't see it).

However, it turns out, that your PidProg and my per-program newtype-s
has one more difference: you have names for ProcessID-s (e.g. command record
may be thought as such), but i have not.

So, let's start from the beginning.

I may just store all ProcessID-s in list - [ProcessID]. But then i
don't even know which ProcessID belongs to which process.

Then, i may add names for ProcessID-s, so i can distinguish them later -
e.g. [(String, ProcessID)]. This is essentially your solution: pid file (and
PidProg value) binds process name and pid together.  But now all ProcessID-s
have the same start/stop functions.

Finally, i may store start/stop functions in data type as well, but such 
type
can't have Show and Read instance, so it can't be stored in extensible state
persistently with 'extensionType = PersistentExtension'.

Then i may try to store in extensible state only ProcessID and name and
find start/stop function for them using type-class . Moreover, i even 
does not
need name - i can use Eq instance for this and compare any fields (not only
e.g. command names) there.

So, here is my rewritten implementation of that ideas:

 > {-# LANGUAGE  FlexibleContexts
 >               , DeriveDataTypeable
 >               , GeneralizedNewtypeDeriving #-}
 >
 > import Data.Monoid
 > import XMonad
 > import qualified XMonad.Util.ExtensibleState as XS
 > import System.Posix.Process
 > import System.IO
 > import System.Posix.IO
 > import System.Posix.Types
 > import System.Posix.Signals
 > import System.Directory
 > import System.FilePath
 > import Control.Exception
 > import Control.Monad
 >
 > spawnPipe' :: [String] -> X (Handle, ProcessID)
 > spawnPipe' (x : xs) = io $ do
 >         (rd, wr) <- createPipe
 >         setFdOption wr CloseOnExec True
 >         h <- fdToHandle wr
 >         hSetBuffering h LineBuffering
 >         p <- xfork $ do
 >               _ <- dupTo rd stdInput
 >               --executeFile "/bin/sh" False ["-c", encodeString x] 
Nothing
 >               executeFile x True xs Nothing
 >         closeFd rd
 >         return (h, p)
 >
 > spawnPID' :: MonadIO m => [String] -> m ProcessID
 > spawnPID' (x : xs) = xfork $ executeFile x True xs Nothing

I've defined XmobarPID3 newtype allowing to launching several xmobar's

 > data XmobarPID3       = XmobarPID3
 >                           { xmobarPID  :: First ProcessID
 >                           , xmobarConf :: FilePath
 >                           }
 >   deriving (Show, Read, Typeable)
 > instance Eq XmobarPID3 where
 >   XmobarPID3 {xmobarConf = xcf} == XmobarPID3 {xmobarConf = ycf}
 >     | xcf == ycf      = True
 >     | otherwise       = False
 > instance Monoid XmobarPID3 where
 >   mempty          = XmobarPID3
 >                       { xmobarPID = First Nothing
 >                       , xmobarConf = "" }
 >   x `mappend` y   = XmobarPID3
 >                       { xmobarPID = xmobarPID x `mappend` xmobarPID y
 >                       , xmobarConf = xmobarConf x }
 >
 > newtype XmobarHandle = XmobarHandle (Maybe Handle)
 >   deriving (Typeable)
 > instance ExtensionClass XmobarHandle where
 >     initialValue  = XmobarHandle Nothing

and TrayerPID3 and FehPID3 designed for one program instance only 
(because all
values of these types are equal):

 > newtype TrayerPID3    = TrayerPID3 {trayerPID  :: First ProcessID}
 >   deriving (Show, Read, Typeable, Monoid)
 > instance Eq TrayerPID3 where
 >   _ == _    = True
 >
 > newtype FehPID3           = FehPID3 {fehPID  :: First ProcessID}
 >   deriving (Show, Read, Typeable, Monoid)
 > instance Eq FehPID3 where
 >   _ == _    = True

Then i define typeclass for start/stop interface (why there is Monoid
constraint see runWith code below):

 > class (Eq a, Monoid a) => RestartClass3 a where
 >   getPidP3   :: a -> Maybe ProcessID
 >   setPidP3   :: Maybe ProcessID -> a -> a
 >   runP3      :: a -> X a
 >   -- restartP3' relies on PID 'Nothing' after killP3, because it then 
calls
 >   -- startP3' and it won't do anything, if PID will still exist. So, 
here i
 >   -- should either set it to Nothing, or wait until it really terminates.
 >   killP3     :: a -> X a
 >   killP3 x    = io $ do
 >       whenJust (getPidP3 x) $ signalProcess sigTERM
 >       return (setPidP3 Nothing x)
 >
 > defaultRunP3 :: RestartClass3 a => [String] -> a -> X a
 > defaultRunP3 xs z = do
 >       p <- spawnPID' xs
 >       return (setPidP3 (Just p) z)

then i define instances for XmobarPID3 and FehPID3 with custom runP3 
functions:

 > instance RestartClass3 XmobarPID3 where
 >   getPidP3        = getFirst . xmobarPID
 >   setPidP3 mp' x  = x{xmobarPID = First mp'}
 >   runP3 x         = do
 >       (h, p) <- spawnPipe' ["/usr/bin/xmobar", xmobarConf x]
 >       XS.put (XmobarHandle (Just h))
 >       return (x{xmobarPID = First (Just p)})
 >
 > instance RestartClass3 FehPID3 where
 >   getPidP3        = getFirst . fehPID
 >   setPidP3 mp' x  = x{fehPID = First mp'}
 >   runP3 x         = do
 >       h <- io $ getHomeDirectory
 >       let f = h </> ".fehbg"
 >       b <- io $ doesFileExist f
 >       p <- if b then do
 >        cmd <- io $ readFile f
 >        -- ~/.fehbg content written assuming evaluation by shell,
 >        -- but i still need real process's PID, so add 'exec' .
 >        spawnPID ("exec " ++ cmd)
 >       else spawnPID' ["xsetroot", "-grey"]
 >       return (x{fehPID = First (Just p)})

trayer will use default run/kill implementation:

 > instance RestartClass3 TrayerPID3 where
 >   getPidP3        = getFirst . trayerPID
 >   setPidP3 mp' x  = x{trayerPID = First mp'}
 >   runP3           = defaultRunP3
 >       [ "trayer"
 >       , "--edge", "top", "--align", "right"
 >       , "--SetDockType", "true", "--SetPartialStrut", "true"
 >       , "--expand", "true", "--width", "10"
 >       , "--transparent", "true" , "--tint", "0x191970"
 >       , "--height", "12"
 >       ]

The other deficiency of my previous implementation was that i may store only
one program's info for each newtype (e.g. i may run only one xmobar, because
i've used (Maybe XmobarPID) to store its pid). Now i'll switch to list 
instead
of Maybe in extensible state. Also, i want to make 'respawn' record of 
PidProg
implicit: if i call 'restart' i ever want to kill program and run again; 
if i
just want to be sure, that program is running, i should call the 'start'
instead.

 > instance (Show a, Read a, Typeable a) => ExtensionClass [a] where
 >   initialValue    = []
 >   extensionType   = PersistentExtension
 >
 > -- Similar to insertWith from Data.Map, but for lists.
 > insertWith :: Eq a => (a -> a -> a) -> a -> [a] -> [a]
 > insertWith f y []   = [y]
 > insertWith f y (x : xs)
 >   | y == x    = f y x : xs
 >   | otherwise = x : insertWith f y xs
 >
 > -- Run function on matched PIDs with specific type.
 > -- Argument's Eq instance is used to find value in extensible state
 > -- to act upon. Also, argument is `mappend`-ed to found value,
 > -- so i should pass mempty, if i want to just "match", and
 > -- something different, if i want to "match and replace".
 > runWith :: (Eq a, Monoid a, ExtensionClass [a]) => (a -> X a) -> a -> 
X ()
 > runWith f y       = do
 >   xs <- XS.gets (insertWith mappend y)
 >   xs'' <- mapM (\x -> if y == x then f x else return x) xs
 >   XS.put xs''
 >
 > -- Based on doesPidProgRun .
 > refreshPid :: (MonadIO m, RestartClass3 a) => a -> m a
 > refreshPid x = case (getPidP3 x) of
 >     Nothing -> return x
 >     Just p  -> liftIO $ do
 >       either (const (setPidP3 Nothing x)) (const x)
 >       `fmap` (try $ getProcessPriority p :: IO (Either IOException Int))
 >
 > -- Run, if program is not running or already dead, otherwise do nothing.
 > -- Note, that this function work on argument, not on extensible state.
 > startP3' :: RestartClass3 a => a -> X a
 > startP3' x   = do
 >   x' <- refreshPid x
 >   case (getPidP3 x') of
 >     Nothing   -> runP3 x'
 >     Just _    -> return x'
 >
 > -- Kill program and run again. Note, that it will run again only,
 > -- if killP3 kills it properly: either sets pid to Nothing
 > -- or waits until it dies.
 > -- Note, that this function work on argument, not on extensible state.
 > restartP3' :: RestartClass3 a => a -> X a
 > restartP3'     = startP3' <=< killP3 <=< refreshPid
 >
 > -- Here are versions of start/restart working on extensible state.
 > -- Usually, these should be used.
 > startP3 :: (ExtensionClass [a], RestartClass3 a) => a -> X ()
 > startP3   = runWith startP3'
 >
 > restartP3 :: (ExtensionClass [a], RestartClass3 a) => a -> X ()
 > restartP3 = runWith restartP3'

Finally, i may define some concerete examples:

 > xmobarTop :: XmobarPID3
 > xmobarTop     = XmobarPID3
 >                   { xmobarPID = First Nothing
 >                   , xmobarConf = "/home/sgf" </> ".xmobarrc"
 >                   }
 > xmobarBot :: XmobarPID3
 > xmobarBot     = XmobarPID3
 >                   { xmobarPID = First Nothing
 >                   , xmobarConf = "/home/sgf" </> ".xmobarrc2"
 >                   }
 > trayer :: TrayerPID3
 > trayer        = TrayerPID3 {trayerPID = First Nothing}
 >
 > feh :: FehPID3
 > feh           = FehPID3 {fehPID = First Nothing}
 >
 > restartXmobarTop :: X ()
 > restartXmobarTop  = restartP3 xmobarTop
 > startXmobarTop :: X ()
 > startXmobarTop    = startP3 xmobarTop
 >
 > restartXmobarBoth :: X ()
 > restartXmobarBoth = mapM_ restartP3 [xmobarTop, xmobarBot]
 > startXmobarBoth :: X ()
 > startXmobarBoth   = mapM_ startP3 [xmobarTop, xmobarBot]
 >
 > restartAll :: X ()
 > restartAll    = do
 >   startP3 feh
 >   restartP3 trayer
 >   mapM_ restartP3 [xmobarTop, xmobarBot]
 > startAll :: X ()
 > startAll    = do
 >   startP3 feh
 >   startP3 trayer
 >   mapM_ startP3 [xmobarTop, xmobarBot]

Usually, i should just use `restartAll` in startupHook .