From f5886bf4479a5dfd8654d04e70178cc7836f338a Mon Sep 17 00:00:00 2001 From: "John J. Camilleri" Date: Thu, 4 Mar 2021 12:37:12 +0100 Subject: [PATCH] Add more complex param/table unit tests and pass them. Still fails on Phrasebook though. --- src/compiler/GF/Compile/GrammarToLPGF.hs | 21 ++++-- testsuite/lpgf/README.md | 59 ++++++++++++---- testsuite/lpgf/test.hs | 2 + testsuite/lpgf/unittests/Params4.gf | 20 ++++++ testsuite/lpgf/unittests/Params4.treebank | 44 ++++++++++++ testsuite/lpgf/unittests/Params4Cnc.gf | 61 +++++++++++++++++ testsuite/lpgf/unittests/Params5.gf | 19 ++++++ testsuite/lpgf/unittests/Params5.treebank | 83 +++++++++++++++++++++++ testsuite/lpgf/unittests/Params5Cnc.gf | 72 ++++++++++++++++++++ 9 files changed, 364 insertions(+), 17 deletions(-) create mode 100644 testsuite/lpgf/unittests/Params4.gf create mode 100644 testsuite/lpgf/unittests/Params4.treebank create mode 100644 testsuite/lpgf/unittests/Params4Cnc.gf create mode 100644 testsuite/lpgf/unittests/Params5.gf create mode 100644 testsuite/lpgf/unittests/Params5.treebank create mode 100644 testsuite/lpgf/unittests/Params5Cnc.gf diff --git a/src/compiler/GF/Compile/GrammarToLPGF.hs b/src/compiler/GF/Compile/GrammarToLPGF.hs index b96e553dd..0a4a93ff9 100644 --- a/src/compiler/GF/Compile/GrammarToLPGF.hs +++ b/src/compiler/GF/Compile/GrammarToLPGF.hs @@ -157,10 +157,23 @@ mkCanon2lpgf opts gr am = do go :: [C.TableRowValue] -> Either String (L.LinFun, Maybe C.LinType) go [C.TableRow _ lv] = val2lin lv go trvs = do - let grps = L.groupBy (\(C.TableRow (C.RecordPattern rps1) _) (C.TableRow (C.RecordPattern rps2) _) -> head rps1 == head rps2) trvs - -- ts <- mapM (go . map (\(C.TableRow (C.RecordPattern rps) lv) -> C.TableRow (C.RecordPattern (tail rps)) lv)) grps + let grps = flip L.groupBy trvs $ \tr1 tr2 -> + let + C.TableRow (C.RecordPattern (C.RecordRow lid1 (C.ParamPattern (C.Param pid1 _)):_)) _ = tr1 + C.TableRow (C.RecordPattern (C.RecordRow lid2 (C.ParamPattern (C.Param pid2 _)):_)) _ = tr2 + in lid1 == lid2 && pid1 == pid2 ts <- forM grps $ \grp -> - go $ map (\(C.TableRow (C.RecordPattern rps) lv) -> C.TableRow (C.RecordPattern (tail rps)) lv) grp + go =<< forM grp (\row -> + case row of + C.TableRow (C.RecordPattern []) lv -> return row + C.TableRow (C.RecordPattern (C.RecordRow _ (C.ParamPattern (C.Param _ [])):rrs)) lv -> return $ C.TableRow (C.RecordPattern rrs) lv + C.TableRow (C.RecordPattern rrs) lv -> return $ C.TableRow (C.RecordPattern rrs') lv + where + C.RecordRow lid (C.ParamPattern (C.Param pid patts)) = head rrs + C.ParamPattern (C.Param pid2 patts2) = head patts + rrs' = C.RecordRow lid (C.ParamPattern (C.Param pid2 (patts2 ++ tail patts))) : tail rrs + _ -> Left $ printf "Unhandled table row: %s" (show row) + ) let typ = case ts of (_, Just tst):_ -> Just $ C.TableType lt tst _ -> Nothing @@ -231,7 +244,7 @@ mkCanon2lpgf opts gr am = do -- C.CommentedValue cmnt lv -> val2lin lv C.CommentedValue cmnt lv -> case cmnt of - "impossible" -> val2lin lv >>= \(_, typ) -> return (L.Empty, typ) -- TODO untested optimisation + "impossible" -> val2lin lv >>= \(_, typ) -> return (L.Empty, typ) _ -> val2lin lv v -> Left $ printf "val2lin not implemented for: %s" (show v) diff --git a/testsuite/lpgf/README.md b/testsuite/lpgf/README.md index cad885b0b..02611d25d 100644 --- a/testsuite/lpgf/README.md +++ b/testsuite/lpgf/README.md @@ -17,6 +17,10 @@ stack test gf:test:lpgf --test-arguments="unittests/Params" # specific grammar stack test gf:test:lpgf --test-arguments="foods/Foods Fre Ger" # specific grammar and languages ``` +``` +stack build --test --bench --no-run-tests --no-run-benchmarks && DEBUG=1 stack test gf:test:lpgf --test-arguments="foods/Foods Fre Ger" +``` + Set environment variable `DEBUG=1` to enable dumping of intermediate formats. ## Benchmark @@ -55,15 +59,16 @@ stack bench --benchmark-arguments "run lpgf Foods.lpgf testsuite/lpgf/foods/Food # Notes on compilation -## 1 +## 1 (see unittests/Params4) -param defns - P = P1 | P2 - Q = Q1 | Q2 - R = RP P | RPQ P Q | R0 - X = XPQ P Q +**param defns** +P = P1 | P2 +Q = Q1 | Q2 +R = RP P | RPQ P Q | R0 +X = XPQ P Q -translation (NB: tuples may be listed, but will be concatted at runtime) +**translation** +NB: tuples may be nested, but will be concatted at runtime P1 = <1> P2 = <2> @@ -110,14 +115,15 @@ X => Str {p=P2 ; r1=RP P1 ; r2=RPQ P1 Q2 ; r3=R0 } < <2> , <1, 1> , <2, 1, 2> , <3>> -## 2 +## 2 (see unittests/Params5) -param defns - P = P1 | PQ Q - Q = Q1 | QR R - R = R1 | R2 +**param defns** -translation +P = P1 | PQ Q +Q = Q1 | QR R +R = R1 | R2 + +**translation** P1 = <1> PQ Q1 = <2,1> @@ -156,3 +162,30 @@ P => Str {q=QR R2 ; p=PQ Q1} = <<2,2>,<2,1>> {q=QR R2 ; p=PQ (QR R1)} = <<2,2>,<2,2,1>> {q=QR R2 ; p=PQ (QR R2)} = <<2,2>,<2,2,2>> + +**NOTE**: GF will swap q and p in record, as part of record field sorting, resulting in the following: + +{p:P ; q:Q} => Str +< <"P1;Q1", <"P1;QR R1","P1;QR R2">>, + < <"PQ Q1;Q1", <"PQ Q1;QR R1","PQ Q1;QR R2">>, + < <"PQ (QR R1);Q1", <"PQ (QR R1);QR R1","PQ (QR R1);QR R2">>, + <"PQ (QR R2);Q1", <"PQ (QR R2);QR R1","PQ (QR R2);QR R2">> + > + > +> + +{p=P1 ; q=Q1} = <<1>,<1>> +{p=P1 ; q=QR R1} = <<1>,<2,1>> +{p=P1 ; q=QR R2} = <<1>,<2,2>> + +{p=PQ Q1 ; q=Q1} = <<2,1>,<1>> +{p=PQ Q1 ; q=QR R1} = <<2,1>,<2,1>> +{p=PQ Q1 ; q=QR R2} = <<2,1>,<2,2>> + +{p=PQ (QR R1) ; q=Q1} = <<2,2,1>,<1>> +{p=PQ (QR R1) ; q=QR R1} = <<2,2,1>,<2,1>> +{p=PQ (QR R1) ; q=QR R2} = <<2,2,1>,<2,2>> + +{p=PQ (QR R2) ; q=Q1} = <<2,2,2>,<1>> +{p=PQ (QR R2) ; q=QR R1} = <<2,2,2>,<2,1>> +{p=PQ (QR R2) ; q=QR R2} = <<2,2,2>,<2,2>> diff --git a/testsuite/lpgf/test.hs b/testsuite/lpgf/test.hs index 609dc537b..404cfe1f8 100644 --- a/testsuite/lpgf/test.hs +++ b/testsuite/lpgf/test.hs @@ -28,6 +28,8 @@ main = do doGrammar "unittests" "Params1" doGrammar "unittests" "Params2" doGrammar "unittests" "Params3" + doGrammar "unittests" "Params4" + doGrammar "unittests" "Params5" doGrammar "unittests" "Pre" doGrammar "unittests" "Projection" doGrammar "unittests" "Tables" diff --git a/testsuite/lpgf/unittests/Params4.gf b/testsuite/lpgf/unittests/Params4.gf new file mode 100644 index 000000000..7d572117f --- /dev/null +++ b/testsuite/lpgf/unittests/Params4.gf @@ -0,0 +1,20 @@ +abstract Params4 = { + cat + P_ ; + Q_ ; + S ; + + fun + p1 : P_ ; + p2 : P_ ; + q1 : Q_ ; + q2 : Q_ ; + + pqrec : P_ -> Q_ -> S ; + + rp : P_ -> S ; + rpq : P_ -> Q_ -> S ; + r0 : S ; + + xpq : P_ -> Q_ -> S ; +} diff --git a/testsuite/lpgf/unittests/Params4.treebank b/testsuite/lpgf/unittests/Params4.treebank new file mode 100644 index 000000000..c91c2bb08 --- /dev/null +++ b/testsuite/lpgf/unittests/Params4.treebank @@ -0,0 +1,44 @@ +Params4: pqrec p1 q1 +Params4Cnc: P1 ; Q1 + +Params4: pqrec p1 q2 +Params4Cnc: P1 ; Q2 + +Params4: pqrec p2 q1 +Params4Cnc: P2 ; Q1 + +Params4: pqrec p2 q2 +Params4Cnc: P2 ; Q2 + +Params4: r0 +Params4Cnc: R0 + +Params4: rp p1 +Params4Cnc: RP P1 + +Params4: rp p2 +Params4Cnc: RP P2 + +Params4: rpq p1 q1 +Params4Cnc: RPQ P1 Q1 + +Params4: rpq p1 q2 +Params4Cnc: RPQ P1 Q2 + +Params4: rpq p2 q1 +Params4Cnc: RPQ P2 Q1 + +Params4: rpq p2 q2 +Params4Cnc: RPQ P2 Q2 + +Params4: xpq p1 q1 +Params4Cnc: XPQ P1 Q1 + +Params4: xpq p1 q2 +Params4Cnc: XPQ P1 Q2 + +Params4: xpq p2 q1 +Params4Cnc: XPQ P2 Q1 + +Params4: xpq p2 q2 +Params4Cnc: XPQ P2 Q2 diff --git a/testsuite/lpgf/unittests/Params4Cnc.gf b/testsuite/lpgf/unittests/Params4Cnc.gf new file mode 100644 index 000000000..b015172ef --- /dev/null +++ b/testsuite/lpgf/unittests/Params4Cnc.gf @@ -0,0 +1,61 @@ +concrete Params4Cnc of Params4 = { + + param + P = P1 | P2 ; + Q = Q1 | Q2 ; + R = RP P | RPQ P Q | R0 ; + X = XPQ P Q ; + + lincat + P_ = P ; + Q_ = Q ; + S = Str ; + + lin + p1 = P1 ; + p2 = P2 ; + q1 = Q1 ; + q2 = Q2 ; + + pqrec p q = tblPQRec ! { p = p ; q = q } ; + + rp p = tblR ! RP p ; + rpq p q = tblR ! RPQ p q ; + r0 = tblR ! R0 ; + + xpq p q = tblX ! XPQ p q ; + + oper + tblP : P => Str ; + tblP = table { + P1 => "P1"; + P2 => "P2" + } ; + + tblPQRec : {p:P; q:Q} => Str ; + tblPQRec = table { + {p=P1; q=Q1} => "P1 ; Q1"; + {p=P1; q=Q2} => "P1 ; Q2"; + {p=P2; q=Q1} => "P2 ; Q1"; + {p=P2; q=Q2} => "P2 ; Q2" + } ; + + tblR : R => Str ; + tblR = table { + RP P1 => "RP P1"; + RP P2 => "RP P2"; + RPQ P1 Q1 => "RPQ P1 Q1"; + RPQ P1 Q2 => "RPQ P1 Q2"; + RPQ P2 Q1 => "RPQ P2 Q1"; + RPQ P2 Q2 => "RPQ P2 Q2"; + R0 => "R0" + } ; + + tblX : X => Str ; + tblX = table { + XPQ P1 Q1 => "XPQ P1 Q1"; + XPQ P1 Q2 => "XPQ P1 Q2"; + XPQ P2 Q1 => "XPQ P2 Q1"; + XPQ P2 Q2 => "XPQ P2 Q2" + } ; +} diff --git a/testsuite/lpgf/unittests/Params5.gf b/testsuite/lpgf/unittests/Params5.gf new file mode 100644 index 000000000..968d15de9 --- /dev/null +++ b/testsuite/lpgf/unittests/Params5.gf @@ -0,0 +1,19 @@ +abstract Params5 = { + cat + P_ ; + Q_ ; + R_ ; + S ; + + fun + p1 : P_ ; + pq : Q_ -> P_ ; + q1 : Q_ ; + qr : R_ -> Q_ ; + r1 : R_ ; + r2 : R_ ; + + showP : P_ -> S ; + showPQ : P_ -> Q_ -> S ; + showQP : Q_ -> P_ -> S ; +} diff --git a/testsuite/lpgf/unittests/Params5.treebank b/testsuite/lpgf/unittests/Params5.treebank new file mode 100644 index 000000000..829bb8fd9 --- /dev/null +++ b/testsuite/lpgf/unittests/Params5.treebank @@ -0,0 +1,83 @@ +Params5: showP p1 +Params5Cnc: P1 + +Params5: showP (pq q1) +Params5Cnc: PQ Q1 + +Params5: showP (pq (qr r1)) +Params5Cnc: PQ (QR R1) + +Params5: showP (pq (qr r2)) +Params5Cnc: PQ (QR R2) + +Params5: showPQ p1 q1 +Params5Cnc: P1 ; Q1 + +Params5: showPQ p1 (qr r1) +Params5Cnc: P1 ; QR R1 + +Params5: showPQ p1 (qr r2) +Params5Cnc: P1 ; QR R2 + +Params5: showPQ (pq q1) q1 +Params5Cnc: PQ Q1 ; Q1 + +Params5: showPQ (pq q1) (qr r1) +Params5Cnc: PQ Q1 ; QR R1 + +Params5: showPQ (pq q1) (qr r2) +Params5Cnc: PQ Q1 ; QR R2 + +Params5: showPQ (pq (qr r1)) q1 +Params5Cnc: PQ (QR R1) ; Q1 + +Params5: showPQ (pq (qr r1)) (qr r1) +Params5Cnc: PQ (QR R1) ; QR R1 + +Params5: showPQ (pq (qr r1)) (qr r2) +Params5Cnc: PQ (QR R1) ; QR R2 + +Params5: showPQ (pq (qr r2)) q1 +Params5Cnc: PQ (QR R2) ; Q1 + +Params5: showPQ (pq (qr r2)) (qr r1) +Params5Cnc: PQ (QR R2) ; QR R1 + +Params5: showPQ (pq (qr r2)) (qr r2) +Params5Cnc: PQ (QR R2) ; QR R2 + +Params5: showQP q1 p1 +Params5Cnc: Q1 ; P1 + +Params5: showQP q1 (pq q1) +Params5Cnc: Q1 ; PQ Q1 + +Params5: showQP q1 (pq (qr r1)) +Params5Cnc: Q1 ; PQ (QR R1) + +Params5: showQP q1 (pq (qr r2)) +Params5Cnc: Q1 ; PQ (QR R2) + +Params5: showQP (qr r1) p1 +Params5Cnc: QR R1 ; P1 + +Params5: showQP (qr r1) (pq q1) +Params5Cnc: QR R1 ; PQ Q1 + +Params5: showQP (qr r1) (pq (qr r1)) +Params5Cnc: QR R1 ; PQ (QR R1) + +Params5: showQP (qr r1) (pq (qr r2)) +Params5Cnc: QR R1 ; PQ (QR R2) + +Params5: showQP (qr r2) p1 +Params5Cnc: QR R2 ; P1 + +Params5: showQP (qr r2) (pq q1) +Params5Cnc: QR R2 ; PQ Q1 + +Params5: showQP (qr r2) (pq (qr r1)) +Params5Cnc: QR R2 ; PQ (QR R1) + +Params5: showQP (qr r2) (pq (qr r2)) +Params5Cnc: QR R2 ; PQ (QR R2) diff --git a/testsuite/lpgf/unittests/Params5Cnc.gf b/testsuite/lpgf/unittests/Params5Cnc.gf new file mode 100644 index 000000000..ff7400819 --- /dev/null +++ b/testsuite/lpgf/unittests/Params5Cnc.gf @@ -0,0 +1,72 @@ +concrete Params5Cnc of Params5 = { + + param + P = P1 | PQ Q ; + Q = Q1 | QR R ; + R = R1 | R2 ; + + lincat + P_ = P ; + Q_ = Q ; + R_ = R ; + S = Str ; + + lin + p1 = P1 ; + pq q = PQ q ; + q1 = Q1 ; + qr r = QR r ; + r1 = R1 ; + r2 = R2 ; + + showP p = tblP ! p ; + showPQ p q = tblPQRec ! { p = p ; q = q } ; + showQP q p = tblQPRec ! { q = q ; p = p } ; + + oper + tblP : P => Str ; + tblP = table { + P1 => "P1"; + PQ Q1 => "PQ Q1"; + PQ (QR R1) => "PQ (QR R1)"; + PQ (QR R2) => "PQ (QR R2)" + } ; + + tblQPRec : {q:Q ; p:P} => Str ; + tblQPRec = table { + {q=Q1 ; p=P1} => "Q1 ; P1"; + {q=Q1 ; p=PQ Q1} => "Q1 ; PQ Q1"; + {q=Q1 ; p=PQ (QR R1)} => "Q1 ; PQ (QR R1)"; + {q=Q1 ; p=PQ (QR R2)} => "Q1 ; PQ (QR R2)"; + + {q=QR R1 ; p=P1} => "QR R1 ; P1"; + {q=QR R1 ; p=PQ Q1} => "QR R1 ; PQ Q1"; + {q=QR R1 ; p=PQ (QR R1)} => "QR R1 ; PQ (QR R1)"; + {q=QR R1 ; p=PQ (QR R2)} => "QR R1 ; PQ (QR R2)"; + + {q=QR R2 ; p=P1} => "QR R2 ; P1"; + {q=QR R2 ; p=PQ Q1} => "QR R2 ; PQ Q1"; + {q=QR R2 ; p=PQ (QR R1)} => "QR R2 ; PQ (QR R1)"; + {q=QR R2 ; p=PQ (QR R2)} => "QR R2 ; PQ (QR R2)" + } ; + + tblPQRec : {p:P ; q:Q} => Str ; + tblPQRec = table { + {p=P1 ; q=Q1} => "P1 ; Q1"; + {p=P1 ; q=QR R1} => "P1 ; QR R1"; + {p=P1 ; q=QR R2} => "P1 ; QR R2"; + + {p=PQ Q1 ; q=Q1} => "PQ Q1 ; Q1"; + {p=PQ Q1 ; q=QR R1} => "PQ Q1 ; QR R1"; + {p=PQ Q1 ; q=QR R2} => "PQ Q1 ; QR R2"; + + {p=PQ (QR R1) ; q=Q1} => "PQ (QR R1) ; Q1"; + {p=PQ (QR R1) ; q=QR R1} => "PQ (QR R1) ; QR R1"; + {p=PQ (QR R1) ; q=QR R2} => "PQ (QR R1) ; QR R2"; + + {p=PQ (QR R2) ; q=Q1} => "PQ (QR R2) ; Q1"; + {p=PQ (QR R2) ; q=QR R1} => "PQ (QR R2) ; QR R1"; + {p=PQ (QR R2) ; q=QR R2} => "PQ (QR R2) ; QR R2" + } ; + +}