Skip to content

Commit

Permalink
Fixing more warnings
Browse files Browse the repository at this point in the history
  • Loading branch information
thomasjm committed Feb 29, 2024
1 parent 7d279ed commit 2079473
Show file tree
Hide file tree
Showing 8 changed files with 34 additions and 5 deletions.
11 changes: 11 additions & 0 deletions sandwich/src/Test/Sandwich/Formatters/Print/CallStacks.hs
Original file line number Diff line number Diff line change
@@ -1,14 +1,25 @@
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}

module Test.Sandwich.Formatters.Print.CallStacks where

import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Reader
import GHC.Stack
import System.IO (Handle)
import Test.Sandwich.Formatters.Print.Color
import Test.Sandwich.Formatters.Print.Printing
import Test.Sandwich.Formatters.Print.Types


printCallStack :: (
MonadReader (PrintFormatter, Int, Handle) m, MonadIO m
) => CallStack -> m ()
printCallStack cs = forM_ (getCallStack cs) printCallStackLine

printCallStackLine :: (
MonadReader (PrintFormatter, Int, Handle) m, MonadIO m
) => (String, SrcLoc) -> m ()
printCallStackLine (f, (SrcLoc {..})) = do
pic logFunctionColor f

Expand Down
4 changes: 4 additions & 0 deletions sandwich/src/Test/Sandwich/Formatters/Print/Logs.hs
Original file line number Diff line number Diff line change
@@ -1,4 +1,5 @@
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}

module Test.Sandwich.Formatters.Print.Logs where

Expand Down Expand Up @@ -30,6 +31,9 @@ printLogs runTreeLogs = do
when (logEntryLevel entry >= logLevel) $ printLogEntry entry


printLogEntry :: (
MonadReader (PrintFormatter, Int, Handle) m, MonadIO m
) => LogEntry -> m ()
printLogEntry (LogEntry {..}) = do
pic logTimestampColor (show logEntryTime)

Expand Down
13 changes: 10 additions & 3 deletions sandwich/src/Test/Sandwich/Formatters/Print/PrintPretty.hs
Original file line number Diff line number Diff line change
Expand Up @@ -7,6 +7,7 @@ module Test.Sandwich.Formatters.Print.PrintPretty (
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Reader
import Data.Colour
import qualified Data.List as L
import System.IO
import Test.Sandwich.Formatters.Print.Color
Expand Down Expand Up @@ -39,10 +40,10 @@ printPretty indentFirst (Rec name tuples) = do
(if indentFirst then pic else pc) recordNameColor name
pcn braceColor " {"
withBumpIndent $
forM_ tuples $ \(name, val) -> do
pic fieldNameColor name
forM_ tuples $ \(name', val) -> do
pic fieldNameColor name'
p " = "
withBumpIndent' (L.length name + L.length (" = " :: String)) $ do
withBumpIndent' (L.length name' + L.length (" = " :: String)) $ do
printPretty False val
p "\n"
pic braceColor "}"
Expand All @@ -67,6 +68,9 @@ printPretty (getPrintFn -> f) (Neg s) = do
printPretty False s


printListWrappedIn :: (
MonadReader (PrintFormatter, Int, Handle) m, MonadIO m
) => (String, String) -> Bool -> [Value] -> m ()
printListWrappedIn (begin, end) (getPrintFn -> f) values | all isSingleLine values = do
f listBracketColor begin
sequence_ (L.intercalate [p ", "] [[printPretty False v] | v <- values])
Expand All @@ -80,5 +84,8 @@ printListWrappedIn (begin, end) (getPrintFn -> f) values = do
p "\n"
pic listBracketColor end

getPrintFn :: (
MonadReader (PrintFormatter, Int, Handle) m, MonadIO m
) => Bool -> Colour Float -> String -> m ()
getPrintFn True = pic
getPrintFn False = pc
4 changes: 3 additions & 1 deletion sandwich/src/Test/Sandwich/Formatters/Print/Util.hs
Original file line number Diff line number Diff line change
Expand Up @@ -24,11 +24,13 @@ isSingleLine (Quote s) = '\n' `L.notElem` s

isSingleLine _ = True

withBumpIndent :: MonadReader (PrintFormatter, Int, c) m => m b -> m b
withBumpIndent action = do
(PrintFormatter {..}, _, _) <- ask
withBumpIndent' printFormatterIndentSize action

withBumpIndent' :: (MonadReader (a, Int, c) m) => Int -> m b -> m b
withBumpIndent' n = local (\(pf, indent, h) -> (pf, indent + n, h))


fst3 :: (a, b, c) -> a
fst3 (x, _, _) = x
Original file line number Diff line number Diff line change
Expand Up @@ -8,5 +8,6 @@ import Control.Monad
import System.Process

-- | TODO: report exceptions here
openFileExplorerFolderPortable :: String -> IO ()
openFileExplorerFolderPortable folder = do
void $ readCreateProcessWithExitCode (proc "xdg-open" [folder]) ""
1 change: 1 addition & 0 deletions sandwich/src/Test/Sandwich/Formatters/TerminalUI/Keys.hs
Original file line number Diff line number Diff line change
@@ -1,3 +1,4 @@
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}

module Test.Sandwich.Formatters.TerminalUI.Keys where

Expand Down
4 changes: 3 additions & 1 deletion sandwich/src/Test/Sandwich/Golden/Update.hs
Original file line number Diff line number Diff line change
Expand Up @@ -29,7 +29,7 @@ updateGolden (fromMaybe defaultDirGoldenTest -> dir) = do
putStrLnColor enableColor green "Done!"

where
go enableColor dir = listDirectory dir >>= mapM_ (processEntry enableColor)
go enableColor dir' = listDirectory dir' >>= mapM_ (processEntry enableColor)

processEntry enableColor (((dir ++ "/") ++) -> entryInDir) = do
isDir <- doesDirectoryExist entryInDir
Expand All @@ -55,9 +55,11 @@ green = SetColor Foreground Dull Green
red = SetColor Foreground Dull Red
magenta = SetColor Foreground Dull Magenta

putStrColor :: EnableColor -> SGR -> String -> IO ()
putStrColor EnableColor color s = bracket_ (setSGR [color]) (setSGR [Reset]) (putStr s)
putStrColor DisableColor _ s = putStr s

putStrLnColor :: EnableColor -> SGR -> String -> IO ()
putStrLnColor EnableColor color s = bracket_ (setSGR [color]) (setSGR [Reset]) (putStrLn s)
putStrLnColor DisableColor _ s = putStrLn s

Expand Down
1 change: 1 addition & 0 deletions sandwich/src/Test/Sandwich/TH/HasMainFunction.hs
Original file line number Diff line number Diff line change
Expand Up @@ -19,6 +19,7 @@ data ShouldWarnOnParseError = WarnOnParseError | NoWarnOnParseError

-- | Use haskell-src-exts to determine if a give Haskell file has an exported main function
-- Parse with all extensions enabled, which will hopefully parse anything
fileHasMainFunction :: FilePath -> ShouldWarnOnParseError -> Q Bool
fileHasMainFunction path shouldWarnOnParseError = runIO (parseFileWithExts [x | x@(EnableExtension _) <- knownExtensions] path) >>= \case
x@(ParseFailed {}) -> do
when (shouldWarnOnParseError == WarnOnParseError) $
Expand Down

0 comments on commit 2079473

Please sign in to comment.