{-# LANGUAGE CPP #-}

------------------------------------------------------------------------------
-- |
-- Module: Xmobar.App.X11EventLoop
-- Copyright: (c) 2018, 2020, 2022 Jose Antonio Ortega Ruiz
-- License: BSD3-style (see LICENSE)
--
-- Maintainer: jao@gnu.org
-- Stability: unstable
-- Portability: portable
-- Created: Sat Nov 24, 2018 19:40
--
--
-- Event loop
--
------------------------------------------------------------------------------

module Xmobar.X11.Loop (x11Loop) where

import Prelude hiding (lookup)
import Graphics.X11.Xlib hiding (textExtents, textWidth, Segment)
import Graphics.X11.Xlib.Extras
import Graphics.X11.Xinerama
import Graphics.X11.Xrandr

import Control.Arrow ((&&&))
import Control.Monad.Reader
import Control.Concurrent
import Control.Concurrent.STM

import Data.Bits
import Data.Map hiding (foldr, map, filter)
import qualified Data.Map as Map
import Data.List.NonEmpty (NonEmpty(..))

import Data.Maybe (fromJust, isJust)
import qualified Data.List.NonEmpty as NE

import Xmobar.System.Signal
import Xmobar.Config.Types ( persistent
                           , font
                           , additionalFonts
                           , textOffset
                           , textOffsets
                           , position
                           , iconRoot
                           , Config
                           , Align(..)
                           , XPosition(..))

import Xmobar.Run.Actions
import Xmobar.Run.Parsers
import Xmobar.X11.Window
import Xmobar.X11.Text
import Xmobar.X11.Draw
import Xmobar.X11.Bitmap as Bitmap
import Xmobar.X11.Types
import Xmobar.System.Utils (safeIndex, forkThread)

import Xmobar.Run.Loop (loop)

#ifndef THREADED_RUNTIME
import Xmobar.X11.Events(nextEvent')
#endif

#ifdef XFT
import Graphics.X11.Xft
#endif

runX :: XConf -> X () -> IO ()
runX :: XConf -> X () -> IO ()
runX XConf
xc X ()
f = X () -> XConf -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT X ()
f XConf
xc

-- | Starts the main event loop and threads
x11Loop :: Config -> IO ()
x11Loop :: Config -> IO ()
x11Loop Config
conf = do
  IO Status
initThreads
  Display
d <- String -> IO Display
openDisplay String
""
  XFont
fs <- Display -> String -> IO XFont
initFont Display
d (Config -> String
font Config
conf)
  [XFont]
fl <- (String -> IO XFont) -> [String] -> IO [XFont]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Display -> String -> IO XFont
initFont Display
d) (Config -> [String]
additionalFonts Config
conf)
  let ic :: Map k a
ic = Map k a
forall k a. Map k a
Map.empty
      to :: Int
to = Config -> Int
textOffset Config
conf
      ts :: [Int]
ts = Config -> [Int]
textOffsets Config
conf [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ Int -> Int -> [Int]
forall a. Int -> a -> [a]
replicate ([XFont] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [XFont]
fl) (-Int
1)
#ifdef XFT
  xftInitFtLibrary
#endif
  (Rectangle
r,Window
w) <- Display -> XFont -> Config -> IO (Rectangle, Window)
createWin Display
d XFont
fs Config
conf
  Config -> LoopFunction -> IO ()
loop Config
conf (XConf -> LoopFunction
startLoop (Display
-> Rectangle
-> Window
-> NonEmpty XFont
-> NonEmpty Int
-> Map String Bitmap
-> Config
-> XConf
XConf Display
d Rectangle
r Window
w (XFont
fs XFont -> [XFont] -> NonEmpty XFont
forall a. a -> [a] -> NonEmpty a
:| [XFont]
fl) (Int
to Int -> [Int] -> NonEmpty Int
forall a. a -> [a] -> NonEmpty a
:| [Int]
ts) Map String Bitmap
forall k a. Map k a
ic Config
conf))

startLoop :: XConf -> TMVar SignalType -> TVar [String] -> IO ()
startLoop :: XConf -> LoopFunction
startLoop xcfg :: XConf
xcfg@(XConf Display
_ Rectangle
_ Window
w NonEmpty XFont
_ NonEmpty Int
_ Map String Bitmap
_ Config
_) TMVar SignalType
sig TVar [String]
tv = do
    String -> IO () -> IO ()
forkThread String
"X event handler" (Window -> TMVar SignalType -> IO ()
x11EventLoop Window
w TMVar SignalType
sig)
    XConf -> [([Action], Position, Position)] -> LoopFunction
signalLoop XConf
xcfg [] TMVar SignalType
sig TVar [String]
tv

-- | Translates X11 events received by w to signals handled by signalLoop
x11EventLoop :: Window -> TMVar SignalType -> IO ()
x11EventLoop :: Window -> TMVar SignalType -> IO ()
x11EventLoop Window
w TMVar SignalType
signal =
  (XEventPtr -> IO ()) -> IO ()
forall a. (XEventPtr -> IO a) -> IO a
allocaXEvent ((XEventPtr -> IO ()) -> IO ()) -> (XEventPtr -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \XEventPtr
e -> do
    Display
dpy <- String -> IO Display
openDisplay String
""
    Display -> Window -> Window -> IO ()
xrrSelectInput Display
dpy (Display -> Window
defaultRootWindow Display
dpy) Window
rrScreenChangeNotifyMask
    Display -> Window -> Window -> IO ()
selectInput Display
dpy Window
w (Window
exposureMask Window -> Window -> Window
forall a. Bits a => a -> a -> a
.|. Window
structureNotifyMask Window -> Window -> Window
forall a. Bits a => a -> a -> a
.|. Window
buttonPressMask)

    IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
#ifdef THREADED_RUNTIME
      nextEvent dpy e
#else
      Display -> XEventPtr -> IO ()
nextEvent' Display
dpy XEventPtr
e
#endif
      Event
ev <- XEventPtr -> IO Event
getEvent XEventPtr
e
      case Event
ev of
        ConfigureEvent {} -> STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar SignalType -> SignalType -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar SignalType
signal SignalType
Reposition
        ExposeEvent {} -> STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar SignalType -> SignalType -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar SignalType
signal SignalType
Wakeup
        RRScreenChangeNotifyEvent {} -> STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar SignalType -> SignalType -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar SignalType
signal SignalType
Reposition
        ButtonEvent {} -> STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$
               TMVar SignalType -> SignalType -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar SignalType
signal (Button -> Position -> SignalType
Action (Event -> Button
ev_button Event
ev) (Status -> Position
forall a b. (Integral a, Num b) => a -> b
fi (Status -> Position) -> Status -> Position
forall a b. (a -> b) -> a -> b
$ Event -> Status
ev_x Event
ev))
        Event
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Continuously wait for a signal from a thread or an interrupt handler
signalLoop :: XConf
          -> [([Action], Position, Position)]
          -> TMVar SignalType
          -> TVar [String]
          -> IO ()
signalLoop :: XConf -> [([Action], Position, Position)] -> LoopFunction
signalLoop xc :: XConf
xc@(XConf Display
d Rectangle
r Window
w NonEmpty XFont
fs NonEmpty Int
vos Map String Bitmap
is Config
cfg) [([Action], Position, Position)]
as TMVar SignalType
signal TVar [String]
tv = do
      SignalType
typ <- STM SignalType -> IO SignalType
forall a. STM a -> IO a
atomically (STM SignalType -> IO SignalType)
-> STM SignalType -> IO SignalType
forall a b. (a -> b) -> a -> b
$ TMVar SignalType -> STM SignalType
forall a. TMVar a -> STM a
takeTMVar TMVar SignalType
signal
      case SignalType
typ of
         SignalType
Wakeup -> do
            [[Segment]]
str <- Config -> TVar [String] -> IO [[Segment]]
updateString Config
cfg TVar [String]
tv
            XConf
xc' <- Display
-> Window
-> Map String Bitmap
-> String
-> [[Segment]]
-> IO (Map String Bitmap)
updateCache Display
d Window
w Map String Bitmap
is (Config -> String
iconRoot Config
cfg) [[Segment]]
str IO (Map String Bitmap)
-> (Map String Bitmap -> IO XConf) -> IO XConf
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                     \Map String Bitmap
c -> XConf -> IO XConf
forall (m :: * -> *) a. Monad m => a -> m a
return XConf
xc { iconS :: Map String Bitmap
iconS = Map String Bitmap
c }
            [([Action], Position, Position)]
as' <- XConf
-> Rectangle -> [[Segment]] -> IO [([Action], Position, Position)]
updateActions XConf
xc Rectangle
r [[Segment]]
str
            XConf -> X () -> IO ()
runX XConf
xc' (X () -> IO ()) -> X () -> IO ()
forall a b. (a -> b) -> a -> b
$ Rectangle -> [[Segment]] -> X ()
drawInWin Rectangle
r [[Segment]]
str
            XConf -> [([Action], Position, Position)] -> LoopFunction
signalLoop XConf
xc' [([Action], Position, Position)]
as' TMVar SignalType
signal TVar [String]
tv

         SignalType
Reposition ->
            Config -> IO ()
reposWindow Config
cfg

         SignalType
ChangeScreen -> do
            Config
ncfg <- Config -> IO Config
updateConfigPosition Config
cfg
            Config -> IO ()
reposWindow Config
ncfg

         Hide   Int
t -> Int -> IO ()
hide   (Int
tInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
100Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
1000)
         Reveal Int
t -> Int -> IO ()
reveal (Int
tInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
100Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
1000)
         Toggle Int
t -> Int -> IO ()
toggle Int
t

         SignalType
TogglePersistent -> XConf -> [([Action], Position, Position)] -> LoopFunction
signalLoop
            XConf
xc { config :: Config
config = Config
cfg { persistent :: Bool
persistent = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Config -> Bool
persistent Config
cfg } } [([Action], Position, Position)]
as TMVar SignalType
signal TVar [String]
tv

         Action Button
but Position
x -> Button -> Position -> IO ()
action Button
but Position
x

    where
        isPersistent :: Bool
isPersistent = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Config -> Bool
persistent Config
cfg
        loopOn :: IO ()
loopOn = XConf -> [([Action], Position, Position)] -> LoopFunction
signalLoop XConf
xc [([Action], Position, Position)]
as TMVar SignalType
signal TVar [String]
tv
        hide :: Int -> IO ()
hide Int
t
            | Int
t Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 =
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isPersistent (Display -> Window -> IO ()
hideWindow Display
d Window
w) IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
loopOn
            | Bool
otherwise = do
                IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO
                     (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
t IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> STM () -> IO ()
forall a. STM a -> IO a
atomically (TMVar SignalType -> SignalType -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar SignalType
signal (SignalType -> STM ()) -> SignalType -> STM ()
forall a b. (a -> b) -> a -> b
$ Int -> SignalType
Hide Int
0)
                IO ()
loopOn

        reveal :: Int -> IO ()
reveal Int
t
            | Int
t Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = do
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isPersistent (Rectangle -> Config -> Display -> Window -> IO ()
showWindow Rectangle
r Config
cfg Display
d Window
w)
                IO ()
loopOn
            | Bool
otherwise = do
                IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO
                     (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
t IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> STM () -> IO ()
forall a. STM a -> IO a
atomically (TMVar SignalType -> SignalType -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar SignalType
signal (SignalType -> STM ()) -> SignalType -> STM ()
forall a b. (a -> b) -> a -> b
$ Int -> SignalType
Reveal Int
0)
                IO ()
loopOn

        toggle :: Int -> IO ()
toggle Int
t = do
            Bool
ismapped <- Display -> Window -> IO Bool
isMapped Display
d Window
w
            STM () -> IO ()
forall a. STM a -> IO a
atomically (TMVar SignalType -> SignalType -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar SignalType
signal (SignalType -> STM ()) -> SignalType -> STM ()
forall a b. (a -> b) -> a -> b
$ if Bool
ismapped then Int -> SignalType
Hide Int
t else Int -> SignalType
Reveal Int
t)
            IO ()
loopOn

        reposWindow :: Config -> IO ()
reposWindow Config
rcfg = do
          Rectangle
r' <- Display -> Window -> XFont -> Config -> IO Rectangle
repositionWin Display
d Window
w (NonEmpty XFont -> XFont
forall a. NonEmpty a -> a
NE.head NonEmpty XFont
fs) Config
rcfg
          XConf -> [([Action], Position, Position)] -> LoopFunction
signalLoop (Display
-> Rectangle
-> Window
-> NonEmpty XFont
-> NonEmpty Int
-> Map String Bitmap
-> Config
-> XConf
XConf Display
d Rectangle
r' Window
w NonEmpty XFont
fs NonEmpty Int
vos Map String Bitmap
is Config
rcfg) [([Action], Position, Position)]
as TMVar SignalType
signal TVar [String]
tv

        updateConfigPosition :: Config -> IO Config
updateConfigPosition Config
ocfg =
          case Config -> XPosition
position Config
ocfg of
            OnScreen Int
n XPosition
o -> do
              [Rectangle]
srs <- Display -> IO [Rectangle]
getScreenInfo Display
d
              Config -> IO Config
forall (m :: * -> *) a. Monad m => a -> m a
return (if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Rectangle] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Rectangle]
srs
                       then
                        (Config
ocfg {position :: XPosition
position = Int -> XPosition -> XPosition
OnScreen Int
1 XPosition
o})
                       else
                        (Config
ocfg {position :: XPosition
position = Int -> XPosition -> XPosition
OnScreen (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) XPosition
o}))
            XPosition
o -> Config -> IO Config
forall (m :: * -> *) a. Monad m => a -> m a
return (Config
ocfg {position :: XPosition
position = Int -> XPosition -> XPosition
OnScreen Int
1 XPosition
o})

        action :: Button -> Position -> IO ()
action Button
button Position
x = do
          (Action -> IO ()) -> [Action] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Action -> IO ()
runAction ([Action] -> IO ()) -> [Action] -> IO ()
forall a b. (a -> b) -> a -> b
$
            (Action -> Bool) -> [Action] -> [Action]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Spawn [Button]
b String
_) -> Button
button Button -> [Button] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Button]
b) ([Action] -> [Action]) -> [Action] -> [Action]
forall a b. (a -> b) -> a -> b
$
            (([Action], Position, Position) -> [Action])
