Lots of conditionals for windows support

sandwich/app/Main.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE CPP #-}
 
 module Main where
 

sandwich/sandwich.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 1750b981aa8aedcd566f479c9aeab1e7c6e333a341cfa12d40b3170ad8ebe3cb
+-- hash: 8974a5333af3c2b92169042d67a8398f766cb9f5fbe40088ffba8de1686b427b
 
 name:           sandwich
 version:        0.1.0.11
@@ -56,17 +56,6 @@ library
       Test.Sandwich.Formatters.Print.PrintPretty
       Test.Sandwich.Formatters.Print.Types
       Test.Sandwich.Formatters.Print.Util
-      Test.Sandwich.Formatters.TerminalUI.AttrMap
-      Test.Sandwich.Formatters.TerminalUI.CrossPlatform
-      Test.Sandwich.Formatters.TerminalUI.Draw
-      Test.Sandwich.Formatters.TerminalUI.Draw.ColorProgressBar
-      Test.Sandwich.Formatters.TerminalUI.Draw.ToBrickWidget
-      Test.Sandwich.Formatters.TerminalUI.Draw.TopBox
-      Test.Sandwich.Formatters.TerminalUI.Draw.Util
-      Test.Sandwich.Formatters.TerminalUI.Filter
-      Test.Sandwich.Formatters.TerminalUI.Keys
-      Test.Sandwich.Formatters.TerminalUI.OpenInEditor
-      Test.Sandwich.Formatters.TerminalUI.Types
       Test.Sandwich.Golden.Update
       Test.Sandwich.Internal.Formatters
       Test.Sandwich.Internal.Running
@@ -80,6 +69,7 @@ library
       Test.Sandwich.ParallelN
       Test.Sandwich.RunTree
       Test.Sandwich.Shutdown
+      Test.Sandwich.Signals
       Test.Sandwich.TestTimer
       Test.Sandwich.TH.HasMainFunction
       Test.Sandwich.TH.ModuleMap

sandwich/src/Test/Sandwich.hs

@@ -83,7 +83,6 @@ import Options.Applicative
 import qualified Options.Applicative as OA
 import System.Environment
 import System.FilePath
-import System.Posix.Signals
 import Test.Sandwich.ArgParsing
 import Test.Sandwich.Contexts
 import Test.Sandwich.Expectations
@@ -100,6 +99,7 @@ import Test.Sandwich.Options
 import Test.Sandwich.ParallelN
 import Test.Sandwich.RunTree
 import Test.Sandwich.Shutdown
+import Test.Sandwich.Signals
 import Test.Sandwich.TH
 import Test.Sandwich.TestTimer
 import Test.Sandwich.Types.ArgParsing
@@ -190,12 +190,12 @@ runSandwich' maybeCommandLineOptions options spec' = do
 
   exitReasonRef <- newIORef NormalExit
 
