Fix some warnings on GHC 9.6.3

src/Foreign/JavaScript.hs

@@ -31,9 +31,6 @@ module Foreign.JavaScript (
     debug, timestamp,
     ) where
 
-import           Control.Concurrent.STM       as STM
-import           Control.Monad                           (unless)
-import qualified Data.Aeson                   as JSON
 import           Foreign.JavaScript.CallBuffer
 import           Foreign.JavaScript.EventLoop
 import           Foreign.JavaScript.Marshal
@@ -49,12 +46,12 @@ serve
     :: Config               -- ^ Configuration options.
     -> (Window -> IO ())    -- ^ Initialization whenever a client connects.
     -> IO ()
-serve config init = httpComm config $ eventLoop $ \w -> do
+serve config initialize = httpComm config $ eventLoop $ \w -> do
     setCallBufferMode w (jsCallBufferMode config)
     runFunction w $
         ffi "connection.setReloadOnDisconnect(%1)" $ jsWindowReloadOnDisconnect config
     flushCallBuffer w   -- make sure that all `runEval` commands are executed
-    init w
+    initialize w
     flushCallBuffer w   -- make sure that all `runEval` commands are executed
 
 {-----------------------------------------------------------------------------

src/Foreign/JavaScript/CallBuffer.hs

@@ -17,7 +17,7 @@ setCallBufferMode w new =
 
 -- | Get the call buffering mode for the given browser window.
 getCallBufferMode :: Window -> IO CallBufferMode
-getCallBufferMode w@Window{..} = atomically $ readTVar wCallBufferMode
+getCallBufferMode Window{..} = atomically $ readTVar wCallBufferMode
 
 -- | Flush the call buffer,
 -- i.e. send all outstanding JavaScript to the client in one single message.
@@ -26,7 +26,7 @@ flushCallBuffer w = flushCallBufferWithAtomic w $ return ()
 
 -- | Flush the call buffer, and atomically perform an additional action
 flushCallBufferWithAtomic :: Window -> STM a -> IO a
-flushCallBufferWithAtomic w@Window{..} action = do
+flushCallBufferWithAtomic Window{..} action = do
     -- by taking the call buffer, we ensure that no further code
     -- is added to the buffer while we execute the current buffer's code.
     code' <- atomically $ takeTMVar wCallBuffer
@@ -39,7 +39,7 @@ flushCallBufferWithAtomic w@Window{..} action = do
 -- | Schedule a piece of JavaScript code to be run with `runEval`,
 -- depending on the buffering mode
 bufferRunEval :: Window -> String -> IO ()
-bufferRunEval w@Window{..} code = do
+bufferRunEval Window{..} code = do
     action <- atomically $ do
         mode <- readTVar wCallBufferMode
         case mode of
@@ -50,5 +50,5 @@ bufferRunEval w@Window{..} code = do
                 putTMVar wCallBuffer (msg . (\s -> ";" ++ code ++ s))
                 return Nothing
     case action of
-        Nothing   -> return ()
-        Just code -> runEval code
+        Nothing    -> return ()
+        Just code1 -> runEval code1

src/Foreign/JavaScript/EventLoop.hs

@@ -6,7 +6,6 @@ module Foreign.JavaScript.EventLoop (
     newHandler, fromJSStablePtr, newJSObjectFromCoupon
     ) where
 
-import           Control.Applicative
 import           Control.Concurrent
 import           Control.Concurrent.Async
 import           Control.Concurrent.STM   as STM
@@ -15,10 +14,7 @@ import           Control.Exception        as E
 import           Control.Monad
 import qualified Data.Aeson               as JSON
 import qualified Data.ByteString.Char8    as BS
-import           Data.IORef
-import qualified Data.Map                 as Map
 import qualified Data.Text                as T
-import qualified System.Mem
 
 import Foreign.RemotePtr             as Foreign
 import Foreign.JavaScript.CallBuffer
@@ -35,19 +31,20 @@ rebug = return ()
     Event Loop
 ------------------------------------------------------------------------------}
 -- | Handle a single event
