diff --git a/sandwich/src/Test/Sandwich/Formatters/Print/CallStacks.hs b/sandwich/src/Test/Sandwich/Formatters/Print/CallStacks.hs index f34e1e57..34ff0b10 100644 --- a/sandwich/src/Test/Sandwich/Formatters/Print/CallStacks.hs +++ b/sandwich/src/Test/Sandwich/Formatters/Print/CallStacks.hs @@ -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 diff --git a/sandwich/src/Test/Sandwich/Formatters/Print/Logs.hs b/sandwich/src/Test/Sandwich/Formatters/Print/Logs.hs index af9403e7..d446b572 100644 --- a/sandwich/src/Test/Sandwich/Formatters/Print/Logs.hs +++ b/sandwich/src/Test/Sandwich/Formatters/Print/Logs.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} module Test.Sandwich.Formatters.Print.Logs where @@ -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) diff --git a/sandwich/src/Test/Sandwich/Formatters/Print/PrintPretty.hs b/sandwich/src/Test/Sandwich/Formatters/Print/PrintPretty.hs index b0b0be40..51666113 100644 --- a/sandwich/src/Test/Sandwich/Formatters/Print/PrintPretty.hs +++ b/sandwich/src/Test/Sandwich/Formatters/Print/PrintPretty.hs @@ -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 @@ -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 "}" @@ -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]) @@ -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 diff --git a/sandwich/src/Test/Sandwich/Formatters/Print/Util.hs b/sandwich/src/Test/Sandwich/Formatters/Print/Util.hs index a8dde9cc..de8e7c30 100644 --- a/sandwich/src/Test/Sandwich/Formatters/Print/Util.hs +++ b/sandwich/src/Test/Sandwich/Formatters/Print/Util.hs @@ -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 diff --git a/sandwich/src/Test/Sandwich/Formatters/TerminalUI/CrossPlatform.hs b/sandwich/src/Test/Sandwich/Formatters/TerminalUI/CrossPlatform.hs index 4a2819ed..58465168 100644 --- a/sandwich/src/Test/Sandwich/Formatters/TerminalUI/CrossPlatform.hs +++ b/sandwich/src/Test/Sandwich/Formatters/TerminalUI/CrossPlatform.hs @@ -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]) "" diff --git a/sandwich/src/Test/Sandwich/Formatters/TerminalUI/Keys.hs b/sandwich/src/Test/Sandwich/Formatters/TerminalUI/Keys.hs index 5030adbe..77ecab1c 100644 --- a/sandwich/src/Test/Sandwich/Formatters/TerminalUI/Keys.hs +++ b/sandwich/src/Test/Sandwich/Formatters/TerminalUI/Keys.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} module Test.Sandwich.Formatters.TerminalUI.Keys where diff --git a/sandwich/src/Test/Sandwich/Golden/Update.hs b/sandwich/src/Test/Sandwich/Golden/Update.hs index f4d4d9f4..6cd4b4e3 100644 --- a/sandwich/src/Test/Sandwich/Golden/Update.hs +++ b/sandwich/src/Test/Sandwich/Golden/Update.hs @@ -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 @@ -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 diff --git a/sandwich/src/Test/Sandwich/TH/HasMainFunction.hs b/sandwich/src/Test/Sandwich/TH/HasMainFunction.hs index 2848ae1d..c1242c8e 100644 --- a/sandwich/src/Test/Sandwich/TH/HasMainFunction.hs +++ b/sandwich/src/Test/Sandwich/TH/HasMainFunction.hs @@ -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) $