Add more complex param/table unit tests and pass them. Still fails on Phrasebook though.

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)

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>>

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"

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 ;
+}

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

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"
+    } ;
+}

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 ;
+}

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)

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"
+    } ;
+
+}