[update] テストで使用する ok, ng 関数を TestCase.Utils へ移動

Author: Yuta1004

lib/copager2/src/Copager2/Prelude.hs

@@ -12,6 +12,7 @@ module Copager2.Prelude
  , tokenQQ
  , RuleSet(..)
  , ruleQQ
+ , IR
  ) where
 
 import Copager2.Core.Processor (Processor, ProcessorT(..), runProcessor)
@@ -20,3 +21,4 @@ import Copager2.Core.Language.Token (TokenSet(..))
 import Copager2.Core.Language.Token.QuasiQuote (tokenQQ)
 import Copager2.Core.Language.Rule (RuleSet(..))
 import Copager2.Core.Language.Rule.QuasiQuote (ruleQQ)
+import Copager2.Core.Language.IR (IR)

test/src/TestCase/Arithmetic.hs

@@ -1,5 +1,6 @@
 module TestCase.Arithmetic (arithmetic) where
 
+import Data.Bifunctor (first)
 import Data.Either.Combinators (swapEither)
 import Data.Functor.Identity (runIdentity)
 
@@ -8,12 +9,12 @@ import Copager2.IR.Void (Void)
 
 import Language.Arithmetic (ArithmeticToken, ArithmeticRule)
 
-import Utils (test)
+import TestCase.Utils (test, ok', ng')
 
 arithmetic :: Processor ArithmeticToken ArithmeticRule Void -> IO ()
 arithmetic processor = do
- let ok = runIdentity . runProcessor processor
- ng = swapEither . ok
+ let ok = ok' processor
+ ng = ng' processor
 
  test $ do
  ok "10"
@@ -26,7 +27,6 @@ arithmetic processor = do
  ok "10 * 20"
  ok "10 / 20"
 
- test $ do
  ng "+"
  ng "(10"
  ng "((((((10)))))"

test/src/TestCase/Json.hs

@@ -1,5 +1,6 @@
 module TestCase.Json (json) where
 
+import Data.Bifunctor (first)
 import Data.Either.Combinators (swapEither)
 import Data.Functor.Identity (runIdentity)
 
@@ -8,19 +9,18 @@ import Copager2.IR.Void (Void)
 
 import Language.Json (JsonToken, JsonRule)
 
-import Utils (test)
+import TestCase.Utils (test, ok', ng')
 
 json :: Processor JsonToken JsonRule Void -> IO ()
 json processor = do
- let ok = runIdentity . runProcessor processor
- ng = swapEither . ok
+ let ok = ok' processor
+ ng = ng' processor
 
  -- オブジェクト
  test $ do
  ok "{ \"key\": 10 }"
  ok "{ \"key\": { \"key\": 10 } }"
 
- test $ do
  ng "{ \"key\": 10 "
  ng "{ key: 10 }"
  ng "{ \"key\": 10, }"
@@ -32,7 +32,6 @@ json processor = do
  ok "[10, [20, 30]]"
  ok "[[[[10]]]]"
 
- test $ do
  ng "[10"
  ng "[10, 20, ]"
  ng "[[[[[10]]]]"

test/src/TestCase/Utils.hs

@@ -0,0 +1,37 @@
+module TestCase.Utils (test, ok', ng') where
+
+import Data.Function ((&))
+import System.Exit (exitSuccess, exitFailure)
+
+import Data.Bifunctor (first, second)
+import Data.Either.Combinators (swapEither)
+import Data.Functor.Identity (runIdentity)
+
+import Copager2.Prelude
+import Copager2.Utils.Error (Copager2Error)
+
+test :: (Show a) => Either a b -> IO ()
+test (Right _) = return ()
+test (Left err) = do
+ putStrLn $ "error: " ++ show err
+ exitFailure
+
+ok' :: (TokenSet ts, RuleSet ts rs, IR i)
+ => Processor ts rs i
+ -> String
+ -> Either String ()
+ok' processor input =
+ let f = runIdentity . runProcessor processor
+ g = first (\a -> "Expected success, but " ++ show a ++ " => " ++ input ++ " ")
+ h = second (const ())
+ in h . g . f $ input
+
+ng' :: (TokenSet ts, RuleSet ts rs, IR i)
+ => Processor ts rs i
+ -> String
+ -> Either String ()
+ng' processor input =
+ let f = swapEither . runIdentity . runProcessor processor
+ g = first (const $ "Unexpected success => " ++ input ++ " ")
+ h = second (const ())
+ in h . g . f $ input

test/src/Utils.hs

@@ -22,4 +22,4 @@ test-suite standard
  other-modules:
  TestCase.Arithmetic,
  TestCase.Json,
- Utils,
+ TestCase.Utils,