-handleEvent w@(Window{..}) (name, args) = do
+handleEvent :: Window -> (Coupon, JSON.Value) -> IO ()
+handleEvent Window{..} (name, args) = do
     mhandler <- Foreign.lookup name wEventHandlers
     case mhandler of
         Nothing -> return ()
-        Just f  -> withRemotePtr f (\_ f -> f args)
+        Just f  -> withRemotePtr f (\_ g -> g args)
 
 
 type Result = Either String JSON.Value
 
 -- | Event loop for a browser window.
 -- Supports concurrent invocations of `runEval` and `callEval`.
 eventLoop :: (Window -> IO void) -> EventLoop
-eventLoop init server info comm = void $ do
+eventLoop initialize server info comm = void $ do
     -- To support concurrent FFI calls, we need three threads.
     -- A fourth thread supports 
     --
@@ -112,12 +109,12 @@ eventLoop init server info comm = void $ do
 
     -- Send FFI calls to client and collect results
     let handleCalls = forever $ do
-            ref <- atomically $ do
-                (ref, msg) <- readTQueue calls
+            mref <- atomically $ do
+                (mref, msg) <- readTQueue calls
                 writeServer comm msg
-                return ref
+                return mref
             atomically $
-                case ref of
+                case mref of
                     Just ref -> do
                         result <- readTQueue results
                         putTMVar ref result
@@ -155,7 +152,7 @@ eventLoop init server info comm = void $ do
         withAsync multiplexer $ \_ ->
         withAsync handleCalls $ \_ ->
         withAsync (flushCallBufferPeriodically w) $ \_ ->
-        E.finally (init w >> handleEvents) $ do
+        E.finally (initialize w >> handleEvents) $ do
             putStrLn "Foreign.JavaScript: Browser window disconnected."
             -- close communication channel if still necessary
             commClose comm
@@ -175,7 +172,7 @@ flushCallBufferPeriodically w =
 ------------------------------------------------------------------------------}
 -- | Turn a Haskell function into an event handler.
 newHandler :: Window -> ([JSON.Value] -> IO ()) -> IO HsEvent
-newHandler w@(Window{..}) handler = do
+newHandler Window{..} handler = do
     coupon <- newCoupon wEventHandlers
     newRemotePtr coupon (handler . parseArgs) wEventHandlers
     where

src/Foreign/JavaScript/Include.hs

@@ -8,8 +8,8 @@ import           System.IO
 
 include :: FilePath -> Q Exp
 include path = do
-    path <- makeRelativeToProject path
-    LitE . StringL <$> runIO (readFileUTF8 path)
+    relativePath <- makeRelativeToProject path
+    LitE . StringL <$> runIO (readFileUTF8 relativePath)
 
 readFileUTF8 :: FilePath -> IO String
 readFileUTF8 path = do

src/Foreign/JavaScript/Marshal.hs

@@ -19,7 +19,6 @@ import qualified Data.Aeson.Encode      as JSON   (encodeToTextBuilder)
 #else
 import qualified Data.Aeson.Text        as JSON   (encodeToTextBuilder)
 #endif
-import qualified Data.Aeson.Types       as JSON
 import           Data.Functor                     ((<$>))
 import           Data.List                        (intercalate)
 import qualified Data.Text              as T
@@ -48,6 +47,7 @@ class ToJS a where
         ys <- mapM render xs
         jsCode $ "[" ++ intercalate "," (map unJSCode ys) ++ "]"
 
+jsCode :: String -> IO JSCode
 jsCode = return . JSCode
 
 instance ToJS Float      where render   = render . JSON.toJSON

src/Foreign/JavaScript/Server.hs

@@ -15,17 +15,16 @@ import           Data.ByteString                    (ByteString)
 import qualified Data.ByteString.Char8      as BS
 import qualified Data.ByteString.Lazy.Char8 as LBS
 import qualified Data.Map                   as M