-  let shutdown = do
+  let shutdown info = do
-        putStrLn "Shutting down..."
+        putStrLn [i|Shutting down due to #{info}...|]
         writeIORef exitReasonRef InterruptExit
         forM_ rts cancelNode
 
-  _ <- installHandler sigINT (Catch shutdown) Nothing
+  _ <- installHandler sigINT shutdown
 
   -- Wait for the tree to finish
   mapM_ waitForTree rts

sandwich/src/Test/Sandwich/ArgParsing.hs

@@ -113,7 +113,9 @@ formatter :: Parser FormatterType
 formatter =
   flag' Print (long "print" <> help "Print to stdout")
   <|> flag' PrintFailures (long "print-failures" <> help "Print failures only to stdout")
+#ifndef mingw32_HOST_OS
   <|> flag' TUI (long "tui" <> help "Open terminal UI app")
+#endif
   <|> flag' Silent (long "silent" <> help "Run silently (print the run root only)")
   <|> flag Auto Auto (long "auto" <> help "Automatically decide which formatter to use")
 
@@ -263,18 +265,27 @@ addOptionsFromArgs baseOptions (CommandLineOptions {..}) = do
     isMainFormatter :: SomeFormatter -> Bool
     isMainFormatter (SomeFormatter x) = case cast x of
       Just (_ :: PrintFormatter) -> True
+#ifdef mingw32_HOST_OS
+      Nothing -> False
+#else
       Nothing -> case cast x of
         Just (_ :: TerminalUIFormatter) -> True
         Nothing -> False
+#endif
 
     setVisibilityThreshold Nothing x = x
     setVisibilityThreshold (Just v) x@(SomeFormatter f) = case cast f of
       Just pf@(PrintFormatter {}) -> SomeFormatter (pf { printFormatterVisibilityThreshold = v })
       Nothing -> case cast f of
+#ifdef mingw32_HOST_OS
+        Just (frf :: FailureReportFormatter) -> SomeFormatter (frf { failureReportVisibilityThreshold = v })
+        Nothing -> x
+#else
         Just tuif@(TerminalUIFormatter {}) -> SomeFormatter (tuif { terminalUIVisibilityThreshold = v })
         Nothing -> case cast f of
           Just (frf :: FailureReportFormatter) -> SomeFormatter (frf { failureReportVisibilityThreshold = v })
           Nothing -> x
+#endif
 
     isMarkdownSummaryFormatter :: SomeFormatter -> Bool
     isMarkdownSummaryFormatter (SomeFormatter x) = case cast x of

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

@@ -1,3 +1,5 @@
+{-# LANGUAGE CPP #-}
+
 -- | Pretty printing failure reasons
 
 
@@ -22,8 +24,10 @@ import Text.Show.Pretty as P
 printFailureReason :: FailureReason -> ReaderT (PrintFormatter, Int, Handle) IO ()
 printFailureReason (Reason _ s) = do
   printShowBoxPrettyWithTitleString "Reason: " s
+#ifndef mingw32_HOST_OS
 printFailureReason (RawImage _ fallback _image) = do
   forM_ (L.lines fallback) pin
+#endif
 printFailureReason (ChildrenFailed _ n) = do
   picn midWhite ([i|#{n} #{if n == 1 then ("child" :: String) else "children"} failed|] :: String)
 printFailureReason (ExpectedButGot _ seb1 seb2) = do

sandwich/src/Test/Sandwich/Signals.hs

@@ -0,0 +1,43 @@
+{-# LANGUAGE CPP #-}
+
+module Test.Sandwich.Signals (
+  installHandler
+  , sigINT
+  , sigTERM
+  ) where
+
+import Foreign.C.Types
+
+#ifdef mingw32_HOST_OS
+import Control.Exception.Base (assert)
+import Foreign
+#else
+import Control.Monad
+import qualified System.Posix.Signals as Posix
+#endif
+
+
+type Signal = CInt
+
+type Handler = Signal -> IO ()
+
+sigINT :: Signal
+sigINT = 2
+
+sigTERM :: Signal
+sigTERM = 15
+
+installHandler :: Signal -> Handler -> IO ()
+#ifdef mingw32_HOST_OS
+foreign import ccall "wrapper"
+    genHandler:: Handler -> IO (FunPtr Handler)
+
+foreign import ccall safe "signal.h signal"
+    install:: Signal -> FunPtr Handler -> IO Signal
+
+installHandler signal handler = do
+    result <- install signal =<< genHandler handler
+    return $ assert (result == 0) ()
+#else
+installHandler signal handler = void $ Posix.installHandler signal (Posix.CatchInfo (handler . Posix.siginfoSignal)) Nothing
+#endif

sandwich/src/Test/Sandwich/Types/ArgParsing.hs

@@ -11,23 +11,27 @@ import GHC.Int
 
 data FormatterType =
   Print
-  | PrintFailures
-  | Auto
-  | Silent
 #ifndef mingw32_HOST_OS
   | TUI
 #endif
+  | PrintFailures
+  | Auto
+  | Silent
 
 instance Show FormatterType where
   show Print = "print"
   show PrintFailures = "print-failures"
+#ifndef mingw32_HOST_OS
   show TUI = "tui"
+#endif
   show Auto = "auto"
   show Silent = "silent"
 
 instance Read FormatterType where
   readsPrec _ "print" = [(Print, "")]
+#ifndef mingw32_HOST_OS
   readsPrec _ "tui" = [(TUI, "")]
+#endif
   readsPrec _ "auto" = [(Auto, "")]
   readsPrec _ "silent" = [(Silent, "")]
   readsPrec _ _ = []

sandwich/src/Test/Sandwich/Types/Spec.hs

@@ -31,13 +31,17 @@ import Data.Maybe
 import Data.String.Interpolate
 import GHC.Stack
 import GHC.TypeLits
-import Graphics.Vty.Image (Image)
 import Safe
 
+#ifndef mingw32_HOST_OS
+import Graphics.Vty.Image (Image)
+#endif
+
 #if !MIN_VERSION_base(4,13,0)
 import Control.Monad.Fail
 #endif
 
+
 -- * ExampleM monad
 
 newtype ExampleT context m a = ExampleT { unExampleT :: ReaderT context (LoggingT m) a }
@@ -98,9 +102,12 @@ data FailureReason = Reason { failureCallStack :: Maybe CallStack
                                        , failureAsyncException :: SomeAsyncExceptionWithEq }
                    | ChildrenFailed { failureCallStack :: Maybe CallStack
                                     , failureNumChildren :: Int }
+#ifndef mingw32_HOST_OS
                    | RawImage { failureCallStack :: Maybe CallStack
                               , failureFallback :: String
                               , failureRawImage :: Image }
+#endif
+
   deriving (Show, Typeable, Eq)
 
 instance Exception FailureReason