-> [([Action], Position, Position)] -> [Action]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\([Action]
a,Position
_,Position
_) -> [Action]
a) ([([Action], Position, Position)] -> [Action])
-> [([Action], Position, Position)] -> [Action]
forall a b. (a -> b) -> a -> b
$
            (([Action], Position, Position) -> Bool)
-> [([Action], Position, Position)]
-> [([Action], Position, Position)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\([Action]
_, Position
from, Position
to) -> Position
x Position -> Position -> Bool
forall a. Ord a => a -> a -> Bool
>= Position
from Bool -> Bool -> Bool
&& Position
x Position -> Position -> Bool
forall a. Ord a => a -> a -> Bool
<= Position
to) [([Action], Position, Position)]
as
          IO ()
loopOn

updateString :: Config -> TVar [String] -> IO [[Segment]]
updateString :: Config -> TVar [String] -> IO [[Segment]]
updateString Config
conf TVar [String]
v = do
  [String]
s <- TVar [String] -> IO [String]
forall a. TVar a -> IO a
readTVarIO TVar [String]
v
  let String
l:String
c:String
r:[String]
_ = [String]
s [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ String -> [String]
forall a. a -> [a]
repeat String
""
  IO [[Segment]] -> IO [[Segment]]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [[Segment]] -> IO [[Segment]])
