sandwich: starting to fix warnings from -Wall

sandwich/package.yaml

@@ -74,7 +74,7 @@ when:
 library:
   source-dirs: src
   ghc-options:
-  - -W
+  - -Wall
   exposed-modules:
   - Test.Sandwich
   - Test.Sandwich.Contexts

sandwich/sandwich.cabal

@@ -107,7 +107,7 @@ library
       RecordWildCards
       ScopedTypeVariables
       ViewPatterns
-  ghc-options: -W
+  ghc-options: -Wall
   build-depends:
       aeson
     , ansi-terminal

sandwich/src/Test/Sandwich/ArgParsing.hs

@@ -10,6 +10,7 @@ import Data.Function
 import qualified Data.List as L
 import Data.Maybe
 import qualified Data.Text as T
+import Data.Time (UTCTime)
 import Data.Time.Clock.POSIX
 import Data.Typeable
 import Options.Applicative
@@ -29,8 +30,10 @@ import Test.Sandwich.Types.Spec
 
 #if MIN_VERSION_time(1,9,0)
 import Data.Time.Format.ISO8601
+formatTime :: UTCTime -> String
 formatTime = T.unpack . T.replace ":" "_" . T.pack . iso8601Show
 #else
+formatTime :: UTCTime -> String
 formatTime = show
 #endif
 

sandwich/src/Test/Sandwich/Formatters/Common/Util.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE CPP #-}
--- |
 
 module Test.Sandwich.Formatters.Common.Util (
   formatNominalDiffTime
@@ -10,13 +9,14 @@ import Data.Time.Clock
 import Text.Printf
 
 formatNominalDiffTime :: NominalDiffTime -> String
-formatNominalDiffTime diff | diff < ps = (roundFixed ((nominalDiffTimeToSeconds diff) * 10^15)) <> "ps"
-formatNominalDiffTime diff | diff < ns = (roundFixed ((nominalDiffTimeToSeconds diff) * 10^12)) <> "ns"
-formatNominalDiffTime diff | diff < us = (roundFixed ((nominalDiffTimeToSeconds diff) * 10^9)) <> "ns"
-formatNominalDiffTime diff | diff < ms = (roundFixed ((nominalDiffTimeToSeconds diff) * 10^6)) <> "us"
-formatNominalDiffTime diff | diff < second = (roundFixed ((nominalDiffTimeToSeconds diff) * 10^3)) <> "ms"
+formatNominalDiffTime diff | diff < ps = (roundFixed ((nominalDiffTimeToSeconds diff) * 10^(15 :: Integer))) <> "ps"
+formatNominalDiffTime diff | diff < ns = (roundFixed ((nominalDiffTimeToSeconds diff) * 10^(12 :: Integer))) <> "ns"
+formatNominalDiffTime diff | diff < us = (roundFixed ((nominalDiffTimeToSeconds diff) * 10^(9 :: Integer))) <> "ns"
+formatNominalDiffTime diff | diff < ms = (roundFixed ((nominalDiffTimeToSeconds diff) * 10^(6 :: Integer))) <> "us"
+formatNominalDiffTime diff | diff < second = (roundFixed ((nominalDiffTimeToSeconds diff) * 10^(3 :: Integer))) <> "ms"
 formatNominalDiffTime diff = (roundFixed (nominalDiffTimeToSeconds diff)) <> "s"
 
+second, ms, us, ns, ps :: NominalDiffTime
 second = secondsToNominalDiffTime 1
 ms = secondsToNominalDiffTime 0.001
 us = secondsToNominalDiffTime 0.000001

sandwich/src/Test/Sandwich/Formatters/Print.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE MultiWayIf #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 
 -- | The print formatter prints all results from the test tree from top to bottom, as they become available.
 --
@@ -44,7 +45,7 @@ instance Formatter PrintFormatter where
   finalizeFormatter _ _ _ = return ()
 
 runApp :: (MonadIO m, MonadLogger m) => PrintFormatter -> [RunNode BaseContext] -> Maybe (CommandLineOptions ()) -> BaseContext -> m ()
-runApp pf@(PrintFormatter {..}) rts _maybeCommandLineOptions bc = liftIO $ do
+runApp pf rts _maybeCommandLineOptions bc = liftIO $ do
   let total = countWhere isItBlock rts
 
   startTime <- getCurrentTime

sandwich/src/Test/Sandwich/Formatters/Print/Color.hs

@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
 
 module Test.Sandwich.Formatters.Print.Color where
 

sandwich/src/Test/Sandwich/Formatters/TerminalUI.hs

@@ -1,6 +1,7 @@
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE MultiWayIf #-}
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE RankNTypes #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Test.Sandwich.Formatters.TerminalUI (
   -- | The terminal UI formatter produces an interactive UI for running tests and inspecting their results.
@@ -165,11 +166,13 @@ continue = put
 continueNoChange :: AppState -> EventM ClickableName AppState ()
 continueNoChange _ = return ()
 
+doHalt :: p -> EventM n s ()
 doHalt _ = halt
 #else
 continueNoChange :: AppState -> EventM ClickableName (Next AppState)
 continueNoChange = continue
 
+doHalt :: p -> EventM n s
 doHalt = halt
 #endif
 
@@ -209,8 +212,8 @@ appEvent s (MouseDown (ListRow _i) V.BScrollUp _ _) = do
 appEvent s (MouseDown (ListRow _i) V.BScrollDown _ _) = do
   vScrollBy (viewportScroll MainList) 1
   continueNoChange s
-appEvent s (MouseDown (ListRow i) V.BLeft _ _) = do
-  continue (s & appMainList %~ (listMoveTo i))
+appEvent s (MouseDown (ListRow n) V.BLeft _ _) = do
+  continue (s & appMainList %~ (listMoveTo n))
 appEvent s (VtyEvent e) =
   case e of
     -- Column 1
@@ -219,15 +222,15 @@ appEvent s (VtyEvent e) =
     V.EvKey c [] | c == nextFailureKey -> do
       let ls = Vec.toList $ listElements (s ^. appMainList)
       let listToSearch = case listSelectedElement (s ^. appMainList) of
-            Just (i, MainListElem {}) -> let (front, back) = L.splitAt (i + 1) (zip [0..] ls) in back <> front
+            Just (n, MainListElem {}) -> let (front, back) = L.splitAt (n + 1) (zip [0..] ls) in back <> front
             Nothing -> zip [0..] ls
       case L.find (isFailureStatus . status . snd) listToSearch of
         Nothing -> continue s
         Just (i', _) -> continue (s & appMainList %~ (listMoveTo i'))
     V.EvKey c [] | c == previousFailureKey -> do
       let ls = Vec.toList $ listElements (s ^. appMainList)
       let listToSearch = case listSelectedElement (s ^. appMainList) of
