wip

Author: cdepillabout

.hlint.yaml

@@ -56,8 +56,17 @@
 # Ignore some builtin hints
 # - ignore: {name: Use let}
 # - ignore: {name: Use const, within: SpecialModule} # Only within certain modules
-- ignore: {name: Use forM_}
-- ignore: {name: Use join}
+- ignore: {name: "Eta reduce"}
+- ignore: {name: "Redundant pure"}
+- ignore: {name: "Replace case with maybe"}
+- ignore: {name: "Use <$>"}
+- ignore: {name: "Use <$>"}
+- ignore: {name: "Use forM_"}
+- ignore: {name: "Use foldr"}
+- ignore: {name: "Use infix"}
+- ignore: {name: "Use join"}
+- ignore: {name: "Use uncurry"}
+
 
 
 # Define some custom infix operators

src/Termonad/App.hs

@@ -436,13 +436,13 @@ setupTermonad tmConfig app win builder = do
   newTabAction <- simpleActionNew "newtab" Nothing
   void $ onSimpleActionActivate newTabAction $ \_ -> void $ createTerm handleKeyPress mvarTMState
   actionMapAddAction app newTabAction
-  applicationSetAccelsForAction app "app.newtab" ["<Shift><Ctrl>T"]
+  applicationSetAccelsForAction app "win.newtab" ["<Shift><Ctrl>T"]
 
   nextPageAction <- simpleActionNew "nextpage" Nothing
   void $ onSimpleActionActivate nextPageAction $ \_ ->
     termNextPage mvarTMState
   actionMapAddAction app nextPageAction
-  applicationSetAccelsForAction app "app.nextpage" ["<Ctrl>Page_Down"]
+  applicationSetAccelsForAction app "win.nextpage" ["<Ctrl>Page_Down"]
 
   prevPageAction <- simpleActionNew "prevpage" Nothing
   void $ onSimpleActionActivate prevPageAction $ \_ ->

src/Termonad/Cli.hs

@@ -15,9 +15,11 @@ module Termonad.Cli where
 
 import Termonad.Prelude
 