-> IO [[Segment]] -> IO [[Segment]]
forall a b. (a -> b) -> a -> b
$ (String -> IO [Segment]) -> [String] -> IO [[Segment]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Config -> String -> IO [Segment]
parseString Config
conf) [String
l, String
c, String
r]

updateActions :: XConf -> Rectangle -> [[Segment]]
              -> IO [([Action], Position, Position)]
updateActions :: XConf
-> Rectangle -> [[Segment]] -> IO [([Action], Position, Position)]
updateActions XConf
conf (Rectangle Position
_ Position
_ Button
wid Button
_) ~[[Segment]
left,[Segment]
center,[Segment]
right] = do
  let (Display
d,NonEmpty XFont
fs) = (XConf -> Display
display (XConf -> Display)
-> (XConf -> NonEmpty XFont) -> XConf -> (Display, NonEmpty XFont)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& XConf -> NonEmpty XFont
fontListS) XConf
conf
      strLn :: [Segment] -> IO [(Maybe [Action], Position, Position)]
      strLn :: [Segment] -> IO [(Maybe [Action], Position, Position)]
strLn  = IO [(Maybe [Action], Position, Position)]
-> IO [(Maybe [Action], Position, Position)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(Maybe [Action], Position, Position)]
 -> IO [(Maybe [Action], Position, Position)])
