Skip to content

Commit

Permalink
[test] switch to detailed-0.9
Browse files Browse the repository at this point in the history
  • Loading branch information
mauke committed Oct 23, 2024
1 parent eacb826 commit 374880b
Show file tree
Hide file tree
Showing 2 changed files with 36 additions and 41 deletions.
6 changes: 3 additions & 3 deletions data-default.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -24,8 +24,8 @@ library
default-language: Haskell98

test-suite test
type: exitcode-stdio-1.0
main-is: basics.hs
build-depends: base, containers, data-default, mtl
type: detailed-0.9
test-module: Basics
build-depends: base, containers, data-default, Cabal >=1.9.2, mtl
hs-source-dirs: t
default-language: Haskell98
71 changes: 33 additions & 38 deletions t/basics.hs → t/Basics.hs
Original file line number Diff line number Diff line change
@@ -1,5 +1,9 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module Basics (tests) where

import qualified Distribution.TestSuite as C
import Control.Monad.RWS.CPS

Check failure on line 6 in t/Basics.hs

View workflow job for this annotation

GitHub Actions / Test w/ ghc 9.4 on ubuntu-latest

Could not find module ‘Control.Monad.RWS.CPS’

Check failure on line 6 in t/Basics.hs

View workflow job for this annotation

GitHub Actions / Test w/ ghc 9.4 on windows-latest

Could not find module ‘Control.Monad.RWS.CPS’

Check failure on line 6 in t/Basics.hs

View workflow job for this annotation

GitHub Actions / Test w/ ghc 9.2 on ubuntu-latest

Could not find module ‘Control.Monad.RWS.CPS’

Check failure on line 6 in t/Basics.hs

View workflow job for this annotation

GitHub Actions / Test w/ ghc 9.2 on windows-latest

Could not find module ‘Control.Monad.RWS.CPS’

Check failure on line 6 in t/Basics.hs

View workflow job for this annotation

GitHub Actions / Test w/ ghc 9.0 on ubuntu-latest

Could not find module ‘Control.Monad.RWS.CPS’

Check failure on line 6 in t/Basics.hs

View workflow job for this annotation

GitHub Actions / Test w/ ghc 9.0 on windows-latest

Could not find module ‘Control.Monad.RWS.CPS’

Check failure on line 6 in t/Basics.hs

View workflow job for this annotation

GitHub Actions / Test w/ ghc 8.10 on ubuntu-latest

Could not find module ‘Control.Monad.RWS.CPS’

Check failure on line 6 in t/Basics.hs

View workflow job for this annotation

GitHub Actions / Test w/ ghc 8.10 on windows-latest

Could not find module ‘Control.Monad.RWS.CPS’

Check failure on line 6 in t/Basics.hs

View workflow job for this annotation

GitHub Actions / Test w/ ghc 8.8 on ubuntu-latest

Could not find module ‘Control.Monad.RWS.CPS’

Check failure on line 6 in t/Basics.hs

View workflow job for this annotation

GitHub Actions / Test w/ ghc 8.8 on windows-latest

Could not find module ‘Control.Monad.RWS.CPS’

Check failure on line 6 in t/Basics.hs

View workflow job for this annotation

GitHub Actions / Test w/ ghc 8.6 on ubuntu-latest

Could not find module ‘Control.Monad.RWS.CPS’

Check failure on line 6 in t/Basics.hs

View workflow job for this annotation

GitHub Actions / Test w/ ghc 8.6 on windows-latest

Could not find module ‘Control.Monad.RWS.CPS’

Check failure on line 6 in t/Basics.hs

View workflow job for this annotation

GitHub Actions / Test w/ ghc 8.4 on ubuntu-latest

Could not find module ‘Control.Monad.RWS.CPS’

Check failure on line 6 in t/Basics.hs

View workflow job for this annotation

GitHub Actions / Test w/ ghc 8.4 on windows-latest