-import           Data.Text
+import           Data.Text                          (Text)
 import qualified Safe                       as Safe
 import           System.Environment
 import           System.FilePath
 
 -- import web libraries
-import           Data.Aeson                             ((.=))
 import qualified Data.Aeson                    as JSON
 import qualified Network.WebSockets            as WS
 import qualified Network.WebSockets.Snap       as WS
-import           Snap.Core                     as Snap
+import           Snap.Core                     as Snap hiding (path, dir)
 import qualified Snap.Http.Server              as Snap
 import           Snap.Util.FileServe
 
@@ -114,15 +113,15 @@ communicationFromWebSocket request = do
     let commClose = atomically $ STM.writeTVar commOpen False
 
     -- read/write data until an exception occurs or the channel is no longer open
-    forkFinally (sendData `race_` readData `race_` sentry) $ \_ -> void $ do
+    _ <- forkFinally (sendData `race_` readData `race_` sentry) $ \_ -> void $ do
         -- close the communication channel explicitly if that didn't happen yet
         commClose
 
         -- attempt to close websocket if still necessary/possible
         -- ignore any exceptions that may happen if it's already closed
-        let all :: E.SomeException -> Maybe ()
-            all _ = Just ()
-        E.tryJust all $ WS.sendClose connection $ LBS.pack "close"
+        let allExceptions :: E.SomeException -> Maybe ()
+            allExceptions _ = Just ()
+        E.tryJust allExceptions $ WS.sendClose connection $ LBS.pack "close"
 
     return $ Comm {..}
 
@@ -155,6 +154,7 @@ routeResources server customHTML staticDir =
             Nothing  -> logError "Foreign.JavaScript: Cannot use jsCustomHTML file without jsStatic"
         Nothing   -> writeTextMime defaultHtmlFile "text/html"
 
+writeTextMime :: MonadSnap m => Text -> ByteString -> m ()
 writeTextMime text mime = do
     modifyResponse (setHeader "Content-type" mime)
     writeText text

src/Foreign/RemotePtr.hs