-> ([Segment] -> IO [(Maybe [Action], Position, Position)])
-> [Segment]
-> IO [(Maybe [Action], Position, Position)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Segment -> IO (Maybe [Action], Position, Position))
-> [Segment] -> IO [(Maybe [Action], Position, Position)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Segment -> IO (Maybe [Action], Position, Position)
forall b c b a.
(Num b, Num c) =>
(Widget, b, Int, a) -> IO (a, b, c)
getCoords
      iconW :: String -> Button
iconW String
i = Button -> (Bitmap -> Button) -> Maybe Bitmap -> Button
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Button
0 Bitmap -> Button
Bitmap.width (String -> Map String Bitmap -> Maybe Bitmap
forall k a. Ord k => k -> Map k a -> Maybe a
lookup String
i (Map String Bitmap -> Maybe Bitmap)
-> Map String Bitmap -> Maybe Bitmap
forall a b. (a -> b) -> a -> b
$ XConf -> Map String Bitmap
iconS XConf
conf)
      getCoords :: (Widget, b, Int, a) -> IO (a, b, c)
getCoords (Text String
s,b
_,Int
i,a
a) =
        Display -> XFont -> String -> IO Int
textWidth Display
d (NonEmpty XFont -> Int -> XFont
forall a. NonEmpty a -> Int -> a
safeIndex NonEmpty XFont
fs Int
i) String
s IO Int -> (Int -> IO (a, b, c)) -> IO (a, b, c)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Int
tw -> (a, b, c) -> IO (a, b, c)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, b
0, Int -> c
forall a b. (Integral a, Num b) => a -> b
fi Int
tw)
      getCoords (Icon String
s,b
_,Int
_,a
a) = (a, b, c) -> IO (a, b, c)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, b
0, Button -> c
forall a b. (Integral a, Num b) => a -> b
fi (Button -> c) -> Button -> c
forall a b. (a -> b) -> a -> b
$ String -> Button
iconW String
s)
      getCoords (Hspace Position
w,b
_,Int
_,a
a) = (a, b, c) -> IO (a, b, c)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, b
0, Position -> c
forall a b. (Integral a, Num b) => a -> b
fi Position
w)
      partCoord :: c -> [(Maybe a, b, c)] -> [(a, c, c)]