-            Just (i, MainListElem {}) -> let (front, back) = L.splitAt i (zip [0..] ls) in (L.reverse front) <> (L.reverse back)
+            Just (n, MainListElem {}) -> let (front, back) = L.splitAt n (zip [0..] ls) in (L.reverse front) <> (L.reverse back)
             Nothing -> L.reverse (zip [0..] ls)
       case L.find (isFailureStatus . status . snd) listToSearch of
         Nothing -> continue s
@@ -325,7 +328,7 @@ appEvent s (VtyEvent e) =
 
     -- Column 3
     V.EvKey c [] | c == cycleVisibilityThresholdKey -> do
-      let newVisibilityThreshold =  case [(i, x) | (i, x) <- zip [0..] (s ^. appVisibilityThresholdSteps)
+      let newVisibilityThreshold =  case [(n, x) | (n, x) <- zip [(0 :: Integer)..] (s ^. appVisibilityThresholdSteps)
                                                  , x > s ^. appVisibilityThreshold] of
             [] -> 0
             xs -> minimum $ fmap snd xs
@@ -354,19 +357,21 @@ appEvent s (VtyEvent e) =
     ev -> handleEventLensed s appMainList handleListEvent ev >>= continue
 #endif
 
-  where withContinueS s action = action >> continue s
+  where withContinueS s' action = action >> continue s'
 #if MIN_VERSION_brick(1,0,0)
 appEvent _ _ = return ()
 #else
 appEvent s _ = continue s
 #endif
 
+modifyToggled :: AppState -> (Bool -> Bool) -> EventM ClickableName AppState ()
 modifyToggled s f = case listSelectedElement (s ^. appMainList) of
   Nothing -> continue s
   Just (_i, MainListElem {..}) -> do
     liftIO $ atomically $ modifyTVar (runTreeToggled node) f
     continue s
 
+modifyOpen :: AppState -> (Bool -> Bool) -> EventM ClickableName AppState ()
 modifyOpen s f = case listSelectedElement (s ^. appMainList) of
   Nothing -> continue s
   Just (_i, MainListElem {..}) -> do
@@ -455,6 +460,7 @@ withScroll s action = do
   continue s
 #endif
 
+openSrcLoc :: Ord n => AppState -> SrcLoc -> EventM n AppState ()
 openSrcLoc s loc' = do
   -- Try to make the file path in the SrcLoc absolute
   loc <- case isRelative (srcLocFile loc') of

sandwich/src/Test/Sandwich/Formatters/TerminalUI/Draw.hs

@@ -18,7 +18,7 @@ import Data.String.Interpolate
 import qualified Data.Text.Encoding as E
 import Data.Time.Clock
 import GHC.Stack
-import Lens.Micro
+import Lens.Micro hiding (ix)
 import Safe
 import Test.Sandwich.Formatters.Common.Count
 import Test.Sandwich.Formatters.Common.Util
@@ -43,6 +43,7 @@ drawUI app = [ui]
       , clickable ColorBar $ bottomProgressBarColored app
       ]
 
+mainList :: AppState -> Widget ClickableName
 mainList app = hCenter $ padAll 1 $ L.renderListWithIndex listDrawElement True (app ^. appMainList)
   where
     listDrawElement ix isSelected x@(MainListElem {..}) = clickable (ListRow ix) $ padLeft (Pad (4 * depth)) $ (if isSelected then border else id) $ vBox $ catMaybes [
@@ -121,6 +122,7 @@ mainList app = hCenter $ padAll 1 $ L.renderListWithIndex listDrawElement True (
     logLevelWidget (LevelOther x) = withAttr infoAttr $ str [i|#{x}|]
 
 
+borderWithCounts :: AppState -> Widget n
 borderWithCounts app = hBorderWithLabel $ padLeftRight 1 $ hBox (L.intercalate [str ", "] countWidgets <> [str [i| of |]
                                                                                                           , withAttr totalAttr $ str $ show totalNumTests
                                                                                                           , str [i| in |]

sandwich/src/Test/Sandwich/Formatters/TerminalUI/Draw/RunTimes.hs

@@ -12,9 +12,11 @@ import Test.Sandwich.Formatters.TerminalUI.AttrMap
 import Test.Sandwich.Formatters.TerminalUI.Types
 
 
-minGray :: Int = 50
-maxGray :: Int = 255
+minGray, maxGray :: Int
+minGray = 50
+maxGray = 255
 
+getRunTimes :: AppState -> UTCTime -> UTCTime -> Maybe NominalDiffTime -> Maybe NominalDiffTime -> Bool -> Widget n
 getRunTimes app startTime endTime statusSetupTime statusTeardownTime showEllipses = raw setupWork <+> raw actualWork <+> raw teardownWork
   where
     totalElapsed = diffUTCTime (app ^. appCurrentTime) (app ^. appStartTime)

sandwich/src/Test/Sandwich/Internal/Running.hs

@@ -65,13 +65,13 @@ runWithRepeat 0 totalTests action = do
      | otherwise -> exitFailure
 -- | For 1 repeat, run once and return
 runWithRepeat n totalTests action = do
-  (successes, total) <- (flip execStateT (0 :: Int, 0 :: Int)) $ flip fix (n - 1) $ \loop n -> do
+  (successes, total) <- (flip execStateT (0 :: Int, 0 :: Int)) $ flip fix (n - 1) $ \loop n' -> do
     (exitReason, numFailures) <- liftIO action
 
     modify $ \(successes, total) -> (successes + (if numFailures == 0 then 1 else 0), total + 1)
 
     if | exitReason == SignalExit -> return ()
-       | n > 0 -> loop (n - 1)
+       | n' > 0 -> loop (n' - 1)
        | otherwise -> return ()
 
   putStrLn [i|#{successes} runs succeeded out of #{total} repeat#{if n > 1 then ("s" :: String) else ""} (#{totalTests} tests)|]
@@ -98,8 +98,8 @@ baseContextFromOptions options@(Options {..}) = do
           here <- getCurrentDirectory
           return $ here </> base'
 
-      name <- f
-      let dir = base </> name
+      name' <- f
+      let dir = base </> name'
       createDirectoryIfMissing True dir
       return $ Just dir
 

sandwich/src/Test/Sandwich/Interpreters/StartTree.hs

@@ -53,7 +53,7 @@ startTree node@(RunNodeBefore {..}) ctx' = do
   let ctx = modifyBaseContext ctx' $ baseContextFromCommon runNodeCommon
   runInAsync node ctx $ do
     (timed (runExampleM runNodeBefore ctx runTreeLogs (Just [i|Exception in before '#{runTreeLabel}' handler|]))) >>= \case
-      (result@(Failure fr@(Pending {..})), setupTime) -> do
+      (result@(Failure fr@(Pending {})), setupTime) -> do
         markAllChildrenWithResult runNodeChildren ctx (Failure fr)
         return (result, mkSetupTimingInfo setupTime)
       (result@(Failure fr), setupTime) -> do
@@ -90,8 +90,8 @@ startTree node@(RunNodeIntroduce {..}) ctx' = do
             (\(ret, setupTime) -> case ret of
                 Left failureReason -> writeIORef result (Failure failureReason, mkSetupTimingInfo setupTime)
                 Right intro -> do
-                  (ret, teardownTime) <- timed $ runExampleM (runNodeCleanup intro) ctx runTreeLogs (Just [i|Failure in introduce '#{runTreeLabel}' cleanup handler|])
-                  writeIORef result (ret, ExtraTimingInfo (Just setupTime) (Just teardownTime))
+                  (ret', teardownTime) <- timed $ runExampleM (runNodeCleanup intro) ctx runTreeLogs (Just [i|Failure in introduce '#{runTreeLabel}' cleanup handler|])
+                  writeIORef result (ret', ExtraTimingInfo (Just setupTime) (Just teardownTime))
             )
             (\(ret, _setupTime) -> case ret of
                 Left failureReason@(Pending {}) -> do
@@ -340,7 +340,7 @@ runExampleM' ex ctx logs exceptionMessage = do
     wrapInFailureReasonIfNecessary msg e = return $ Left $ case fromException e of
       Just (x :: FailureReason) -> x
       _ -> case fromException e of
-        Just (SomeExceptionWithCallStack e cs) -> GotException (Just cs) msg (SomeExceptionWithEq (SomeException e))
+        Just (SomeExceptionWithCallStack e' cs) -> GotException (Just cs) msg (SomeExceptionWithEq (SomeException e'))
         _ -> GotException Nothing msg (SomeExceptionWithEq e)
 
 recordExceptionInStatus :: (MonadIO m) => TVar Status -> SomeException -> m ()

sandwich/src/Test/Sandwich/ParallelN.hs

@@ -23,7 +23,6 @@ import Control.Concurrent.QSem
 import Control.Exception.Safe
 import Control.Monad
 import Control.Monad.IO.Class
-import Control.Monad.Trans.Control (MonadBaseControl)
 import Test.Sandwich.Contexts
 import Test.Sandwich.Types.ArgParsing
 import Test.Sandwich.Types.RunTree
@@ -33,12 +32,12 @@ import Test.Sandwich.Types.Spec
 
 -- | Wrapper around 'parallel'. Introduces a semaphore to limit the parallelism to N threads.
 parallelN :: (
-  MonadBaseControl IO m, MonadIO m, MonadMask m
+  MonadIO m, MonadMask m
   ) => Int -> SpecFree (LabelValue "parallelSemaphore" QSem :> context) m () -> SpecFree context m ()
 parallelN = parallelN' defaultParallelNodeOptions
 
 parallelN' :: (
-  MonadBaseControl IO m, MonadIO m, MonadMask m
+  MonadIO m, MonadMask m
   ) => NodeOptions -> Int -> SpecFree (LabelValue "parallelSemaphore" QSem :> context) m () -> SpecFree context m ()
 parallelN' nodeOptions n children = introduce "Introduce parallel semaphore" parallelSemaphore (liftIO $ newQSem n) (const $ return ()) $
   parallel' nodeOptions $ aroundEach "Take parallel semaphore" claimRunSlot children
@@ -48,12 +47,12 @@ parallelN' nodeOptions n children = introduce "Introduce parallel semaphore" par
 
 -- | Same as 'parallelN', but extracts the semaphore size from the command line options.
 parallelNFromArgs :: forall context a m. (
-  MonadBaseControl IO m, MonadIO m, MonadMask m, HasCommandLineOptions context a
+  MonadIO m, MonadMask m, HasCommandLineOptions context a
   ) => (CommandLineOptions a -> Int) -> SpecFree (LabelValue "parallelSemaphore" QSem :> context) m () -> SpecFree context m ()
 parallelNFromArgs = parallelNFromArgs' @context @a defaultParallelNodeOptions
 
 parallelNFromArgs' :: forall context a m. (
-  MonadBaseControl IO m, MonadIO m, MonadMask m, HasCommandLineOptions context a
+  MonadIO m, MonadMask m, HasCommandLineOptions context a
   ) => NodeOptions -> (CommandLineOptions a -> Int) -> SpecFree (LabelValue "parallelSemaphore" QSem :> context) m () -> SpecFree context m ()
 parallelNFromArgs' nodeOptions getParallelism children = introduce "Introduce parallel semaphore" parallelSemaphore getQSem (const $ return ()) $
   parallel' nodeOptions $ aroundEach "Take parallel semaphore" claimRunSlot children