diff --git a/lib/Quox/Parser/FromParser.idr b/lib/Quox/Parser/FromParser.idr index 6326a5e..afe2ae4 100644 --- a/lib/Quox/Parser/FromParser.idr +++ b/lib/Quox/Parser/FromParser.idr @@ -13,7 +13,7 @@ import System.File import System.Path import Data.IORef -import public Quox.Parser.FromParser.Error +import public Quox.Parser.FromParser.Error as Quox.Parser.FromParser %default total diff --git a/tests/Tests/Equal.idr b/tests/Tests/Equal.idr index bf1472b..54dc143 100644 --- a/tests/Tests/Equal.idr +++ b/tests/Tests/Equal.idr @@ -1,12 +1,14 @@ module Tests.Equal import Quox.Equal +import Quox.Typechecker import Quox.Syntax.Qty.Three import public TypingImpls import TAP +import Quox.EffExtra 0 M : Type -> Type -M = ReaderT (Definitions Three) (Either (Error Three)) +M = TC Three defGlobals : Definitions Three defGlobals = fromList @@ -23,10 +25,10 @@ defGlobals = fromList parameters (label : String) (act : Lazy (M ())) {default defGlobals globals : Definitions Three} testEq : Test - testEq = test label $ runReaderT globals act + testEq = test label $ runTC globals act testNeq : Test - testNeq = testThrows label (const True) $ runReaderT globals act $> "()" + testNeq = testThrows label (const True) $ runTC globals act $> "()" parameters (0 d : Nat) (ctx : TyContext Three d n) diff --git a/tests/Tests/FromPTerm.idr b/tests/Tests/FromPTerm.idr index 211cf26..05b65fe 100644 --- a/tests/Tests/FromPTerm.idr +++ b/tests/Tests/FromPTerm.idr @@ -1,11 +1,12 @@ module Tests.FromPTerm -import Quox.Parser.Syntax +import Quox.Parser.FromParser import Quox.Parser import TermImpls import TypingImpls import Tests.Parser as TParser import TAP +import Quox.EffExtra import System.File import Derive.Prelude @@ -16,21 +17,19 @@ import Derive.Prelude public export data Failure = - ParseError (Parser.Error) - | FromParser FromParserError + ParseError Parser.Error + | FromParser FromParser.Error | WrongResult String | ExpectedFail String %runElab derive "FileError" [Show] -%runElab derive "Parser.Error" [Show] -%runElab derive "FromParserError" [Show] export ToInfo Failure where toInfo (ParseError err) = toInfo err toInfo (FromParser err) = [("type", "FromParserError"), - ("got", show err)] + ("got", show $ prettyError True True err)] toInfo (WrongResult got) = [("type", "WrongResult"), ("got", got)] toInfo (ExpectedFail got) = @@ -38,7 +37,7 @@ ToInfo Failure where parameters {c : Bool} {auto _ : Show b} - (grm : Grammar c a) (fromP : a -> Either FromParserError b) + (grm : Grammar c a) (fromP : a -> Either FromParser.Error b) (inp : String) parameters {default (ltrim inp) label : String} parsesWith : (b -> Bool) -> Test @@ -62,11 +61,14 @@ parameters {c : Bool} {auto _ : Show b} FromString BName where fromString = Just . fromString +runFromParser : Eff [Except FromParser.Error] a -> Either FromParser.Error a +runFromParser = extract . runExcept + export tests : Test tests = "PTerm โ†’ Term" :- [ "dimensions" :- - let fromPDim = fromPDimWith [< "๐‘–", "๐‘—"] + let fromPDim = runFromParser . fromPDimWith [< "๐‘–", "๐‘—"] in [ note "dim ctx: [๐‘–, ๐‘—]", parsesAs dim fromPDim "๐‘–" (BV 1), @@ -77,18 +79,19 @@ tests = "PTerm โ†’ Term" :- [ ], "terms" :- - let fromPTerm' = fromPTermWith [< "๐‘–", "๐‘—"] [< "A", "x", "y", "z"] + let fromPTerm = runFromParser . + fromPTermWith [< "๐‘–", "๐‘—"] [< "A", "x", "y", "z"] in [ note "dim ctx: [๐‘–, ๐‘—]; term ctx: [A, x, y, z]", - parsesAs term fromPTerm' "x" $ BVT 2, - parseFails term fromPTerm' "๐‘–", - parsesAs term fromPTerm' "f" $ FT "f", - parsesAs term fromPTerm' "ฮป w โ‡’ w" $ [< "w"] :\\ BVT 0, - parsesAs term fromPTerm' "ฮป w โ‡’ x" $ [< "w"] :\\ BVT 3, - parsesAs term fromPTerm' "ฮป x โ‡’ x" $ [< "x"] :\\ BVT 0, - parsesAs term fromPTerm' "ฮป a b โ‡’ f a b" $ + parsesAs term fromPTerm "x" $ BVT 2, + parseFails term fromPTerm "๐‘–", + parsesAs term fromPTerm "f" $ FT "f", + parsesAs term fromPTerm "ฮป w โ‡’ w" $ [< "w"] :\\ BVT 0, + parsesAs term fromPTerm "ฮป w โ‡’ x" $ [< "w"] :\\ BVT 3, + parsesAs term fromPTerm "ฮป x โ‡’ x" $ [< "x"] :\\ BVT 0, + parsesAs term fromPTerm "ฮป a b โ‡’ f a b" $ [< "a", "b"] :\\ E (F "f" :@@ [BVT 1, BVT 0]), - parsesAs term fromPTerm' "f @๐‘–" $ + parsesAs term fromPTerm "f @๐‘–" $ E $ F "f" :% BV 1 ], diff --git a/tests/Tests/Typechecker.idr b/tests/Tests/Typechecker.idr index 7cdc972..deb04b7 100644 --- a/tests/Tests/Typechecker.idr +++ b/tests/Tests/Typechecker.idr @@ -5,6 +5,7 @@ import Quox.Syntax.Qty.Three import Quox.Typechecker as Lib import public TypingImpls import TAP +import Quox.EffExtra data Error' @@ -25,13 +26,10 @@ ToInfo Error' where ("wanted", prettyStr True bad)] 0 M : Type -> Type -M = ReaderT (Definitions Three) $ Either Error' +M = Eff [Except Error', DefsReader Three] -inj : (forall m. CanTC Three m => m a) -> M a -inj act = do - env <- ask - let res = runReaderT env act {m = Either (Typing.Error Three)} - either (throwError . TCError) pure res +inj : TC Three a -> M a +inj = rethrow . mapFst TCError <=< lift . runExcept reflTy : IsQty q => Term q d n @@ -92,10 +90,12 @@ defGlobals = fromList parameters (label : String) (act : Lazy (M ())) {default defGlobals globals : Definitions Three} testTC : Test - testTC = test label $ runReaderT globals act + testTC = test label {e = Error', a = ()} $ + extract $ runExcept $ runReader globals act testTCFail : Test - testTCFail = testThrows label (const True) $ runReaderT globals act $> "()" + testTCFail = testThrows label (const True) $ + (extract $ runExcept $ runReader globals act) $> "()" anys : {n : Nat} -> QContext Three n @@ -114,12 +114,10 @@ empty01 = eqDim (K Zero) (K One) empty inferredTypeEq : TyContext Three d n -> (exp, got : Term Three d n) -> M () inferredTypeEq ctx exp got = - catchError - (inj $ equalType ctx exp got) - (\_ : Error' => throwError $ WrongInfer exp got) + wrapErr (const $ WrongInfer exp got) $ inj $ equalType ctx exp got qoutEq : (exp, got : QOutput Three n) -> M () -qoutEq qout res = unless (qout == res) $ throwError $ WrongQOut qout res +qoutEq qout res = unless (qout == res) $ throw $ WrongQOut qout res inferAs : TyContext Three d n -> (sg : SQty Three) -> Elim Three d n -> Term Three d n -> M () @@ -395,7 +393,7 @@ tests = "typechecker" :- [ testTC "0 ยท โ„• โ‡ โ˜…โ‚‡" $ check_ empty szero Nat (TYPE 7), testTCFail "1 ยท โ„• โ‡ โ˜…โ‚€" $ check_ empty sone Nat (TYPE 0), testTC "1 ยท zero โ‡ โ„•" $ check_ empty sone Zero Nat, - testTC "1 ยท zero โ‡ โ„•ร—โ„•" $ check_ empty sone Zero (Nat `And` Nat), + testTCFail "1 ยท zero โ‡ โ„•ร—โ„•" $ check_ empty sone Zero (Nat `And` Nat), testTC "ฯ‰ยทn : โ„• โŠข 1 ยท succ n โ‡ โ„•" $ check_ (ctx [< ("n", Nat)]) sone (Succ (BVT 0)) Nat, testTC "1 ยท ฮป n โ‡’ succ n โ‡ 1.โ„• โ†’ โ„•" $ diff --git a/tests/quox-tests.ipkg b/tests/quox-tests.ipkg index 62766f0..0f576bb 100644 --- a/tests/quox-tests.ipkg +++ b/tests/quox-tests.ipkg @@ -1,6 +1,6 @@ package quox-tests -depends = base, contrib, elab-util, snocvect, quox-lib, tap +depends = base, contrib, elab-util, snocvect, quox-lib, tap, eff executable = quox-tests main = Tests