-----------------------------------------------------------------------------
-- |
-- Module      :  Plugins.MarqueePipeReader
-- Copyright   :  (c) Reto Habluetzel
-- License     :  BSD-style (see LICENSE)
--
-- Maintainer  :  Jose A. Ortega Ruiz <jao@gnu.org>
-- Stability   :  unstable
-- Portability :  unportable
--
-- A plugin for reading from named pipes for long texts with marquee
--
-----------------------------------------------------------------------------

module Xmobar.Plugins.MarqueePipeReader(MarqueePipeReader(..)) where

import System.IO (openFile, IOMode(ReadWriteMode), Handle, hGetLine)
import Xmobar.System.Environment
import Xmobar.Run.Exec(Exec(alias, start), tenthSeconds)
import System.Posix.Files (getFileStatus, isNamedPipe)
import Control.Concurrent(forkIO, threadDelay)
import Control.Concurrent.STM (TChan, atomically, writeTChan, tryReadTChan, newTChan)
import Control.Exception
import Control.Monad(forever, unless)

type Length = Int       -- length of the text to display
type Rate = Int         -- delay in tenth seconds
type Separator = String -- if text wraps around, use separator

data MarqueePipeReader = MarqueePipeReader String (Length, Rate, Separator) String
    deriving (ReadPrec [MarqueePipeReader]
ReadPrec MarqueePipeReader
Int -> ReadS MarqueePipeReader
ReadS [MarqueePipeReader]
(Int -> ReadS MarqueePipeReader)
-> ReadS [MarqueePipeReader]
-> ReadPrec MarqueePipeReader
-> ReadPrec [MarqueePipeReader]
-> Read MarqueePipeReader
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [MarqueePipeReader]
$creadListPrec :: ReadPrec [MarqueePipeReader]
readPrec :: ReadPrec MarqueePipeReader
$creadPrec :: ReadPrec MarqueePipeReader
readList :: ReadS [MarqueePipeReader]
$creadList :: ReadS [MarqueePipeReader]
readsPrec :: Int -> ReadS MarqueePipeReader
$creadsPrec :: Int -> ReadS MarqueePipeReader
Read, Int -> MarqueePipeReader -> ShowS
[MarqueePipeReader] -> ShowS
MarqueePipeReader -> String
(Int -> MarqueePipeReader -> ShowS)
-> (MarqueePipeReader -> String)
-> ([MarqueePipeReader] -> ShowS)
-> Show MarqueePipeReader
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MarqueePipeReader] -> ShowS
$cshowList :: [MarqueePipeReader] -> ShowS
show :: MarqueePipeReader -> String
$cshow :: MarqueePipeReader -> String
showsPrec :: Int -> MarqueePipeReader -> ShowS
$cshowsPrec :: Int -> MarqueePipeReader -> ShowS
Show)

instance Exec MarqueePipeReader where
    alias :: MarqueePipeReader -> String
alias (MarqueePipeReader String
_ (Int, Int, String)
_ String
a)    = String
a
    start :: MarqueePipeReader -> (String -> IO ()) -> IO ()
start (MarqueePipeReader String
p (Int
len, Int
rate, String
sep) String
_) String -> IO ()
cb = do
        (String
def, String
pipe) <- Char -> String -> (String, String)
forall a. Eq a => a -> [a] -> ([a], [a])
split Char
':' (String -> (String, String)) -> IO String -> IO (String, String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
expandEnv String
p
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
def) (String -> IO ()
cb String
def)
        String -> IO ()
checkPipe String
pipe
        Handle
h <- String -> IOMode -> IO Handle
openFile String
pipe IOMode
ReadWriteMode
        String
line <- Handle -> IO String
hGetLine Handle
h
        TChan String
chan <- STM (TChan String) -> IO (TChan String)
forall a. STM a -> IO a
atomically STM (TChan String)
forall a. STM (TChan a)
newTChan
        IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ String
-> String
-> Int
-> Int
-> TChan String
-> (String -> IO ())
-> IO ()
writer (String -> ShowS
toInfTxt String
line String
sep) String
sep Int
len Int
rate TChan String
chan String -> IO ()
cb
        IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> TChan String -> IO ()
pipeToChan Handle
h TChan String
chan
      where
        split :: a -> [a] -> ([a], [a])
split a
c [a]
xs | a
c a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [a]
xs = let ([a]
pre, [a]
post) = (a -> Bool) -> [a] -> ([a], [a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (a
c a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/=) [a]
xs
                                   in ([a]
pre, (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (a
c a -> a -> Bool
forall a. Eq a => a -> a -> Bool
==) [a]
post)
                   | Bool
otherwise   = ([], [a]
xs)

pipeToChan :: Handle -> TChan String -> IO ()
pipeToChan :: Handle -> TChan String -> IO ()
pipeToChan Handle
h TChan String
chan = do
    String
line <- Handle -> IO String
hGetLine Handle
h
    STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TChan String -> String -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan String
chan String
line

writer :: String -> Separator -> Length -> Rate -> TChan String -> (String -> IO ()) -> IO ()
writer :: String
-> String
-> Int
-> Int
-> TChan String
-> (String -> IO ())
-> IO ()
writer String
txt String
sep Int
len Int
rate TChan String
chan String -> IO ()
cb = do
    String -> IO ()
cb (Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
len String
txt)
    Maybe String
mbnext <- STM (Maybe String) -> IO (Maybe String)
forall a. STM a -> IO a
atomically (STM (Maybe String) -> IO (Maybe String))
-> STM (Maybe String) -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ TChan String -> STM (Maybe String)
forall a. TChan a -> STM (Maybe a)
tryReadTChan TChan String
chan
    case Maybe String
mbnext of
        Just String
new -> String
-> String
-> Int
-> Int
-> TChan String
-> (String -> IO ())
-> IO ()
writer (String -> ShowS
toInfTxt String
new String
sep) String
sep Int
len Int
rate TChan String
chan String -> IO ()
cb
        Maybe String
Nothing -> Int -> IO ()
tenthSeconds Int
rate IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String
-> String
-> Int
-> Int
-> TChan String
-> (String -> IO ())
-> IO ()
writer (Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
1 String
txt) String
sep Int
len Int
rate TChan String
chan String -> IO ()
cb

toInfTxt :: String -> String -> String
toInfTxt :: String -> ShowS
toInfTxt String
line String
sep = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (String -> [String]
forall a. a -> [a]
repeat (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ String
line String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
sep String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" ")

checkPipe :: FilePath -> IO ()
checkPipe :: String -> IO ()
checkPipe String
file = (SomeException -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle (\(SomeException e
_) -> IO ()
waitForPipe) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                    FileStatus
status <- String -> IO FileStatus
getFileStatus String
file
                    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (FileStatus -> Bool
isNamedPipe FileStatus
status) IO ()
waitForPipe
    where waitForPipe :: IO ()
waitForPipe = Int -> IO ()
threadDelay Int
1000 IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO ()
checkPipe String
file