partCoord c
off [(Maybe a, b, c)]
xs = ((Maybe a, c, c) -> (a, c, c)) -> [(Maybe a, c, c)] -> [(a, c, c)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Maybe a
a, c
x, c
x') -> (Maybe a -> a
forall a. HasCallStack => Maybe a -> a
fromJust Maybe a
a, c
x, c
x')) ([(Maybe a, c, c)] -> [(a, c, c)])
-> [(Maybe a, c, c)] -> [(a, c, c)]
forall a b. (a -> b) -> a -> b
$
                         ((Maybe a, c, c) -> Bool) -> [(Maybe a, c, c)] -> [(Maybe a, c, c)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Maybe a
a, c
_,c
_) -> Maybe a -> Bool
forall a. Maybe a -> Bool
isJust Maybe a
a) ([(Maybe a, c, c)] -> [(Maybe a, c, c)])
-> [(Maybe a, c, c)] -> [(Maybe a, c, c)]
forall a b. (a -> b) -> a -> b
$
                         ((Maybe a, c, c) -> (Maybe a, b, c) -> (Maybe a, c, c))
-> (Maybe a, c, c) -> [(Maybe a, b, c)] -> [(Maybe a, c, c)]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl (\(Maybe a
_,c
_,c
x') (Maybe a
a,b
_,c
w') -> (Maybe a
a, c
x', c
x' c -> c -> c
forall a. Num a => a -> a -> a
+ c
w'))
                               (Maybe a
forall a. Maybe a
Nothing, c
0, c
off)
                               [(Maybe a, b, c)]
xs
      totSLen :: [(a, b, Position)] -> Position
totSLen = ((a, b, Position) -> Position -> Position)
-> Position -> [(a, b, Position)] -> Position
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(a
_,b
_,Position
len) -> Position -> Position -> Position
forall a. Num a => a -> a -> a
(+) Position
len) Position
0
      remWidth :: [(a, b, Position)] -> Position
remWidth [(a, b, Position)]
xs = Button -> Position
forall a b. (Integral a, Num b) => a -> b
fi Button
wid Position -> Position -> Position
forall a. Num a => a -> a -> a
- [(a, b, Position)] -> Position
forall a b. [(a, b, Position)] -> Position
totSLen [(a, b, Position)]
xs
      offs :: Position
offs = Position
1
      offset :: Align -> [(a, b, Position)] -> Position
offset Align
a [(a, b, Position)]
xs = case Align
a of
                     Align
C -> ([(a, b, Position)] -> Position
forall a b. [(a, b, Position)] -> Position
remWidth [(a, b, Position)]
xs Position -> Position -> Position
forall a. Num a => a -> a -> a
+ Position
offs) Position -> Position -> Position
forall a. Integral a => a -> a -> a
`div` Position
2
                     Align
R -> [(a, b, Position)] -> Position
forall a b. [(a, b, Position)] -> Position
remWidth [(a, b, Position)]
xs
                     Align
L -> Position
offs
  ([[([Action], Position, Position)]]
 -> [([Action], Position, Position)])
-> IO [[([Action], Position, Position)]]
-> IO [([Action], Position, Position)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[([Action], Position, Position)]]
-> [([Action], Position, Position)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (IO [[([Action], Position, Position)]]
 -> IO [([Action], Position, Position)])
-> IO [[([Action], Position, Position)]]
-> IO [([Action], Position, Position)]
forall a b. (a -> b) -> a -> b
$ ((Align, [Segment]) -> IO [([Action], Position, Position)])
-> [(Align, [Segment])] -> IO [[([Action], Position, Position)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(Align
a,[Segment]
xs) ->
                       (\[(Maybe [Action], Position, Position)]
xs' -> Position
-> [(Maybe [Action], Position, Position)]
-> [([Action], Position, Position)]
forall c a b. Num c => c -> [(Maybe a, b, c)] -> [(a, c, c)]
partCoord (Align -> [(Maybe [Action], Position, Position)] -> Position
forall a b. Align -> [(a, b, Position)] -> Position
offset Align
a [(Maybe [Action], Position, Position)]
xs') [(Maybe [Action], Position, Position)]
xs') ([(Maybe [Action], Position, Position)]
 -> [([Action], Position, Position)])
-> IO [(Maybe [Action], Position, Position)]
-> IO [([Action], Position, Position)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Segment] -> IO [(Maybe [Action], Position, Position)]
strLn [Segment]
xs) ([(Align, [Segment])] -> IO [[([Action], Position, Position)]])
-> [(Align, [Segment])] -> IO [[([Action], Position, Position)]]
forall a b. (a -> b) -> a -> b
$
                     [Align] -> [[Segment]] -> [(Align, [Segment])]
forall a b. [a] -> [b] -> [(a, b)]
zip [Align
L,Align
C,Align
R] [[Segment]
left,[Segment]
center,[Segment]
right]