Hlinting

.gitignore

@@ -8,14 +8,30 @@
 
 *.old
 
-dist
-
 cabal-dev
 cabal.sandbox.config
 .cabal-sandbox
 
 .stack-work
 
+dist
+dist-*
+cabal-dev
+*.chi
+*.chs.h
+*.dyn_o
+*.dyn_hi
+.hpc
+.hsenv
+*.prof
+*.aux
+*.hp
+*.eventlog
+cabal.project.local
+cabal.project.local~
+.HTF/
+.ghc.environment.*
+
 bingtranslator
 bingtranslatorconc
 catch-mask
@@ -81,3 +97,5 @@ sudoku5
 threadperf1
 threadperf2
 timeout
+
+

.hlint.yaml

@@ -0,0 +1,67 @@
+# HLint configuration file
+# https://github.com/ndmitchell/hlint
+##########################
+
+# This file contains a template configuration file, which is typically
+# placed as .hlint.yaml in the root of your project
+
+
+# Specify additional command line arguments
+#
+# - arguments: [--color, --cpp-simple, -XQuasiQuotes]
+
+
+# Control which extensions/flags/modules/functions can be used
+#
+# - extensions:
+#   - default: false # all extension are banned by default
+#   - name: [PatternGuards, ViewPatterns] # only these listed extensions can be used
+#   - {name: CPP, within: CrossPlatform} # CPP can only be used in a given module
+#
+# - flags:
+#   - {name: -w, within: []} # -w is allowed nowhere
+#
+# - modules:
+#   - {name: [Data.Set, Data.HashSet], as: Set} # if you import Data.Set qualified, it must be as 'Set'
+#   - {name: Control.Arrow, within: []} # Certain modules are banned entirely
+#
+# - functions:
+#   - {name: unsafePerformIO, within: []} # unsafePerformIO can only appear in no modules
+
+
+# Add custom hints for this project
+#
+# Will suggest replacing "wibbleMany [myvar]" with "wibbleOne myvar"
+# - error: {lhs: "wibbleMany [x]", rhs: wibbleOne x}
+
+ - ignore: {name: Eta reduce}
+ - ignore: {name: Use tuple-section}
+ - ignore: {name: Use newtype instead of data}
+ - ignore: {name: Redundant bracket}
+ - ignore: {name: Use camelCase}
+ - ignore: {name: Unused LANGUAGE pragma}
+ - ignore: {name: Use otherwise}
+
+# Turn on hints that are off by default
+#
+# Ban "module X(module X) where", to require a real export list
+# - warn: {name: Use explicit module export list}
+#
+# Replace a $ b $ c with a . b $ c
+# - group: {name: dollar, enabled: true}
+#
+# Generalise map to fmap, ++ to <>
+# - group: {name: generalise, enabled: true}
+
+
+# Ignore some builtin hints
+# - ignore: {name: Use let}
+# - ignore: {name: Use const, within: SpecialModule} # Only within certain modules
+
+
+# Define some custom infix operators
+# - fixity: infixr 3 ~^#^~
+
+
+# To generate a suitable file for HLint do:
+# $ hlint --default > .hlint.yaml

.travis.yml

@@ -171,7 +171,7 @@ install:
       # Get the list of packages from the stack.yaml file
       PACKAGES=$(stack --install-ghc query locals | grep '^ *path' | sed 's@^ *path:@@')
 
-      cabal install --only-dependencies --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES
+      cabal install --only-dependencies --enable-tests --enable-benchmarks --force-reinstalls --ghc-options='-Wall -O0' --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES
       ;;
   esac
   set +ex
@@ -184,7 +184,7 @@ script:
       stack --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps
       ;;
     cabal)
-      cabal install --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES
+      cabal install --enable-tests --enable-benchmarks --force-reinstalls --ghc-options='-Wall -O0' --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES
 
       ORIGDIR=$(pwd)
       for dir in $PACKAGES

Stream.hs

@@ -92,6 +92,6 @@ streamFilter p instr = do
              tail <- new
              put_ outstr (Cons x tail)
              loop instr' tail
-          | otherwise -> do
+          | otherwise ->
              loop instr' outstr
 

Sudoku.hs

@@ -139,9 +139,9 @@ gridToString g =
       -- ["1  2  3 "," 4  5  6 ", ...]
       l3 = (sublist 3) l2
       -- [["1  2  3 "," 4  5  6 "," 7  8  9 "],...] 
-      l4 = (map (concat . intersperse "|")) l3
+      l4 = (map (intercalate "|")) l3
       -- ["1  2  3 | 4  5  6 | 7  8  9 ",...]
-      l5 = (concat . intersperse [line] . sublist 3) l4
+      l5 = (intercalate [line] . sublist 3) l4
   in unlines l5 
      where sublist n [] = []
            sublist n xs = ys : sublist n zs

TBQueue2.hs

