heartbreaking: Quox.Error doesn't actually work

tests/src/TAP.idr

@@ -1,8 +1,7 @@
 module TAP
 -- [todo] extract this and Quox.Error to their own packages
 
-import public Quox.Error
-
+import public Control.Monad.Either
 import Data.String
 import Data.List.Elem
 import Data.SnocList
@@ -40,11 +39,6 @@ toLines xs = "---" :: concatMap toLines1 xs <+> ["..."]
 
 public export interface ToInfo e where toInfo : e -> Info
 
-export
-All ToInfo es => ToInfo (OneOf es) where
-  toInfo (One Here      value) = toInfo value
-  toInfo (One (There x) value) = toInfo (One x value)
-
 export %inline ToInfo () where toInfo () = []
 
 export %inline Show a => ToInfo (List (String, a)) where toInfo = map (map show)
@@ -67,16 +61,16 @@ lazyToIO : Lazy a -> IO a
 lazyToIO val = primIO $ \w => MkIORes (force val) w
 
 export
-testIO : (All ToInfo es, ToInfo a) => String -> ErrorT es IO a -> Test
+testIO : (ToInfo e, ToInfo a) => String -> EitherT e IO a -> Test
 testIO label act = One $ MakeTest label $ do
-  case !(runErrorT act) of
+  case !(runEitherT act) of
        Right val => success val
        Left  err => failure err
 
 export %inline
-test : (All ToInfo es, ToInfo a) => String -> Lazy (Error es a) -> Test
+test : (ToInfo e, ToInfo a) => String -> Lazy (Either e a) -> Test
 test label val =
-  testIO label $ MkErrorT $ lazyToIO $ runError val
+  testIO label $ MkEitherT $ lazyToIO val
 
 export %inline
 todoWith : String -> String -> Test
@@ -100,10 +94,11 @@ skip : Test -> Test
 skip test = skipWith test ""
 
 export
-testThrows : Show a => String -> Lazy (Error es a) -> Test
-testThrows label act = One $ MakeTest label $ do
-  case runError !(lazyToIO act) of
-       Left  err => success ()
+testThrows : (ToInfo e, Show a) =>
+             String -> (e -> Bool) -> Lazy (Either e a) -> Test
+testThrows label p act = One $ MakeTest label $ do
+  case !(lazyToIO act) of
+       Left  err => if p err then success () else failure err
        Right val => failure [("success", val)]
 
 infix 0 :-

tests/src/Tests.idr

@@ -9,7 +9,7 @@ import System
 
 allTests = [
   Lexer.tests,
-  skip Equal.tests
+  Equal.tests
 ]
 
 main = do

tests/src/Tests/Equal.idr

@@ -22,13 +22,13 @@ ToInfo Equal.Error where
      ("right", prettyStr True rh)]
 
 
-M = Error [Equal.Error]
+M = Either Equal.Error
 
 testEq : String -> Lazy (M ()) -> Test
 testEq = test
 
 testNeq : String -> Lazy (M ()) -> Test
-testNeq = testThrows
+testNeq label = testThrows label $ const True
 
 
 subT : {default 0 d, n : Nat} -> Term d n -> Term d n -> M ()

tests/src/Tests/Lexer.idr

@@ -4,31 +4,39 @@ import Quox.Lexer
 import TAP
 
 
+RealError = Quox.Lexer.Error
+%hide Quox.Lexer.Error
+
 export
-ToInfo Error where
+ToInfo RealError where
   toInfo (Err reason line col char) =
     [("reason", show reason),
      ("line",   show line),
      ("col",    show col),
      ("char",   show char)]
 
-data ExtraError
-= WrongAnswer (List Token) (List Token)
+data Error
+= LexerError RealError
+| WrongAnswer (List Token) (List Token)
 | TestFailed  (List Token)
 
-ToInfo ExtraError where
+ToInfo Error where
+  toInfo (LexerError err) = toInfo err
   toInfo (WrongAnswer exp got) =
     [("expected", show exp), ("received", show got)]
   toInfo (TestFailed got) =
     [("failed", show got)]
 
 
+lex' : String -> Either Error (List Token)
+lex' = bimap LexerError (map val) . lex
+
 parameters (label : String) (input : String)
-  acceptsSuchThat' : (List Token -> Maybe ExtraError) -> Test
-  acceptsSuchThat' p = test {es = [Lexer.Error, ExtraError]} label $ do
-    res <- map val <$> lex input
+  acceptsSuchThat' : (List Token -> Maybe Error) -> Test
+  acceptsSuchThat' p = test label $ delay $ do
+    res <- bimap LexerError (map val) $ lex input
     case p res of
-         Just err => throw err
+         Just err => throwError err
          Nothing  => pure ()
 
   acceptsSuchThat : (List Token -> Bool) -> Test
@@ -43,8 +51,8 @@ parameters (label : String) (input : String)
   accepts = acceptsSuchThat $ const True
 
   rejects : Test
-  rejects = testThrows {es = [Lexer.Error]} label $ delay $
-    map val <$> lex input
+  rejects = testThrows label (\case LexerError _ => True; _ => False) $ delay $
+            bimap LexerError (map val) $ lex {m = Either RealError} input
 
 parameters (input : String) {default False esc : Bool}
   show' : String -> String