Fix GHC/HLint warnings. No semantic changes.

1 files changed, 53 insertions, 23 deletions

diff --git a/axis.hs b/axis.hs
index 89ba636..bd57573 100644
--- a/axis.hs
+++ b/axis.hs
@@ -2,20 +2,14 @@
 {-# LANGUAGE FlexibleContexts #-}
 import Prelude ()
 import BasePrelude
-import Data.Time.Clock
+-- import Data.Time.Clock
 import Control.Monad
 import qualified Graphics.UI.SDL as SDL
 import AlsaSeq
 import qualified Data.Set as Set
 import qualified Graphics.UI.SDL.TTF as SDL.TTF
-import Data.String
 import Graphics.UI.SDL.Keysym as SDL.Keysym
 import Graphics.UI.SDL.Primitives as SDL.Primitive
-import Data.Int (Int16)
-import qualified System.Exit as Exit
-import Data.List (elemIndex, elemIndices, filter, groupBy, length, reverse, sort)
-import GHC.Word
-import Data.Bits
 import qualified Sound.ALSA.Sequencer.Event as Event
 import qualified Graphics.UI.SDL.Utilities as SDL.Util
 import qualified Data.Map as Map
@@ -27,25 +21,34 @@ import qualified Sound.ALSA.Sequencer.Address
 
 import AlsaShutUp
 
+smartShowPitch :: Word8 -> String
 smartShowPitch = showPitch -- TODO: use flat for Eb, Bb; use unicode flat/sharp chars
 
+_USE_HEXAGONS, _LABEL_WHILE_PLAYING, _LABEL_ALL_KEYS :: Bool
 _USE_HEXAGONS = True
 _LABEL_WHILE_PLAYING = True
 _LABEL_ALL_KEYS = False
 
+_AXIS_ROWS, _AXIS_UNIQUE_COLS, _AXIS_TOPLEFT_PITCH, _AXIS_BOTTOMLEFT_PITCH, _AXIS_TOPRIGHT_PITCH  :: Word8
 _AXIS_ROWS = 7 + 4
 _AXIS_UNIQUE_COLS = 7
+
+_AXIS_COLS_REPEAT :: Integer
 _AXIS_COLS_REPEAT = 2
+
 _AXIS_TOPLEFT_PITCH = 81 + (7 * (_AXIS_ROWS - 7) `div` 2)
 _AXIS_BOTTOMLEFT_PITCH = _AXIS_TOPLEFT_PITCH - (_AXIS_ROWS * 7)
 _AXIS_TOPRIGHT_PITCH = _AXIS_TOPLEFT_PITCH + _AXIS_UNIQUE_COLS `div` 2
 
+_KEY_BORDER_COLOR, _KEY_ON_COLOR, _KB_BG_COLOR, _KEY_TEXT_COLOR :: SDL.Color
+
 --_KEY_BORDER_COLOR = (SDL.Color 0 0 255)
 _KEY_BORDER_COLOR = SDL.Color 0 0 0
 _KEY_ON_COLOR = SDL.Color 0xAA 0x00 0xFF
 _KB_BG_COLOR = SDL.Color 0 0 0
 _KEY_TEXT_COLOR = SDL.Color 128 128 0
 
+_KEY_BORDER_COLOR_PIXEL, _KB_BG_COLOR_PIXEL :: SDL.Pixel
 _KEY_BORDER_COLOR_PIXEL = colorToPixel _KEY_BORDER_COLOR
 _KB_BG_COLOR_PIXEL = colorToPixel _KB_BG_COLOR
 
@@ -69,6 +72,7 @@ http://en.wikipedia.org/wiki/Enhanced_Graphics_Adapter
 15 – bright white               (#FFFFFF) 111111  63
 -}
 
+_CGA :: [SDL.Color]
 _CGA = [  SDL.Color 0x00 0x00 0x00,        --black
           SDL.Color 0x00 0x00 0xAA,        --blue
           SDL.Color 0x00 0xAA 0x00,        --green
@@ -86,23 +90,32 @@ _CGA = [  SDL.Color 0x00 0x00 0x00,        --black
           SDL.Color 0xFF 0xFF 0x55,        --bright yellow
           SDL.Color 0xFF 0xFF 0xFF]        --bright white
 
+_CHAN_TO_COLOR :: [SDL.Color]
 _CHAN_TO_COLOR = _KEY_ON_COLOR : tail _CGA
 
+_drawHexircle :: Bool -> SDL.Surface -> Int16 -> Int16 -> Int16 -> SDL.Pixel -> IO Bool
 _drawHexircle f v x y s c =
   if _USE_HEXAGONS
   then _drawHexagonSDL f v x y s c
   else (if f then SDL.Primitive.filledCircle else SDL.Primitive.circle) v x y (s * 7 `div` 9) c
 
+drawHexircle :: SDL.Surface -> Int16 -> Int16 -> Int16 -> SDL.Pixel -> IO Bool
 drawHexircle  = _drawHexircle False
+
+drawFilledHexircle :: SDL.Surface -> Int16 -> Int16 -> Int16 -> SDL.Pixel -> IO Bool
 drawFilledHexircle = _drawHexircle True
+
+colorToPixel :: SDL.Color -> SDL.Pixel
 colorToPixel x = let (SDL.Color r g b) = x in rgbColor r g b
 
+inMajorC :: (Eq a, Num a) => a -> Bool
 inMajorC pclass = not (pclass == 1 || pclass == 3 || pclass == 6 || pclass == 8 || pclass == 10)
 
 -- TODO: color schemes with per-key {bg, border, hilightcolor, textcolor}
 -- TODO: try hilighting like in the app, where only part of the key is colored
 -- TODO: idea: for the channels, draw a dot.  offset the dot from the center of the key at an angle determined by the channel number
 
+pitchToColor :: Integral a => a -> SDL.Color
 pitchToColor p =
   case p `mod` 12 of
     2 -> SDL.Color 0xC0 0xC0 0xFF -- D
@@ -133,6 +146,7 @@ smartDrawKeys colsRepeat reallyErase beforeKeys_ nowKeys_ videoSurface font axis
         (if showLabel then Just text else Nothing)
         chans
 
+allKeysOff :: (Enum b, Integral a, Integral a1, Integral a2, Num b) => b -> Bool -> SDL.Surface -> SDL.TTF.Font -> [(a1, a2)] -> a -> IO ()
 allKeysOff colsRepeat reallyErase videoSurface font axis_key_locations axis_key_size = do
   let indices = [0 .. length axis_key_locations - 1]
       showLabel = not reallyErase && _LABEL_ALL_KEYS
@@ -157,10 +171,10 @@ allKeysOff colsRepeat reallyErase videoSurface font axis_key_locations axis_key_
 
 -- Next order of business: 
 
---drawKey :: (Integral a1, Integral a2, Integral a) => Int -> SDL.Surface -> SDL.TTF.Font -> [(a1, a2)] -> a -> SDL.Color -> t -> Maybe String -> [Int] -> IO ()
+drawKey :: (Integral a, Integral a1, Integral a2) => Int -> SDL.Surface -> SDL.TTF.Font -> [(a1, a2)] -> a -> SDL.Color -> Maybe String -> [Event.Channel] -> IO ()
 drawKey idx videoSurface font axis_key_locations axis_key_size fillColor text channels = do
   let (x, y) = axis_key_locations !! idx
-  drawFilledHexircle videoSurface (fromIntegral x) (fromIntegral y) (fromIntegral axis_key_size) (colorToPixel fillColor)
+  void $ drawFilledHexircle videoSurface (fromIntegral x) (fromIntegral y) (fromIntegral axis_key_size) (colorToPixel fillColor)
   let len = length channels
   let channels' = sort channels
   Control.Monad.when (len /= 0) $
@@ -181,12 +195,18 @@ drawKey idx videoSurface font axis_key_locations axis_key_size fillColor text ch
     (Just t) -> centerText videoSurface x y font _KEY_TEXT_COLOR fillColor t
     _ -> return ()
 
-fi = fromIntegral
+rgbColor :: Word8 -> Word8 -> Word8 -> SDL.Pixel
 rgbColor r g b = SDL.Pixel (shiftL (fi r) 24 .|. shiftL (fi g) 16 .|. shiftL (fi b) 8 .|. fi 255)
+  where
+    fi = fromIntegral
+    fi :: Word8 -> Word32
 
+chooseFontSize :: Integral a => a -> a -> a
 chooseFontSize h w = 30 * d `div` 1024 where d = min h w
 
+_SDL_DIGITS :: Set.Set SDLKey
 _SDL_DIGITS = Set.fromList [SDL.SDLK_1, SDL.SDLK_2, SDL.SDLK_3, SDL.SDLK_4, SDL.SDLK_5, SDL.SDLK_6, SDL.SDLK_7, SDL.SDLK_8, SDL.SDLK_9, SDL.SDLK_0]
+
 firstDigitDown :: Set.Set SDL.Keysym.SDLKey -> Maybe Integer
 firstDigitDown k = if Set.null digitsDown then Nothing else Just $ (-48 +) $ fromIntegral $ SDL.Util.fromEnum $ Set.findMin digitsDown
   where digitsDown = Set.intersection _SDL_DIGITS k
@@ -207,6 +227,7 @@ data Env = Env {
    _setVideoMode :: Int -> Int -> IO SDL.Surface
 }
 
+main :: IO ()
 main =
   withAlsaInit $ \h public private q publicAddr privateAddr -> do
     cmdlineAlsaConnect h public -- fail early if bad command lines
@@ -218,7 +239,7 @@ main =
           warpMouse = do
             _ <- SDL.warpMouse (fromIntegral (sWidth `div` 2)) (fromIntegral (sHeight `div` 2))
             return ()
-          setVideoMode w h = SDL.setVideoMode w h 32 [SDL.HWSurface, SDL.Resizable, SDL.DoubleBuf]
+          setVideoMode wid hei = SDL.setVideoMode wid hei 32 [SDL.HWSurface, SDL.Resizable, SDL.DoubleBuf]
       _ <- setVideoMode sWidth sHeight
 
       _ <- SDL.TTF.init
@@ -228,7 +249,7 @@ main =
       -- pixelFormat or the faked one, so fuck it. See colorToPixel let pixelFormat =
       -- SDL.surfaceGetPixelFormat videoSurface pixelFormat <- SDL.surfaceGetPixelFormat <$>
       -- SDL.createRGBSurfaceEndian [] 1 1 24
-      shutUp
+      void $ shutUp
       putStrLn "Initialized."
 
       (_, ()) <- execRWST mainLoop
@@ -236,13 +257,14 @@ main =
                           (LoopState True _AXIS_COLS_REPEAT Set.empty Set.empty (sWidth, sHeight) font)
       return ()
 
+setFont :: (MonadIO m, MonadState LoopState m) => (Int, Int) -> m ()
 setFont resolution' = do
-    font <- gets _sdlFont
     let (w, h) = resolution'
         fontSize = chooseFontSize w h
     font' <- liftIO $ SDL.TTF.openFont "LiberationMono-Bold.ttf" fontSize
     modify $ \s -> s { _sdlFont = font' }
 
+parseEvents :: RWST Env () LoopState IO (Bool, Set.Set SDLKey, MidiPitchSet, (Int, Int), Integer)
 parseEvents = do
     Env h q publicAddr setVideoMode <- ask
     LoopState _ colsRepeat midiKeysDown keysDown resolution _ <- get
@@ -264,22 +286,22 @@ mainLoop = do
     Env h q publicAddr setVideoMode <- ask
     LoopState firstLoop _ midiKeysDown keysDown _ _ <- get
 
-    (restartVideo, keysDown', midiKeysDown', resolution', colsRepeat') <- parseEvents
+    (restartVideo, keysDown', midiKeysDown', resolution, colsRepeat) <- parseEvents
 
     when restartVideo $ do
-        let (w, h) = resolution'
-        void $ liftIO $ setVideoMode w h
-        setFont resolution'
+        let (wid, hei) = resolution
+        void $ liftIO $ setVideoMode wid hei
+        setFont resolution
 
-    font' <- gets _sdlFont
+    font <- gets _sdlFont
 
     videoSurface <- liftIO SDL.getVideoSurface
     videoClipRect <- liftIO $ SDL.getClipRect videoSurface
-    let (axis_key_size, axis_key_locations) = getKeyLocations colsRepeat' videoClipRect
+    let (axis_key_size, axis_key_locations) = getKeyLocations colsRepeat videoClipRect
 
     let _ALL_PITCHES = Set.fromList $ map (\p -> (Event.Channel 1, Event.Pitch p))
                                         [_AXIS_BOTTOMLEFT_PITCH .. _AXIS_TOPRIGHT_PITCH]
-        keysOFF really = allKeysOff colsRepeat' really videoSurface font' axis_key_locations axis_key_size
+        keysOFF really = allKeysOff colsRepeat really videoSurface font axis_key_locations axis_key_size
         allKeysOFF = keysOFF False
         allKeysReallyOFF = keysOFF True
 
@@ -303,11 +325,11 @@ mainLoop = do
         --        let chord = show $ pitchList midiKeysDown'
         --        let chord = show $ map (\i->elemIndices i pitchIndex) $ pitchList midiKeysDown'
         --        textBand videoSurface videoClipRect (SDL.Rect 0 70 0 70) font chord
-        liftIO $ smartDrawKeys colsRepeat' False midiKeysDown midiKeysDown' videoSurface font' axis_key_locations axis_key_size
+        liftIO $ smartDrawKeys colsRepeat False midiKeysDown midiKeysDown' videoSurface font axis_key_locations axis_key_size
 
     when restartVideo $ do
         liftIO allKeysOFF
-        liftIO $ smartDrawKeys colsRepeat' False Set.empty midiKeysDown' videoSurface font' axis_key_locations axis_key_size
+        liftIO $ smartDrawKeys colsRepeat False Set.empty midiKeysDown' videoSurface font axis_key_locations axis_key_size
 
     when (keysDown' /= keysDown) $ do
         when (keyDown SDL.SDLK_BACKSPACE keysDown') $ liftIO allKeysOFF
@@ -331,14 +353,17 @@ mainLoop = do
     let delay = 1000 `div` framerate -- TODO: subtract delta
     liftIO $ SDL.delay delay
     unless (keyDown SDL.SDLK_ESCAPE keysDown) $ do
-        put (LoopState False colsRepeat' midiKeysDown' keysDown' resolution' font')
+        put (LoopState False colsRepeat midiKeysDown' keysDown' resolution font)
         mainLoop
 
+zipzip :: [[b]] -> [[b]]
 zipzip ls = if null (head ls) then [] else map head ls : zipzip (map tail ls)
 
+drawHexagonSDL, drawFilledHexagonSDL :: SDL.Surface -> Int16 -> Int16 -> Integer -> SDL.Pixel -> IO Bool
 drawHexagonSDL = _drawHexagonSDL False
 drawFilledHexagonSDL = _drawHexagonSDL True
 
+_drawHexagonSDL :: Integral a => Bool -> SDL.Surface -> Int16 -> Int16 -> a -> SDL.Pixel -> IO Bool
 _drawHexagonSDL filled videoSurface centerx centery radius pixel = do
   let r = fromIntegral radius
   let points = map (\(x, y) -> (centerx + x, centery + y)) $
@@ -346,6 +371,7 @@ _drawHexagonSDL filled videoSurface centerx centery radius pixel = do
                map (\i -> (r * cos(pi/3 * (i)), r * sin(pi/3 * (i)))) [0 .. 5]
   (if not filled then SDL.Primitive.polygon else SDL.Primitive.filledPolygon) videoSurface points pixel
 
+centerText :: (Integral a, Integral a1) => SDL.Surface -> a -> a1 -> SDL.TTF.Font -> SDL.Color -> t -> String -> IO ()
 centerText videoSurface x y font fgColor bgColor text = do
 --fontSurface <- SDL.TTF.renderUTF8Shaded font text (SDL.Color 0 255 0) (SDL.Color 80 80 80) -- useful for testing
 --fontSurface <- SDL.TTF.renderUTF8Shaded font text fgColor bgColor
@@ -355,12 +381,14 @@ centerText videoSurface x y font fgColor bgColor text = do
   _ <- SDL.blitSurface fontSurface (Just fontClipRect) videoSurface (Just (SDL.Rect (fromIntegral(x) - w `div` 2) (fromIntegral(y) - h `div` 2) w h))
   return ()
 
+pitchIndex :: (Enum b, Num b) => b -> [Word8]
 pitchIndex colsRepeat = concatMap (const unique) [0 .. colsRepeat - 1]
   where
     toprow = map (\i -> if i `mod` 2 == 0 then _AXIS_TOPLEFT_PITCH + i `div` 2 else _AXIS_TOPLEFT_PITCH - 3 + i `div` 2) [0 .. _AXIS_UNIQUE_COLS - 1]
     colfrom top = map ((+ top) . (* (-7))) [0 .. _AXIS_ROWS - 1]
     unique = concatMap colfrom toprow
 
+getKeyLocations :: (Integral a, Integral t, Integral t1, Integral t2) => a -> SDL.Rect -> (t, [(t1, t2)])
 getKeyLocations colsRepeat (SDL.Rect offx offy totalw totalh) =
   let (key_height, key_width, xys) = getKeyLocationsAbs colsRepeat
 
@@ -388,6 +416,7 @@ getKeyLocations colsRepeat (SDL.Rect offx offy totalw totalh) =
     in
       (floor(kw/2 * 15/16), map (\(x, y) -> (floor(scale * x + centerx + kw/2), floor(scale * y + centery + kh/2))) $ concat $ zipzip xys)
 
+getKeyLocationsAbs :: Integral a => a -> (Double, Double, [[(Double, Double)]])
 getKeyLocationsAbs colsRepeat =
   let kb_rows = fromIntegral _AXIS_ROWS :: Double
       kb_cols = fromIntegral colsRepeat * fromIntegral _AXIS_UNIQUE_COLS :: Double
@@ -415,6 +444,7 @@ getKeyLocationsAbs colsRepeat =
       (kh, kw, xys)
 
 -- clear a band the width of the videoClipRect and print the text within it, centered
+textBand :: SDL.Surface -> SDL.Rect -> SDL.Rect -> SDL.TTF.Font -> [Char] -> IO ()
 textBand videoSurface videoClipRect (SDL.Rect _ y _ h) font text = do
   let (SDL.Rect vx _ vw _) = videoClipRect
   _ <- SDL.fillRect videoSurface (Just (SDL.Rect 0 y vw h)) (SDL.Pixel 0)