@@ -34,7 +34,7 @@ writeTBQueue :: TBQueue a -> a -> STM ()
 writeTBQueue (TBQueue rsize _read wsize write) a = do
   w <- readTVar wsize
   if (w /= 0)
-     then do writeTVar wsize (w - 1)
+     then writeTVar wsize (w - 1)
      else do
           r <- readTVar rsize
           if (r /= 0)

TChan.hs

@@ -59,7 +59,7 @@ isEmptyTChan (TChan read _write) = do
 -- >>
 
 main = do
-  c <- atomically $ newTChan
+  c <- atomically newTChan
   atomically $ writeTChan c 'a'
   atomically (readTChan c) >>= print
   atomically (isEmptyTChan c) >>= print

chan3.hs

@@ -42,7 +42,7 @@ writeChan (Chan _ writeVar) val = do
 
 -- <<readChan
 readChan :: Chan a -> IO a
-readChan (Chan readVar _) = do
+readChan (Chan readVar _) =
   modifyMVar readVar $ \stream -> do
     Item val tail <- readMVar stream
     return (tail, val)

chanbench.hs

@@ -63,7 +63,7 @@ runtest n test = do
     1 -> do
       replicateM_ n $ writec c (1 :: Int)
       replicateM_ n $ readc c
-    2 -> do
+    2 ->  do
       replicateM_ (n `quot` bufsiz) $ do
         replicateM_ bufsiz $ writec c (1 :: Int)
         replicateM_ bufsiz $ readc c

chat.hs

@@ -119,7 +119,7 @@ data Message = Notice String
 broadcast :: Server -> Message -> STM ()
 broadcast Server{..} msg = do
   clientmap <- readTVar clients
-  mapM_ (\client -> sendMessage client msg) (Map.elems clientmap)
+  mapM_ (`sendMessage` msg) (Map.elems clientmap)
 -- >>
 
 -- <<sendMessage
@@ -220,7 +220,7 @@ runClient serv@Server{..} client@Client{..} = do
         msg <- readTChan clientSendChan
         return $ do
             continue <- handleMessage serv client msg
-            when continue $ server
+            when continue server
 -- >>
 
 -- <<handleMessage

distrib-chat/chat-noslave.hs

@@ -181,7 +181,7 @@ kick server@Server{..} who by = do
     Just (ClientLocal victim) -> do
       writeTVar (clientKicked victim) $ Just ("by " ++ by)
       void $ sendToName server by (Notice $ "you kicked " ++ who)
-    Just (ClientRemote victim) -> do
+    Just (ClientRemote victim) ->
       sendRemote server (clientHome victim) (MsgKick who by)
 -- >>
 
@@ -254,7 +254,7 @@ runClient serv@Server{..} client@LocalClient{..} = do
         msg <- readTChan clientSendChan
         return $ do
             continue <- handleMessage serv client msg
-            when continue $ server
+            when continue server
 -- >>
 
 -- <<handleMessage
@@ -352,7 +352,7 @@ handleRemoteMessage server@Server{..} m =
 
     MsgNewClient name pid -> liftIO $ atomically $ do
         ok <- checkAddClient server (ClientRemote (RemoteClient name pid))
-        when (not ok) $
+        unless ok $
           sendRemote server pid (MsgKick name "SYSTEM")
 
     MsgClientDisconnected name pid -> liftIO $ atomically $ do
@@ -379,7 +379,7 @@ newServerInfo server@Server{..} rsvp pid remote_clients = do
             -- ToDo: also deal with conflicts
     writeTVar clients new_clientmap
 
-    when rsvp $ do
+    when rsvp $
       sendRemote server pid
          (MsgServerInfo False spid (localClientNames new_clientmap))
 
@@ -404,7 +404,7 @@ master backend port = do
   mypid <- getSelfPid
   register "chatServer" mypid
 
-  forM_ peers $ \peer -> do
+  forM_ peers $ \peer ->
     whereisRemoteAsync peer "chatServer"
 
   chatServer (read port :: Int)

distrib-chat/chat.hs

@@ -176,7 +176,7 @@ kick server@Server{..} who by = do
     Just (ClientLocal victim) -> do
       writeTVar (clientKicked victim) $ Just ("by " ++ by)
       void $ sendToName server by (Notice $ "you kicked " ++ who)
-    Just (ClientRemote victim) -> do
+    Just (ClientRemote victim) ->
       sendRemote server (clientHome victim) (MsgKick who by)
 -- >>
 
@@ -249,7 +249,7 @@ runClient serv@Server{..} client@LocalClient{..} = do
         msg <- readTChan clientSendChan
         return $ do
             continue <- handleMessage serv client msg
-            when continue $ server
+            when continue server
 -- >>
 
 -- <<handleMessage
@@ -319,7 +319,7 @@ handleRemoteMessage server@Server{..} m = liftIO $ atomically $
 
     MsgNewClient name pid -> do                                   -- <3>
         ok <- checkAddClient server (ClientRemote (RemoteClient name pid))