Could not find module ‘Control.Monad.RWS.CPS’

Check failure on line 6 in t/Basics.hs

View workflow job for this annotation

GitHub Actions / Test w/ ghc 8.2 on ubuntu-latest

Could not find module ‘Control.Monad.RWS.CPS’

Check failure on line 6 in t/Basics.hs

View workflow job for this annotation

GitHub Actions / Test w/ ghc 8.2 on windows-latest

Could not find module ‘Control.Monad.RWS.CPS’

Check failure on line 6 in t/Basics.hs

View workflow job for this annotation

GitHub Actions / Test w/ ghc 8.0 on ubuntu-latest

Failed to load interface for ‘Control.Monad.RWS.CPS’

Check failure on line 6 in t/Basics.hs

View workflow job for this annotation

GitHub Actions / Test w/ ghc 8.0 on windows-latest

Failed to load interface for ‘Control.Monad.RWS.CPS’
import Data.Default
import Data.Int
import Data.Word
Expand All @@ -12,51 +16,42 @@ import qualified Data.IntMap as IM
import qualified Data.IntSet as IS
import Data.Tree (Tree(..))

import Control.Monad (when)
import Control.Monad.Reader
import Data.IORef
import System.Exit (exitFailure)
import System.IO

newtype Test a = Test{ unTest :: ReaderT (IORef Int) IO a }
deriving (Functor, Applicative, Monad, MonadIO, MonadReader (IORef Int))

runTest :: (MonadIO m) => Test a -> m a
runTest t = liftIO $ do
hSetBuffering stdout LineBuffering
r <- newIORef 1
runReaderT (unTest t) r

instance (Default a) => Default (Test a) where
def = return def
data TestInstance = TestInstance
{ result :: Maybe String
, name :: String
}

withRef :: (IORef Int -> IO a) -> Test a
withRef f = do
r <- ask
liftIO (f r)
newtype Test a = MkTest (RWS () (Dual [TestInstance]) Int a)
deriving (Functor, Applicative, Monad, MonadState Int)

planTests :: Int -> Test ()
planTests n = liftIO $ do
putStrLn $ "1.." ++ show n
emit :: TestInstance -> Test ()
emit t = MkTest . tell $ Dual [t]

ok :: Bool -> String -> Test ()
ok b s = withRef $ \r -> do
c <- atomicModifyIORef r ((,) =<< succ)
putStrLn $ (if b then "" else "not ") ++ "ok " ++ show c ++ " - " ++ s
when (not b)
exitFailure
ok r n = do
c <- gets succ
put $! c
emit TestInstance
{ result = if r then Nothing else Just n
, name = shows c $ " # " ++ n
}

is {-, isNot-} :: (Show a, Eq a) => a -> a -> Test ()
is x y = ok (x == y) (show x ++ " == " ++ show y)
-- isNot x y = ok (x /= y) (show x ++ " /= " ++ show y)
is :: (Show a, Eq a) => a -> a -> Test ()
is g e = ok (g == e) (show g ++ " == " ++ show e)

-- diag :: String -> Test ()
-- diag s = liftIO $ do
-- putStrLn $ "# " ++ s
execTest :: Test a -> [C.TestInstance]
execTest (MkTest t) = map wrap . reverse . getDual . snd $ execRWS t () 0
where
wrap TestInstance{ result = r, name = n } = C.TestInstance
{ C.run = pure $ C.Finished (maybe C.Pass C.Fail r)
, C.name = n
, C.tags = def
, C.options = def
, C.setOption = \k _ -> Left ("bad option: " ++ show k)
}

main :: IO ()
main = runTest $ do
planTests 35
tests :: IO [C.Test]
tests = pure . map C.Test . execTest $ do
is def ()
is def (Nothing :: Maybe (Int, Ordering, [Float]))
is def ""
Expand Down

0 comments on commit 374880b

Please sign in to comment.