@@ -17,15 +17,12 @@ module Foreign.RemotePtr (
 
 import Prelude hiding (lookup)
 import Control.Monad
-import           Control.Concurrent
 import qualified Data.Text             as T
 import qualified Data.HashMap.Strict   as Map
 import Data.Functor
 import Data.IORef
 
-import           System.IO.Unsafe         (unsafePerformIO)
 import           System.Mem.Weak          hiding (addFinalizer)
-import qualified System.Mem.Weak  as Weak
 
 import qualified GHC.Base  as GHC
 import qualified GHC.Weak  as GHC
@@ -42,14 +39,14 @@ atomicModifyIORef' = atomicModifyIORef
 mkWeakIORefValue :: IORef a -> value -> IO () -> IO (Weak value)
 #if CABAL
 #if MIN_VERSION_base(4,9,0)
-mkWeakIORefValue r@(GHC.IORef (GHC.STRef r#)) v (GHC.IO f) = GHC.IO $ \s ->
+mkWeakIORefValue (GHC.IORef (GHC.STRef r#)) v (GHC.IO f) = GHC.IO $ \s ->
   case GHC.mkWeak# r# v f s of (# s1, w #) -> (# s1, GHC.Weak w #)
 #else
-mkWeakIORefValue r@(GHC.IORef (GHC.STRef r#)) v f = GHC.IO $ \s ->
+mkWeakIORefValue (GHC.IORef (GHC.STRef r#)) v f = GHC.IO $ \s ->
   case GHC.mkWeak# r# v f s of (# s1, w #) -> (# s1, GHC.Weak w #)
 #endif
 #else
-mkWeakIORefValue r@(GHC.IORef (GHC.STRef r#)) v (GHC.IO f) = GHC.IO $ \s ->
+mkWeakIORefValue (GHC.IORef (GHC.STRef r#)) v (GHC.IO f) = GHC.IO $ \s ->
   case GHC.mkWeak# r# v f s of (# s1, w #) -> (# s1, GHC.Weak w #)
 #endif
 
@@ -133,8 +130,9 @@ newRemotePtr coupon value Vendor{..} = do
     let self = undefined
     ptr      <- newIORef RemoteData{..}
 
-    let finalize = atomicModifyIORef' coupons $ \m -> (Map.delete coupon m, ())
-    w <- mkWeakIORef ptr finalize
+    let doFinalize =
+            atomicModifyIORef' coupons $ \m -> (Map.delete coupon m, ())
+    w <- mkWeakIORef ptr doFinalize
     atomicModifyIORef' coupons $ \m -> (Map.insert coupon w m, ())
     atomicModifyIORef' ptr $ \itemdata -> (itemdata { self = w }, ())
     return ptr
@@ -148,10 +146,10 @@ newRemotePtr coupon value Vendor{..} = do
 -- will not be garbage collected
 -- and its 'Coupon' can be successfully redeemed at the 'Vendor'.
 withRemotePtr :: RemotePtr a -> (Coupon -> a -> IO b) -> IO b
-withRemotePtr ptr f = do
-        RemoteData{..} <- readIORef ptr
+withRemotePtr ptr0 f = do
+        RemoteData{..} <- readIORef ptr0
         b <- f coupon value
-        touch ptr
+        touch ptr0
         return b
     where
     -- make sure that the pointer is alive at this point in the code

src/Graphics/UI/Threepenny/Attributes.hs

@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -Wno-missing-signatures #-}
 module Graphics.UI.Threepenny.Attributes (
     -- * Synopsis
     -- | Element attributes.
@@ -50,13 +51,13 @@ selection = fromJQueryProp "selectedIndex" from (JSON.toJSON . maybe (-1) id)
     http://hackage.haskell.org/package/html
 ------------------------------------------------------------------------------}
 strAttr :: String -> WriteAttr Element String
-strAttr name = mkWriteAttr (set' (attr name))
+strAttr attrname = mkWriteAttr (set' (attr attrname))
 
 intAttr :: String -> WriteAttr Element Int
-intAttr name = mkWriteAttr (set' (attr name) . show)
+intAttr attrname = mkWriteAttr (set' (attr attrname) . show)
 
 emptyAttr :: String -> WriteAttr Element Bool
-emptyAttr name = mkWriteAttr (set' (attr name) . f)
+emptyAttr attrname = mkWriteAttr (set' (attr attrname) . f)
     where
     f True  = "1"
     f False = "0"

src/Graphics/UI/Threepenny/Canvas.hs

@@ -20,7 +20,6 @@ import Data.List(intercalate)
 import Numeric (showHex)
 
 import Graphics.UI.Threepenny.Core
-import qualified Data.Aeson as JSON
 
 {-----------------------------------------------------------------------------
     Canvas
@@ -240,8 +239,8 @@ stroke = runFunction . ffi "%1.getContext('2d').stroke()"
 -- The 'textAlign' attributes determines the position of the text
 -- relative to the point.
 fillText :: String -> Point -> Canvas -> UI ()
-fillText text (x,y) canvas =
-  runFunction $ ffi "%1.getContext('2d').fillText(%2, %3, %4)" canvas text x y
+fillText t (x,y) canvas =
+  runFunction $ ffi "%1.getContext('2d').fillText(%2, %3, %4)" canvas t x y
 
 -- | Render the outline of a text at a certain point on the canvas.
 -- 
@@ -250,8 +249,8 @@ fillText text (x,y) canvas =
 -- The 'textAlign' attributes determines the position of the text
 -- relative to the point.
 strokeText :: String -> Point -> Canvas -> UI ()
-strokeText text (x,y) canvas =
-  runFunction $ ffi "%1.getContext('2d').strokeText(%2, %3, %4)" canvas text x y
+strokeText t (x,y) canvas =
+  runFunction $ ffi "%1.getContext('2d').strokeText(%2, %3, %4)" canvas t x y
 
 {-----------------------------------------------------------------------------
     helper functions