diff --git a/lib/Quox/Parser/Parser.idr b/lib/Quox/Parser/Parser.idr index c8b7192..b73044a 100644 --- a/lib/Quox/Parser/Parser.idr +++ b/lib/Quox/Parser/Parser.idr @@ -286,8 +286,66 @@ export universe1 : Grammar True Universe universe1 = universeTok <|> res "★" *> option 0 super -||| argument/atomic term: single-token terms, or those with delimiters e.g. -||| `[t]` + +public export +PCaseArm : Type +PCaseArm = (PCasePat, PTerm) + +export +caseArm : FileName -> Grammar True PCaseArm +caseArm fname = + [|(,) (casePat fname) (needRes "⇒" *> assert_total term fname)|] + +export +checkCaseArms : Loc -> List PCaseArm -> Grammar False PCaseBody +checkCaseArms loc [] = pure $ CaseEnum [] loc +checkCaseArms loc ((PPair x y _, rhs) :: rest) = + if null rest then pure $ CasePair (x, y) rhs loc + else fatalError "unexpected pattern after pair" +checkCaseArms loc ((PTag tag _, rhs1) :: rest) = do + let rest = for rest $ \case + (PTag tag _, rhs) => Just (tag, rhs) + _ => Nothing + maybe (fatalError "expected all patterns to be tags") + (\rest => pure $ CaseEnum ((tag, rhs1) :: rest) loc) rest +checkCaseArms loc ((PZero _, rhs1) :: rest) = do + let [(PSucc p q ih _, rhs2)] = rest + | _ => fatalError "expected succ pattern after zero" + pure $ CaseNat rhs1 (p, q, ih, rhs2) loc +checkCaseArms loc ((PSucc p q ih _, rhs1) :: rest) = do + let [(PZero _, rhs2)] = rest + | _ => fatalError "expected zero pattern after succ" + pure $ CaseNat rhs2 (p, q, ih, rhs1) loc +checkCaseArms loc ((PBox x _, rhs) :: rest) = + if null rest then pure $ CaseBox x rhs loc + else fatalError "unexpected pattern after box" + +export +caseBody : FileName -> Grammar True PCaseBody +caseBody fname = do + body <- bounds $ delimSep "{" "}" ";" $ caseArm fname + let loc = makeLoc fname body.bounds + checkCaseArms loc body.val + +export +caseReturn : FileName -> Grammar True (PatVar, PTerm) +caseReturn fname = do + x <- patVar fname <* resC "⇒" <|> unused fname + ret <- assert_total term fname + pure (x, ret) + +export +caseTerm : FileName -> Grammar True PTerm +caseTerm fname = withLoc fname $ do + qty <- caseIntro fname; commit + head <- mustWork $ assert_total term fname; needRes "return" + ret <- mustWork $ caseReturn fname; needRes "of" + body <- mustWork $ caseBody fname + pure $ Case qty head ret body + + +||| argument/atomic term: single-token terms, or those with delimiters +||| e.g. `[t]`. includes `case` because the end delimiter is the `}`. export termArg : FileName -> Grammar True PTerm termArg fname = withLoc fname $ @@ -302,6 +360,7 @@ termArg fname = withLoc fname $ <|> STRING <$ res "String" <|> [|Str strLit|] <|> [|V qname displacement|] + <|> const <$> caseTerm fname <|> const <$> tupleTerm fname export @@ -525,65 +584,12 @@ where makePi q doms cod loc = foldr (\(q, x, s), t => Pi q x s t loc) cod $ toDoms (toQty q) doms -public export -PCaseArm : Type -PCaseArm = (PCasePat, PTerm) + export -caseArm : FileName -> Grammar True PCaseArm -caseArm fname = - [|(,) (casePat fname) (needRes "⇒" *> assert_total term fname)|] - -export -checkCaseArms : Loc -> List PCaseArm -> Grammar False PCaseBody -checkCaseArms loc [] = pure $ CaseEnum [] loc -checkCaseArms loc ((PPair x y _, rhs) :: rest) = - if null rest then pure $ CasePair (x, y) rhs loc - else fatalError "unexpected pattern after pair" -checkCaseArms loc ((PTag tag _, rhs1) :: rest) = do - let rest = for rest $ \case - (PTag tag _, rhs) => Just (tag, rhs) - _ => Nothing - maybe (fatalError "expected all patterns to be tags") - (\rest => pure $ CaseEnum ((tag, rhs1) :: rest) loc) rest -checkCaseArms loc ((PZero _, rhs1) :: rest) = do - let [(PSucc p q ih _, rhs2)] = rest - | _ => fatalError "expected succ pattern after zero" - pure $ CaseNat rhs1 (p, q, ih, rhs2) loc -checkCaseArms loc ((PSucc p q ih _, rhs1) :: rest) = do - let [(PZero _, rhs2)] = rest - | _ => fatalError "expected zero pattern after succ" - pure $ CaseNat rhs2 (p, q, ih, rhs1) loc -checkCaseArms loc ((PBox x _, rhs) :: rest) = - if null rest then pure $ CaseBox x rhs loc - else fatalError "unexpected pattern after box" - -export -caseBody : FileName -> Grammar True PCaseBody -caseBody fname = do - body <- bounds $ delimSep "{" "}" ";" $ caseArm fname - let loc = makeLoc fname body.bounds - checkCaseArms loc body.val - -export -caseReturn : FileName -> Grammar True (PatVar, PTerm) -caseReturn fname = do - x <- patVar fname <* resC "⇒" <|> unused fname - ret <- assert_total term fname - pure (x, ret) - -export -caseTerm : FileName -> Grammar True PTerm -caseTerm fname = withLoc fname $ do - qty <- caseIntro fname; commit - head <- mustWork $ assert_total term fname; needRes "return" - ret <- mustWork $ caseReturn fname; needRes "of" - body <- mustWork $ caseBody fname - pure $ Case qty head ret body -- term : FileName -> Grammar True PTerm term fname = lamTerm fname - <|> caseTerm fname <|> piTerm fname <|> sigmaTerm fname diff --git a/tests/Tests/Parser.idr b/tests/Tests/Parser.idr index 26b327a..d27ee2b 100644 --- a/tests/Tests/Parser.idr +++ b/tests/Tests/Parser.idr @@ -400,7 +400,15 @@ tests = "parser" :- [ `(Case (PQ Any _) (V "n" {}) (Unused _, NAT _) (CaseNat (Nat 0 _) (Unused _, PQ One _, PV "ih" _, V "ih" {}) _) _), parseFails term "caseω n return A of { zero ⇒ a }", - parseFails term "caseω n return ℕ of { succ ⇒ 5 }" + parseFails term "caseω n return ℕ of { succ ⇒ 5 }", + parseMatch term + "case1 f s return x ⇒ A x of { (l, r) ⇒ r l } x" + `(App + (Case (PQ One _) (App (V "f" {}) (V "s" {}) _) + (PV "x" _, App (V "A" {}) (V "x" {}) _) + (CasePair (PV "l" _, PV "r" _) + (App (V "r" {}) (V "l" {}) _) _) _) + (V "x" {}) _) ], "definitions" :-