Fix mouse scrolling in menus

src/Dodge/Render/List.hs

@@ -35,13 +35,11 @@ makeSelectionListPictures sl = concatMap _siPictures $ _slItems sl
 drawSelectionCursor :: ListDisplayParams -> Configuration -> SelectionList a -> Picture
 drawSelectionCursor ldps cfig sl = fromMaybe mempty $ do
     i <- _slSelPos sl
-    --selit <- filter _siIsSelectable lis !? i
     selit <- lis !? i
     f <- case _ldpCursorType ldps of
         BorderCursor cps -> Just $ listCursorChooseBorderScale (_ldpVerticalGap ldps) (_ldpScale ldps) cps
         NoCursor -> Nothing
-    --let j = sum . map _siHeight $ takeWhileArb (<= i) (\x itsel -> x + if _siIsSelectable itsel then 1 else 0) 0 lis
-    let j = sum . map _siHeight $ takeWhileArb (<= i) (\x itsel -> x + 1) 0 lis
+    let j = sum . map _siHeight $ take i lis
         col = _siColor selit
     return $ f (_ldpPosX ldps + (9 * fromIntegral (_siOffX selit))) (_ldpPosY ldps) cfig j col wdth (_siHeight selit)
   where

src/Dodge/Update.hs

@@ -100,7 +100,6 @@ mouseClickOptionsList screen u = fromMaybe u $ do
     Just False -> fromMaybe u $ do
         i <- sl ^. slSelPos
         f <- sl ^? slItems . ix i . siPayload
-        --f <- sl ^? slItems . ix i . siPayload
         return $ f u
     _ -> u
 
@@ -151,7 +150,6 @@ optionScreenUpdate screen mop _ ldps sl u =
     . mouseOverSelectionList ldps sl
     . menuWheelEvents
     . over (uvScreenLayers . _head) (setSelectionListRestriction' cfig)
---    $ over (uvScreenLayers . _head) setShownSelectionItems
     $ u
   where
     cfig = u ^. uvConfig
@@ -293,12 +291,30 @@ functionalUpdate w =
         . over uvWorld updateWheelEvents
         $ over uvWorld updatePastWorlds w
 
+--menuWheelEvents :: Universe -> Universe
+--menuWheelEvents u = u & uvScreenLayers . _head . scSelectionList . slSelPos . _Just %~ (\y' -> (y' - y) `mod` ymax)
+--  where
+--    ymax = max 1 $ maybe 1 length (u ^? uvScreenLayers . _head . scSelectionList . slItems)
+--    y = u ^. uvWorld . input . scrollAmount
+
 menuWheelEvents :: Universe -> Universe
-menuWheelEvents u = u & uvScreenLayers . _head . scSelectionList . slSelPos . _Just %~ (\y' -> (y' - y) `mod` ymax)
+menuWheelEvents u = foldr ($) u (replicate (abs y) (menuWheelStep (signum y)))
   where
-    ymax = max 1 $ maybe 1 length (u ^? uvScreenLayers . _head . scSelectionList . slItems)
     y = u ^. uvWorld . input . scrollAmount
 
+-- you probably want i to be 1 or -1
+menuWheelStep :: Int -> Universe -> Universe
+menuWheelStep i u = fromMaybe u $ do
+    sl <- u ^? uvScreenLayers . _head . scSelectionList
+    selpos <- sl ^? slSelPos . _Just 
+    ymax <- fmap length (sl ^? slItems)
+    let newpos = (selpos - i) `mod` ymax
+    itm <- sl ^? slItems . ix newpos
+    let newu = u & uvScreenLayers . _head . scSelectionList . slSelPos . _Just %~ const newpos
+    if _siIsSelectable itm
+        then Just newu 
+        else Just $ menuWheelStep i newu
+
 updateWheelEvents :: World -> World
 updateWheelEvents w = foldr ($) w (replicate (abs y) (updateWheelEvent (signum y)))
   where