Optimization work. (#163)

Author: galenhuntington

Decoder.hs

@@ -21,7 +21,7 @@ mp3Tool = "mpg123"
 ------------------------------------------------------------------------
 -- Send commands to mpg123
 
-data Cmd = Load ByteString | Jump (Fixed E2) | Pause | Quit
+data Cmd = Load !ByteString | Jump !(Fixed E2) | Pause | Quit
 
 cmdToBS :: Cmd -> ByteString
 cmdToBS (Load f) = "L " <> f
@@ -32,10 +32,7 @@ cmdToBS Quit     = "Q"
 ------------------------------------------------------------------------
 -- Receive messages from mpg123
 
-data Msg = I                !Id3
-         | S {-# UNPACK #-} !ByteString
-         | F {-# UNPACK #-} !Frame
-         | P                !Status
+data Msg = I !Id3 | S !ByteString | F !Frame | P !Status
     deriving stock (Eq, Show)
 
 -- ID3 info

State.hs

@@ -28,7 +28,7 @@ data HState = HState
     , folders         :: !DirArray
     , bootTime        :: !TimeSpec
     , configPath      :: !(Maybe FilePath)     -- style.conf override (CLI)
-    , histSize        :: Int
+    , histSize        :: !Int
     -- These can
     , current         :: !Int                  -- currently playing mp3
     , cursor          :: !Int                  -- mp3 under the cursor
@@ -41,7 +41,7 @@ data HState = HState
     , minibuffer      :: !Line                 -- contents of minibuffer
     , modal           :: !(Maybe Modal)        -- modal visible
     , miniFocused     :: !Bool                 -- is the mini buffer focused?
-    , folderCol       :: Float                 -- portion of width for folders
+    , folderCol       :: !Float                -- portion of width for folders
     , mode            :: !Mode
     , uptime          :: !ByteString
     , searchFw        :: !Bool                 -- active search direction

Style.hs

@@ -2,9 +2,7 @@
 -- Copyright (c) 2019-2022, 2026 Galen Huntington
 -- SPDX-License-Identifier: GPL-2.0-or-later
 
---
 -- | Color manipulation
---
 
 module Style where
 
@@ -48,17 +46,15 @@ data Style = Style !Color !Color
     deriving stock (Eq,Ord)
 
 -- | A styled UTF-8 ByteString segment.
-data Segment = Seg  {-# UNPACK #-} !Style {-# UNPACK #-} !ByteString
+data Segment = Seg !Style {-# UNPACK #-} !ByteString
 
 -- | A line of segments.
 type Line = [Segment]
 
 ------------------------------------------------------------------------
---
 -- | Named colors for the config file and the built-in styles.  The
 -- \"dark\" name of each pair is the normal-intensity hue; the plain name
 -- is its bright variant (so @red@ is bright, @darkred@ is normal).
---
 stringToColor :: String -> Maybe Color
 stringToColor s = case map toLower s of
     "black"         -> Just $ Color Normal Black
@@ -82,31 +78,21 @@ stringToColor s = case map toLower s of
     _               -> Nothing
 
 ------------------------------------------------------------------------
---
 -- | Set some colours, perform an action, and then reset the colours
---
 withStyle :: Style -> IO () -> IO ()
 withStyle sty fn = uiAttr sty >>= setAttribute >> fn >> reset
 {-# INLINE withStyle #-}
 
---
 -- | manipulate the current attributes of the standard screen
 -- Only set attr if it's different to the current one?
---
 setAttribute :: (Curses.Attr, Curses.Pair) -> IO ()
 setAttribute = uncurry Curses.attrSet
-{-# INLINE setAttribute #-}
 
---
 -- | Reset the screen to normal values
---
 reset :: IO ()
 reset = setAttribute (Curses.attr0, Curses.Pair 0)
-{-# INLINE reset #-}
 
---
 -- | And turn on the colours
---
 initcolours :: UIStyle -> IO ()
 initcolours sty = do
     let ls  = [sty.modals, sty.warnings, sty.window,
@@ -119,7 +105,6 @@ initcolours sty = do
     uiAttr sty.window >>= \(_,p) -> Curses.bkgrndSet nullA p
 
 ------------------------------------------------------------------------
---
 -- | Set up the ui attributes, given a ui style record
 --
 -- Returns an association list of pairs for foreground and bg colors,
@@ -138,24 +123,20 @@ initUiColors stys = do
         pure (sty, (a `Curses.attrPlus` b, Curses.Pair p))
 
 ------------------------------------------------------------------------
---
 -- | Getting from nice abstract colours to ncurses-settable values
 
 -- 20% of allocss occur here! But there's only 3 or 4 colours :/
 -- Every call to uiAttr
---
 uiAttr :: Style -> IO (Curses.Attr, Curses.Pair)
 uiAttr sty = do
     m <- readIORef pairMap
     pure $ lookupPair m sty
-{-# INLINE uiAttr #-}
 
 -- | Given a curses color pair, find the Curses.Pair (i.e. the pair
 -- curses thinks these colors map to) from the state
 lookupPair :: PairMap -> Style -> (Curses.Attr, Curses.Pair)
 lookupPair m s =
     fromMaybe (Curses.attr0, Curses.Pair 0) (M.lookup s m)
-{-# INLINE lookupPair #-}
 
 -- | Keep a map of nice style defs to underlying curses pairs, created at init time
 type PairMap = M.Map Style (Curses.Attr, Curses.Pair)
@@ -166,22 +147,17 @@ pairMap = unsafePerformIO $ newIORef M.empty
 {-# NOINLINE pairMap #-}
 
 ------------------------------------------------------------------------
---
 -- Basic (ncurses) colours.
---
+
 defaultColor :: Curses.Color
 defaultColor = fromJust $ Curses.color "default"
 
---
 -- Combine attribute with another attribute
---
 setBoldA, setReverseA ::  Curses.Attr -> Curses.Attr
 setBoldA     = flip Curses.setBold    True
 setReverseA  = flip Curses.setReverse True
 
---
 -- | Some attribute constants
---
 boldA, nullA, reverseA :: Curses.Attr
 nullA       = Curses.attr0
 boldA       = setBoldA      nullA
@@ -194,7 +170,6 @@ newtype CColor = CColor (Curses.Attr, Curses.Color)
 -- | Map an abstract 'Style' to its ncurses foreground/background pair.
 style2curses :: Style -> (CColor, CColor)
 style2curses (Style fg bg) = (fgCursCol fg, bgCursCol bg)
-{-# INLINE style2curses #-}
 
 -- | The ncurses color for each ANSI hue.
 hueColor :: Hue -> Curses.Color
@@ -226,7 +201,6 @@ plainSeg :: ByteString -> Segment
 plainSeg = Seg defaultSty
 
 ------------------------------------------------------------------------
---
 -- Support for runtime configuration
 -- We choose a simple strategy, read/showable record types, with strings
 -- to represent colors
@@ -260,7 +234,6 @@ buildStyle bs = UIStyle {
        , blockcursor = f bs.hmp3_blockcursor
        , progress    = f bs.hmp3_progress
     }
-
     where 
         f (x,y) = Style (g x) (g y)
         g x     = fromMaybe Default $ stringToColor x

UI.hs

@@ -140,7 +140,7 @@ refreshClock = runDraw $ redrawJustClock <> Draw Curses.refresh
 
 ------------------------------------------------------------------------
 
-data DrawData = DD { drawWidth :: Int, drawState :: HState }
+data DrawData = DD { drawWidth :: !Int, drawState :: !HState }
 
 ------------------------------------------------------------------------
 
@@ -339,7 +339,6 @@ slice :: Int -> Int -> Array Int e -> [e]
 slice i j arr = 
     let (a, b) = bounds arr
     in [unsafeAt arr n | n <- [max a i .. min b j]]
-{-# INLINE slice #-}
 
 ------------------------------------------------------------------------
 

hmp3-ng.cabal

@@ -39,7 +39,6 @@ common opts
   ghc-options:
     -Wall
     -Wprepositive-qualified-module
-    -funbox-strict-fields
 
 library
   import: opts

test/TextSpec.hs

@@ -3,7 +3,6 @@ module TextSpec (tests) where
 import Test.Tasty
 import Test.Tasty.HUnit
 
-import Base ((<&>))
 import Text
 
 -- These tests depend on wcwidth's behavior under a UTF-8 locale and on a
@@ -91,5 +90,5 @@ tests = testGroup "Text"
 
 
 m :: Maybe Bool -> String -> String -> String -> TestTree
-m b tag pat str = testCase tag $ (matches (u pat) <&> ($ u str)) @?= b
+m b tag pat str = testCase tag $ ($ u str) <$> matches (u pat) @?= b