-        when (not ok) $
+        unless ok $
           sendRemote server pid (MsgKick name "SYSTEM")
 
     MsgClientDisconnected name pid -> do                          -- <4>

distrib-db/db.hs

@@ -25,7 +25,7 @@ master peers = do
 
   forever $ do
     l <- liftIO $ do putStr "key: "; hFlush stdout; getLine
-    when (not (null l)) $ do
+    unless (null l) $ do
       r <- get db l
       liftIO $ putStrLn ("response: " ++ show r)
 

distrib-ping/ping-fail.hs

@@ -56,5 +56,5 @@ master = do
 
 -- <<main
 main :: IO ()
-main = distribMain (\_ -> master) Main.__remoteTable
+main = distribMain (const master) Main.__remoteTable
 -- >>

distrib-ping/ping-tc-notify.hs

@@ -50,7 +50,7 @@ master peers = do
     return recvport
 
   let loop [] = return ()
-      loop (port:ps) = do
+      loop (port:ps) =
         receiveWait
           [ match $ \(ProcessMonitorNotification ref pid reason) -> do
               say (show pid ++ " died: " ++ show reason)

distrib-ping/ping.hs

@@ -51,5 +51,5 @@ master = do
 
 -- <<main
 main :: IO ()
-main = distribMain (\_ -> master) Main.__remoteTable
+main = distribMain (const master) Main.__remoteTable
 -- >>

findpar.hs

@@ -14,7 +14,7 @@ find :: String -> FilePath -> IO (Maybe FilePath)
 find s d = do
   fs <- getDirectoryContents d
   let fs' = sort $ filter (`notElem` [".",".."]) fs
-  if any (== s) fs'
+  if s `elem` fs'
      then return (Just (d </> s))
      else do
        let ps = map (d </>) fs'         -- <1>

findpar2.hs

@@ -22,7 +22,7 @@ find :: NBSem -> String -> FilePath -> IO (Maybe FilePath)
 find sem s d = do
   fs <- getDirectoryContents d
   let fs' = sort $ filter (`notElem` [".",".."]) fs
-  if any (== s) fs'
+  if s `elem` fs'
      then return (Just (d </> s))
      else do
        let ps = map (d </>) fs'         -- <1>

findpar3.hs

@@ -25,7 +25,7 @@ find :: NBSem -> String -> FilePath -> IO (Maybe FilePath)
 find sem s d = do
   fs <- getDirectoryContents d
   let fs' = sort $ filter (`notElem` [".",".."]) fs
-  if any (== s) fs'
+  if s `elem` fs'
      then return (Just (d </> s))
      else do
        let ps = map (d </>) fs'         -- <1>
@@ -68,7 +68,7 @@ newNBSem i = do
   return (NBSem m)
 
 tryWaitNBSem :: NBSem -> IO Bool
-tryWaitNBSem (NBSem m) = do
+tryWaitNBSem (NBSem m) =
   atomicModifyIORef m $ \i ->
     if i == 0
        then (i, False)

findpar4.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
 import System.Directory
 import Control.Concurrent
 import System.FilePath
@@ -24,7 +24,7 @@ find :: String -> FilePath -> ParIO (Maybe FilePath)
 find s d = do
   fs <- liftIO $ getDirectoryContents d
   let fs' = sort $ filter (`notElem` [".",".."]) fs
-  if any (== s) fs'
+  if s `elem` fs'
      then return (Just (d </> s))
      else do
        let ps = map (d </>) fs'

findpar5.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
 import System.Directory
 import Control.Applicative
 import Control.Concurrent
@@ -25,7 +25,7 @@ find :: String -> FilePath -> EParIO (Maybe FilePath)
 find s d = do
   fs <- liftIO $ getDirectoryContents d
   let fs' = sort $ filter (`notElem` [".",".."]) fs
-  if any (== s) fs'
+  if s `elem` fs'
      then return (Just (d </> s))
      else do
        let ps = map (d </>) fs'         -- <1>
@@ -84,7 +84,7 @@ instance MonadIO EParIO where
   liftIO io = E $ liftIO (try io)
 
 liftPar :: ParIO a -> EParIO a
-liftPar p = E $ p >>= return . Right
+liftPar p = E $ Right <$> p
 
 type EVar a = IVar (Either SomeException a)
 
@@ -95,5 +95,5 @@ get :: EVar a -> EParIO a
 get evar = E $ P.get evar
 
 putResult :: EParIO a -> EVar a -> ParIO ()
-putResult (E e) var = do e >>= P.put_ var
+putResult (E e) var = e >>= P.put_ var
 

findseq.hs

@@ -17,7 +17,7 @@ find :: String -> FilePath -> IO (Maybe FilePath)
 find s d = do
   fs <- getDirectoryContents d                         -- <1>
   let fs' = sort $ filter (`notElem` [".",".."]) fs    -- <2>
-  if any (== s) fs'                                    -- <3>
+  if s `elem` fs'                                      -- <3>
      then return (Just (d </> s))
      else loop fs'                                     -- <4>
  where