+import Control.Applicative ((<|>), (<**>))
+import Data.Text (pack)
+import GI.Vte (CursorBlinkMode)
 import Options.Applicative (fullDesc, info, helper, progDesc, ParserInfo, execParser, Parser, Mod, OptionFields, option, str, value, short, long, metavar, help, ReadM, maybeReader, auto, flag')
 import Termonad.Types (ConfigOptions (..), Option (Set, Unset), ShowScrollbar, FontSize (..), ShowTabBar, showScrollbarFromString, showTabBarFromString, cursorBlinkModeFromString, FontConfig (..))
-import GI.Vte (CursorBlinkMode)
 
 
 -- | A data type that contains arguments from the command line.

src/Termonad/Config/Colour.hs

@@ -661,6 +661,12 @@ showColourCube matrix =
     showCol :: AlphaColour Double -> String -> String
     showCol col str = sRGB32show col <> str
 
+    -- A version of head that gives a better error message.
+    headEx :: forall b. [b] -> b
+    headEx = \case
+      [] -> error "showColourCube: error in headEx, passed empty list, this is likely a logic error"
+      (h : _) -> h
+
 -- | A List of a grey scale.  Default value for 'FullPalette'.
 --
 -- >>> fmap sRGB32show defaultGreyscale

src/Termonad/Gtk.hs

@@ -19,6 +19,7 @@ import Termonad.Prelude
 
 import Control.Monad.Fail (MonadFail, fail)
 import Data.GI.Base (ManagedPtr, withManagedPtr)
+import Data.Text (unpack)
 import GHC.Stack (HasCallStack)
 import GI.Gdk
   ( GObject
@@ -42,15 +43,11 @@ objFromBuildUnsafe ::
 objFromBuildUnsafe builder name constructor = do
   maybePlainObj <- builderGetObject builder name
   case maybePlainObj of
-    Nothing -> error $ "Couldn't get " <> unpack name <> " from builder!"
+    Nothing -> error $ unpack $ "Couldn't get " <> name <> " from builder!"
     Just plainObj -> do
       maybeNewObj <- castTo constructor plainObj
       case maybeNewObj of
-        Nothing ->
-          error $
-            "Got " <>
-            unpack name <>
-            " from builder, but couldn't convert to object!"
+        Nothing -> error $ unpack $ "Got " <> name <> " from builder, but couldn't convert to object!"
         Just obj -> pure obj
 
 -- | Unsafely creates a new 'Application'.  This calls 'fail' if it cannot

src/Termonad/IdMap.hs

@@ -0,0 +1,17 @@
+-- | Module    : Termonad.IdMap
+-- Description : A Map that keeps track of the ID of values
+-- Copyright   : (c) Dennis Gosnell, 2023
+-- License     : BSD3
+-- Stability   : experimental
+-- Portability : POSIX
+
+module Termonad.IdMap
+  ( IdMapKey
+  , IdMap
+  , emptyIdMap
+  , singletonIdMap
+  , insertIdMap
+  , lookupIdMap
+  ) where
+
+import Termonad.IdMap.Internal

src/Termonad/IdMap/Internal.hs

@@ -0,0 +1,77 @@
+-- | Module    : Termonad.IdMap
+-- Description : A Map that keeps track of the ID of values
+-- Copyright   : (c) Dennis Gosnell, 2023
+-- License     : BSD3
+-- Stability   : experimental
+-- Portability : POSIX
+
+module Termonad.IdMap.Internal where
+
+import Termonad.Prelude
+
+import Control.Lens (FoldableWithIndex, ifoldMap, Index, IxValue, Traversal', Ixed (ix))
+import qualified Data.Foldable as Foldable
+import Data.IntMap.Strict (IntMap)
+import qualified Data.IntMap.Strict as IntMap
+
+-- TODO: Write tests for this!
+
+newtype IdMapKey = IdMapKey { unIdMapKey :: Int }
+  deriving stock Show
+
+data IdMap a = IdMap
+  { idMap :: !(IntMap a)
+  , nextId :: !Int
+  }
+  deriving stock Show
+
+instance Functor IdMap where
+  fmap f IdMap{idMap, nextId} = IdMap { idMap = fmap f idMap, nextId }
+
+instance Foldable IdMap where
+  foldMap f m = Foldable.foldMap f $ idMap m
+
+instance FoldableWithIndex Int IdMap where
+  ifoldMap f m = ifoldMap f $ idMap m
+
+instance Traversable IdMap where
+  traverse f IdMap{idMap, nextId} =
+    fmap (\m -> IdMap { idMap = m, nextId }) (traverse f idMap)
+
+type instance Index (IdMap a) = IdMapKey
+type instance IxValue (IdMap a) = a
+
+instance Ixed (IdMap a) where
+  ix :: IdMapKey -> Traversal' (IdMap a) a
+  ix (IdMapKey i) f IdMap{idMap, nextId} =
+    case IntMap.lookup i idMap of
+      Just v -> fmap update (f v) -- f v <&> \v' -> IntMap.insert k v' m
+      Nothing -> pure IdMap{idMap, nextId}
+    where
+      update :: a -> IdMap a
+      update v' =
+        IdMap
+          { idMap = IntMap.adjust (const v') i idMap
+          , nextId
+          }
+
+initialId :: Int
+initialId = 0
+
+succId :: Int -> Int
+succId i = i + 1
+
+emptyIdMap :: IdMap a
+emptyIdMap = IdMap { idMap = mempty, nextId = 0 }
+
+insertIdMap :: a -> IdMap a -> (IdMapKey, IdMap a)
+insertIdMap a IdMap {idMap, nextId} =
+  let newMap = IntMap.insert nextId a idMap
+      newNextId = nextId + 1
+  in (IdMapKey nextId, IdMap { idMap = newMap, nextId = newNextId })
+
+singletonIdMap :: a -> (IdMapKey, IdMap a)
+singletonIdMap a = insertIdMap a emptyIdMap
+
+lookupIdMap :: IdMapKey -> IdMap a -> Maybe a
+lookupIdMap (IdMapKey k) IdMap {idMap} = IntMap.lookup k idMap

src/Termonad/Keys.hs

@@ -4,6 +4,10 @@ module Termonad.Keys where
 import Termonad.Prelude
 
 import Control.Lens (imap)
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+import Data.Set (Set)
+import qualified Data.Set as Set
 import GI.Gdk
   ( EventKey
   , pattern KEY_0
@@ -27,7 +31,7 @@ import GI.Gdk
   )
 
 import Termonad.Term (altNumSwitchTerm)
-import Termonad.Types (TMState)
+import Termonad.Types (TMState, TMWindowId)
 
 
 showKeys :: EventKey -> IO Bool
@@ -41,28 +45,29 @@ showKeys eventKey = do
   keycode <- getEventKeyHardwareKeycode eventKey
 
   putStrLn "key press event:"
-  putStrLn $ "  type = " <> tshow eventType
-  putStrLn $ "  str = " <> tshow maybeString
-  putStrLn $ "  mods = " <> tshow modifiers
-  putStrLn $ "  isMod = " <> tshow isMod
-  putStrLn $ "  len = " <> tshow len
-  putStrLn $ "  keyval = " <> tshow keyval
-  putStrLn $ "  keycode = " <> tshow keycode
+  putStrLn $ "  type = " <> show eventType
+  putStrLn $ "  str = " <> show maybeString
+  putStrLn $ "  mods = " <> show modifiers
+  putStrLn $ "  isMod = " <> show isMod
+  putStrLn $ "  len = " <> show len
+  putStrLn $ "  keyval = " <> show keyval
+  putStrLn $ "  keycode = " <> show keycode
   putStrLn ""
 
   pure True
 
 data Key = Key
-  { keyVal :: Word32
-  , keyMods :: Set ModifierType
+  { keyVal :: !Word32
+  , keyMods :: !(Set ModifierType)
   } deriving (Eq, Ord, Show)
 
 toKey :: Word32 -> Set ModifierType -> Key
 toKey = Key
 
-keyMap :: Map Key (TMState -> IO Bool)
+keyMap :: Map Key (TMState -> TMWindowId -> IO Bool)
 keyMap =
-  let numKeys =
+  let numKeys :: [Word32]
+      numKeys =
         [ KEY_1
         , KEY_2
         , KEY_3
@@ -74,21 +79,23 @@ keyMap =
         , KEY_9
         , KEY_0
         ]
+      altNumKeys :: [(Key, TMState -> TMWindowId -> IO Bool)]
       altNumKeys =
         imap
           (\i k ->
              (toKey k [ModifierTypeMod1Mask], stopProp (altNumSwitchTerm i))
           )
           numKeys
   in
-  mapFromList altNumKeys
+  Map.fromList altNumKeys
 
-stopProp :: (TMState -> IO a) -> TMState -> IO Bool
-stopProp callback terState = callback terState $> True
+stopProp :: (TMState -> TMWindowId -> IO a) -> TMState -> TMWindowId -> IO Bool
+stopProp callback terState tmWinId = callback terState tmWinId $> True
 
 removeStrangeModifiers :: Key -> Key
 removeStrangeModifiers Key{keyVal, keyMods} =
-  let reservedModifiers =
+  let reservedModifiers :: Set ModifierType
+      reservedModifiers =
         [ ModifierTypeModifierReserved13Mask
         , ModifierTypeModifierReserved14Mask
         , ModifierTypeModifierReserved15Mask
@@ -104,17 +111,17 @@ removeStrangeModifiers Key{keyVal, keyMods} =
         , ModifierTypeModifierReserved25Mask
         , ModifierTypeModifierReserved29Mask
         ]
-  in Key keyVal (difference keyMods reservedModifiers)
+  in Key keyVal (Set.difference keyMods reservedModifiers)
 
 
-handleKeyPress :: TMState -> EventKey -> IO Bool
-handleKeyPress terState eventKey = do
+handleKeyPress :: TMState -> TMWindowId -> EventKey -> IO Bool
+handleKeyPress terState tmWindowId eventKey = do
   -- void $ showKeys eventKey
   keyval <- getEventKeyKeyval eventKey
   modifiers <- getEventKeyState eventKey
-  let oldKey = toKey keyval (setFromList modifiers)
+  let oldKey = toKey keyval (Set.fromList modifiers)
       newKey = removeStrangeModifiers oldKey
-      maybeAction = lookup newKey keyMap
+      maybeAction = Map.lookup newKey keyMap
   case maybeAction of
-    Just action -> action terState
+    Just action -> action terState tmWindowId
     Nothing -> pure False

src/Termonad/Lenses.hs

@@ -28,13 +28,18 @@ $(makeLensesFor
     ''TMNotebook
  )
 
+$(makeLensesFor
+    [ ("tmWindowAppWin", "lensTMWindowAppWin")
+    , ("tmWindowNotebook", "lensTMWindowNotebook")
+    ]
+    ''TMWindow
+ )
+
 $(makeLensesFor
     [ ("tmStateApp", "lensTMStateApp")
-    , ("tmStateAppWin", "lensTMStateAppWin")
-    , ("tmStateNotebook", "lensTMStateNotebook")
     , ("tmStateFontDesc", "lensTMStateFontDesc")
     , ("tmStateConfig", "lensTMStateConfig")
-    , ("tmStateUserReqExit", "lensTMStateUserReqExit")
+    , ("tmStateWindows", "lensTMStateWindows")
     ]
     ''TMState'
  )

src/Termonad/PreferencesFile.hs

@@ -9,17 +9,18 @@ import Data.Aeson (Result(..), fromJSON)
 #if MIN_VERSION_aeson(2, 0, 0)
 import qualified Data.Aeson.KeyMap as KeyMap
 #endif
+import qualified Data.ByteString as ByteString
 import qualified Data.HashMap.Strict as HashMap
+import Data.Text (pack)
 import Data.Yaml (ParseException, ToJSON (toJSON), decodeFileEither, encode, prettyPrintParseException)
 import Data.Yaml.Aeson (Value(..))
-
 import System.Directory
   ( XdgDirectory(XdgConfig)
   , createDirectoryIfMissing
   , doesFileExist
   , getXdgDirectory
   )
-
+import System.FilePath ((</>))
 import Termonad.Types
   ( ConfigOptions
   , TMConfig(TMConfig, hooks, options)
@@ -184,7 +185,7 @@ writePreferencesFile confFile options = do
         "# The settings in this file will be ignored if you have a\n" <>
         "# termonad.hs file in this same directory.\n\n" <>
         yaml
-  writeFile confFile yamlWithComment
+  ByteString.writeFile confFile yamlWithComment
 
 -- | Save the configuration to the preferences file
 -- @~\/.config\/termonad\/termonad.yaml@

src/Termonad/Prelude.hs

@@ -1,17 +1,40 @@
+
+-- | This is a basic prelude-like module that adds a bunch of common datatypes
+-- and functions to the 'Prelude'.
+
 module Termonad.Prelude
   ( module X
   , hPutStrLn
   , whenJust
+  , stderr
+  , tshow
   ) where
 
+import Control.Concurrent.MVar as X (MVar, modifyMVar, newMVar, readMVar, withMVar)
+import Control.Exception as X (IOException, try)
 import Control.Lens as X ((&))
+import Control.Monad as X (unless, void, when)
+import Control.Monad.IO.Class as X
 import Control.Monad.Trans.Maybe as X (MaybeT(MaybeT), runMaybeT)
-import ClassyPrelude as X
+import Data.Function as X (on)
+import Data.Functor as X (($>))
+import Data.Int as X (Int32)
+import Data.Maybe as X (catMaybes, fromMaybe)
 import Data.Proxy as X
+import Data.String as X (IsString)
+import Data.Text as X (Text)
+import Data.Text (pack)
 import qualified Data.Text.IO as TextIO
+import Data.Word as X (Word8, Word32)
+import GHC.Generics as X (Generic)
+import Prelude as X
+import System.IO (Handle, stderr)
 
 whenJust :: Monoid m => Maybe a -> (a -> m) -> m
 whenJust = flip foldMap
 
 hPutStrLn :: MonadIO m => Handle -> Text -> m ()
 hPutStrLn hndl = liftIO . TextIO.hPutStrLn hndl
+
+tshow :: Show a => a -> Text
+tshow = pack . show