Scroller.hs

{-# LANGUAGE RecordWildCards #-}
module XNobar.Internal.Scroller where

import Control.Arrow ((&&&))
import Data.Function ((&))
import Data.List (genericLength, partition)
import Data.List.Extra (groupOn)
import Data.Semigroup (Max(Max))
import Data.Tuple.Extra (both, first, second, third3)
import Flow ((.>))

import XNobar.Internal.Notification (Notification(..), urgency, Id)
import XNobar.Internal.Positive32 (toWord32)

type Offset = Int

-- |Configuration. In fact, this is the way to instantiate and customize the plugin,
-- but it's just more practical to use 'xNobar', as it sets some decent default values.
data Config = Config {
    idleText :: !String -- ^ Default string (to be shown steady) when no notification is left.
  , marqueeLength :: !Int -- ^ Width (in number of characters) of the scrolling marquee (this is unrelated ot the length of the first argument).
  , fontNumber :: !Int -- ^ Number of the font used for notifications, as per xmobar config (it's not applied to the idleText).
  , scrollPeriod :: !Int -- ^ Scrolling rate (in tenths of seconds per character).
  , noNewsPrefix :: !String -- ^ Prefix to the idleText.
  , newsPrefix :: !String -- ^ Prefix to the scrolling marquee.
  , criticalPrefix :: !String -- ^ Prefix to the critical nontification.
  , nonCriticalPrefix :: !String -- ^ Prefix to the non-critical nontification.
  , lineBreak :: !String -- ^ String to render a line break.
  } deriving (Read, -- ^ For integration with [XMobar](https://codeberg.org/xmobar/xmobar).
              Show) -- ^ For integration with [XMobar](https://codeberg.org/xmobar/xmobar).

theId = fst

scroll :: (Show n) => Maybe (Id, Offset, [(Id, n)]) -> Maybe (Id, Offset, [(Id, n)])
scroll Nothing = Nothing
scroll (Just (i, o, notifs)) = let notifs' = cycle notifs & dropWhile (theId .> (/= i))
                                   (i', n') = head notifs'
                                   (i'', _) = notifs' !! 1
                               in Just $ if o < genericLength (show n') - 1
                                           then (i', o + 1, notifs)
                                           else (i'',    0, notifs)

enableClick p ((Max i, u), s) = attachAction ("echo -n 0 > " ++ p) 3
                              $ attachAction ("echo -n " ++ show i ++ " > " ++ p) 1
                                             ((if u == 2 then red else id) s)

red :: String -> String
red = wrap "<fc=#ff0000>" "</fc>"

attachAction a b = wrap ("<action=`" ++ a ++ "` button=" ++ show b ++ ">")
                        "</action>"

wrap a c b = a ++ b ++ c

-- TODO: probably Offset should be a class
-- TODO: The first arugment could be a `NonEmpty` list
merge :: [(Id, n)] -> Maybe (Id, Offset, [(Id, n)]) -> Maybe (Id, Offset, [(Id, n)])
merge [] _             = error "This should not be possible!"
merge news Nothing     = Just (theId $ head news, 0, news)
merge news (Just olds) = Just $ third3 (`combine` news) olds

remove :: Num offset
       => Maybe Id -> Maybe (Id, offset, [(Id, Notification)])
                   -> Maybe (Id, offset, [(Id, Notification)])
remove Nothing Nothing              = error "This should not be possible!"
remove Nothing (Just (_, _, []))    = error "This should not be possible!"
remove Nothing (Just (_, _, ns))  = let (u:us) = map (urgency . snd) ns
                                    in case partition ((== 2) . urgency . snd) ns of
                                        (urgent@((i, _):_), _:_) -> Just (i, 0, urgent)
                                        _ -> Nothing
remove (Just _) Nothing             = error "This should not be possible!"
remove (Just _) (Just (_, _, []))   = error "This should not be possible!"
remove (Just i) (Just (i', _, [_])) = if i /= i'
                                then error "This should not be possible!"
                                else Nothing
remove (Just i) (Just (i', o, ns))  = let l = length ns
                                          (b, a) = second tail $ break ((== i) . theId) $ cycle ns
                                          ns' = take (l - 1) $ b ++ a
                                          newCurr = head $ if null a then b else a
                              in Just (if i == i'
                                            then (theId newCurr, 0, ns')
                                            else (i',            o, ns'))

combine :: [(Id, n)] -> [(Id, n)] -> [(Id, n)]
combine olds news = olds' <> news
  where
    olds' = filter (theId .> (not . (`elem` (theId <$> news)))) olds

showNotifs :: Config -> String -> (Id, Offset, [(Id, Notification)]) -> String
showNotifs (Config{..}) pipe (curId, curOffset, oldNotifs) =
  oldNotifs
    -- repeat notifications indefinitely
    & cycle
    -- drop until current notification
    & dropWhile (theId .> (/= curId))
    -- decompose notifications in individual characters (keeping id and urgency attached)
    & (>>= ((theId &&& getUrgency) &&& showNotif) .> sequence)
    -- drop characters that have already flowed beyond the left border
    & drop curOffset
    --- retain only as many characters as required
    & take marqueeLength
    -- re-group according to ID
    & groupOn theId
    -- re-join characters into notifications
    & fmap (joinChars .> toWord32')
    -- encode the click
    & (>>= enableClick pipe)
    -- render line breaks nicely
    & (>>= niceLineBreak)
    -- prepend number of notifications (if ≥ 2)
    & case both length (partition ((== 2) . urgency . snd) oldNotifs) of
        (n1, n2) | n1 + n2 == 1 -> id
                 | n1 == 0 -> (wrap "(" ") " (show n2) ++)
                 | n2 == 0 -> (wrap "(" ") " (red $ show n1) ++)
                 | otherwise -> (wrap "(" ") " (red (show n1) ++ '+':show n2) ++)
    -- prepend prefix for news
    & (newsPrefix ++)
    -- apply font
    & (`withFont` fontNumber)
  where
    t `withFont` f = wrap ("<fn=" ++ show f ++ ">") "</fn>" t
    getNotif = snd
    getUrgency = getNotif .> urgency
    toWord32' = first (first toWord32)
    joinChars l = (theId (head l), map getNotif l)
    niceLineBreak c = if c `elem` ['\r', '\n']
                        then lineBreak
                        else pure c
    showNotif n = let notif = getNotif n
                      emoji = if urgency notif == 2
                                then criticalPrefix
                                else nonCriticalPrefix
                  in emoji ++ show notif

instance Show Notification where
  show n = summary n ++ maybeBody ++ "  "
    where
      maybeBody = if not $ null $ body n
                    then " | " ++ body n
                    else ""