Huge refactor for the Haskell code.HEADmain

This adds new layout configuration, preparing for actually using the
layouts. This also restructures the code and tries to keep code
interfacing with the foreign structures together and rename them to more
sensible names.

1 files changed, 147 insertions, 171 deletions

diff --git a/src/Wetterhorn/Core.hs b/src/Wetterhorn/Core.hs
index d3515fc..d853191 100644
--- a/src/Wetterhorn/Core.hs
+++ b/src/Wetterhorn/Core.hs
@@ -1,176 +1,152 @@
 {-# HLINT ignore "Use camelCase" #-}
 
 module Wetterhorn.Core
-  ( WState (..),
-    WConfig (..),
-    SurfaceState (..),
-    W,
-    getWConfig,
-    getWState,
-    runW,
-    Wetterhorn,
-    initWetterhorn,
-    wio,
-    incrementState,
-    readWState,
-    defaultConfig,
-    requestHotReload,
-    ctxConfig,
-    KeyEvent (..),
-    KeyState (..),
-  )
+--   ( WState (..),
+--     WConfig (..),
+--     SurfaceState (..),
+--     W,
+--     getWConfig,
+--     getWState,
+--     runW,
+--     Wetterhorn,
+--     initWetterhorn,
+--     wio,
+--     incrementState,
+--     readWState,
+--     defaultConfig,
+--     requestHotReload,
+--     ctxConfig,
+--     KeyEvent (..),
+--     KeyState (..),
+--   )
 where
 
-import Control.Arrow (first)
-import Control.Exception
-import Control.Monad (when)
-import Data.ByteString (ByteString)
-import qualified Data.ByteString.Char8 as CH
-import Data.Char (chr, ord)
-import Data.Map (Map)
-import qualified Data.Map as Map
-import Data.Maybe (fromMaybe)
-import Foreign (Ptr, StablePtr, Word32, castForeignPtr, newStablePtr, ptrToIntPtr)
-import Numeric (showHex)
-import Text.Printf
-import Wetterhorn.Core.ForeignInterface (ForeignInterface)
-import qualified Wetterhorn.Core.ForeignInterface as ForeignInterface
-import Wetterhorn.WlRoots
-
-data WContext = WContext
-  { ctxForeignInterface :: ForeignInterface,
-    ctxConfig :: WConfig
-  }
-
--- This is the OpaqueState passed to the harness.
-type Wetterhorn = StablePtr (WContext, WState)
-
-requestHotReload :: W ()
-requestHotReload = do
-  fi <- ctxForeignInterface <$> getWContext
-  wio $ ForeignInterface.requestHotReload fi
-
-requestLog :: String -> W ()
-requestLog str = do
-  fi <- ctxForeignInterface <$> getWContext
-  wio $ ForeignInterface.requestLog fi str
-
-requestExit :: Int -> W ()
-requestExit ec = do
-  fi <- ctxForeignInterface <$> getWContext
-  wio $ ForeignInterface.requestExit fi ec
-
-initWetterhorn :: WConfig -> IO Wetterhorn
-initWetterhorn conf = do
-  foreignInterface <- ForeignInterface.getForeignInterface
-  newStablePtr (WContext foreignInterface conf, WState "this is a string" 0)
-
-data WState = WState
-  { someString :: String,
-    integer :: Int
-  }
-  deriving (Show, Read)
-
-data SurfaceState = Map | Unmap | Destroy deriving (Eq, Ord, Show, Enum)
-
-data KeyState = KeyPressed | KeyReleased deriving (Show, Read, Eq, Enum, Ord)
-
-data KeyEvent = KeyEvent
-  { timeMs :: Word32,
-    keycode :: Word32,
-    state :: KeyState,
-    modifiers :: Word32,
-    keysym :: Word32,
-    codepoint :: Char,
-    device :: Ptr WlrInputDevice
-  }
-  deriving (Show, Ord, Eq)
-
-data WConfig = WConfig
-  { keybindingHandler :: KeyEvent -> W Bool,
-    surfaceHandler :: SurfaceState -> Surface -> W ()
-  }
-
-defaultBindings :: Map (KeyState, Word32, Word32) (W ())
-defaultBindings =
-  Map.fromList
-    [ ((KeyPressed, 0x9, sym 'Q'), requestHotReload),
-      ((KeyPressed, 0x8, sym 'r'), wio $ ForeignInterface.doShellExec "wofi --show run"),
-      ((KeyPressed, 0x8, sym 'l'), requestLog "This is a log statement!\n"),
-      ((KeyPressed, 0x8, sym 't'), wio $ ForeignInterface.doShellExec "alacritty"),
-      ((KeyPressed, 0x9, sym 'T'), wio $ ForeignInterface.doShellExec "gnome-terminal"),
-      ((KeyPressed, 0x8, sym 'c'), wio $ ForeignInterface.doShellExec "pavucontrol"),
-      ((KeyPressed, 0x8, sym 'q'), requestExit 0)
-    ]
-  where
-    sym = fromIntegral . ord
-
-defaultConfig :: WConfig
-defaultConfig =
-  WConfig
-    { keybindingHandler = \keyEvent -> do
-        seatPtr <- (wio . ForeignInterface.getSeat . ctxForeignInterface) =<< getWContext
-
-        maybe
-          ( wio $ do
-              wlrSeatSetKeyboard seatPtr (device keyEvent)
-              wlrSeatKeyboardNotifyKey
-                seatPtr
-                (timeMs keyEvent)
-                (keycode keyEvent)
-                ( case state keyEvent of
-                    KeyReleased -> 0
-                    _ -> 1
-                )
-
-              return True
-          )
-          (fmap (const True))
-          $ Map.lookup
-            (state keyEvent, modifiers keyEvent, keysym keyEvent)
-            defaultBindings,
-      surfaceHandler = \state surface -> wio (printf "Surface %s is %s\n" (show surface) (show state))
-    }
-
-readWState :: ByteString -> IO WState
-readWState bs =
-  catch
-    (return $ read (CH.unpack bs))
-    ( \e ->
-        let _ = (e :: SomeException) in return (WState "" 0)
-    )
-
-newtype W a = W ((WContext, WState) -> IO (a, WState))
-
-instance Functor W where
-  fmap mfn (W fn) = W $ fmap (first mfn) <$> fn
-
-instance Applicative W where
-  pure a = W $ \(_, s) -> return (a, s)
-  mfn <*> ma = do
-    fn <- mfn
-    fn <$> ma
-
-instance Monad W where
-  (W fntoa) >>= fnmb = W $ \(config, state) -> do
-    (a, state') <- fntoa (config, state)
-    let W fntob = fnmb a
-    fntob (config, state')
-
-getWContext :: W WContext
-getWContext = W pure
-
-getWConfig :: W WConfig
-getWConfig = ctxConfig <$> getWContext
-
-getWState :: W WState
-getWState = W $ \(_, s) -> pure (s, s)
-
-runW :: W a -> (WContext, WState) -> IO (a, WState)
-runW (W fn) = fn
-
-incrementState :: W Int
-incrementState = W $ \(_, WState s i) -> return (i, WState s (i + 1))
-
-wio :: IO a -> W a
-wio fn = W $ \(_, b) -> fn >>= \a -> return (a, b)
+-- import Control.Arrow (first)
+-- import Control.Exception
+-- import Data.ByteString (ByteString)
+-- import Data.Char (ord)
+-- import Data.Map (Map)
+-- import Foreign (Ptr, StablePtr, Word32, newStablePtr)
+-- import Text.Printf
+-- import Wetterhorn.Foreign.ForeignInterface (ForeignInterface)
+-- import Wetterhorn.Foreign.WlRoots
+-- import qualified Data.ByteString.Char8 as CH
+-- import qualified Data.Map as Map
+-- import qualified Wetterhorn.Foreign.ForeignInterface as ForeignInterface
+-- 
+-- data WContext = WContext
+--   { ctxForeignInterface :: ForeignInterface,
+--     ctxConfig :: WConfig
+--   }
+-- 
+-- -- This is the OpaqueState passed to the harness.
+-- type Wetterhorn = StablePtr (WContext, WState)
+-- 
+-- requestHotReload :: W ()
+-- requestHotReload = do
+--   fi <- ctxForeignInterface <$> getWContext
+--   wio $ ForeignInterface.requestHotReload fi
+-- 
+-- requestLog :: String -> W ()
+-- requestLog str = do
+--   fi <- ctxForeignInterface <$> getWContext
+--   wio $ ForeignInterface.requestLog fi str
+-- 
+-- requestExit :: Int -> W ()
+-- requestExit ec = do
+--   fi <- ctxForeignInterface <$> getWContext
+--   wio $ ForeignInterface.requestExit fi ec
+-- 
+-- initWetterhorn :: WConfig -> IO Wetterhorn
+-- initWetterhorn conf = do
+--   foreignInterface <- ForeignInterface.getForeignInterface
+--   newStablePtr (WContext foreignInterface conf, WState "this is a string" 0)
+-- 
+-- defaultBindings :: Map (KeyState, Word32, Word32) (W ())
+-- defaultBindings =
+--   Map.fromList
+--     [ ((KeyPressed, 0x9, sym 'Q'), requestHotReload),
+--       ((KeyPressed, 0x8, sym 'r'), wio $ ForeignInterface.doShellExec "wofi --show run"),
+--       ((KeyPressed, 0x8, sym 'l'), requestLog "This is a log statement!\n"),
+--       ((KeyPressed, 0x8, sym 't'), wio $ ForeignInterface.doShellExec "alacritty"),
+--       ((KeyPressed, 0x9, sym 'T'), wio $ ForeignInterface.doShellExec "gnome-terminal"),
+--       ((KeyPressed, 0x8, sym 'c'), wio $ ForeignInterface.doShellExec "pavucontrol"),
+--       ( (KeyPressed, 0x8, sym 'p'),
+--         wio $ do
+--           putStrLn "Maps:"
+--           putStrLn =<< readFile "/proc/self/maps"
+--       ),
+--       ((KeyPressed, 0x8, sym 'q'), requestExit 0)
+--     ]
+--   where
+--     sym = fromIntegral . ord
+-- 
+-- defaultConfig :: WConfig
+-- defaultConfig =
+--   WConfig
+--     { keybindingHandler = \keyEvent -> do
+--         seatPtr <- (wio . ForeignInterface.getSeat . ctxForeignInterface) =<< getWContext
+-- 
+--         maybe
+--           ( wio $ do
+--               wlrSeatSetKeyboard seatPtr (device keyEvent)
+--               wlrSeatKeyboardNotifyKey
+--                 seatPtr
+--                 (timeMs keyEvent)
+--                 (keycode keyEvent)
+--                 ( case state keyEvent of
+--                     KeyReleased -> 0
+--                     _ -> 1
+--                 )
+-- 
+--               return True
+--           )
+--           (fmap (const True))
+--           $ Map.lookup
+--             (state keyEvent, modifiers keyEvent, keysym keyEvent)
+--             defaultBindings,
+--       surfaceHandler = \state surface -> wio (printf "Surface %s is %s\n" (show surface) (show state))
+--     }
+-- 
+-- readWState :: ByteString -> IO WState
+-- readWState bs =
+--   catch
+--     (return $ read (CH.unpack bs))
+--     ( \e ->
+--         let _ = (e :: SomeException) in return (WState "" 0)
+--     )
+-- 
+-- newtype W a = W ((WContext, WState) -> IO (a, WState))
+-- 
+-- instance Functor W where
+--   fmap mfn (W fn) = W $ fmap (first mfn) <$> fn
+-- 
+-- instance Applicative W where
+--   pure a = W $ \(_, s) -> return (a, s)
+--   mfn <*> ma = do
+--     fn <- mfn
+--     fn <$> ma
+-- 
+-- instance Monad W where
+--   (W fntoa) >>= fnmb = W $ \(config, state) -> do
+--     (a, state') <- fntoa (config, state)
+--     let W fntob = fnmb a
+--     fntob (config, state')
+-- 
+-- getWContext :: W WContext
+-- getWContext = W pure
+-- 
+-- getWConfig :: W WConfig
+-- getWConfig = ctxConfig <$> getWContext
+-- 
+-- getWState :: W WState
+-- getWState = W $ \(_, s) -> pure (s, s)
+-- 
+-- runW :: W a -> (WContext, WState) -> IO (a, WState)
+-- runW (W fn) = fn
+-- 
+-- incrementState :: W Int
+-- incrementState = W $ \(_, WState s i) -> return (i, WState s (i + 1))
+-- 
+-- wio :: IO a -> W a
+-- wio fn = W $ \(_, b) -> fn >>= \a -> return (a, b)