Generalise testsuite script to use treebank files, add FoodEng

src/runtime/haskell/LPGF.hs

@@ -153,5 +153,6 @@ lin2string :: LinFun -> String
 lin2string l = case l of
   LFEmpty -> ""
   LFToken tok -> tok
+  LFTuple [l] -> lin2string l
   LFConcat l1 l2 -> unwords [lin2string l1, lin2string l2]
   x -> printf "[%s]" (show x)

testsuite/lpgf/Foods.gf

@@ -0,0 +1,15 @@
+-- (c) 2009 Aarne Ranta under LGPL
+
+abstract Foods = {
+  flags startcat = Comment ;
+  cat
+    Comment ; Item ; Kind ; Quality ;
+  fun
+    Pred : Item -> Quality -> Comment ;
+    This, That, These, Those : Kind -> Item ;
+    Mod : Quality -> Kind -> Kind ;
+    Wine, Cheese, Fish, Pizza : Kind ;
+    Very : Quality -> Quality ;
+    Fresh, Warm, Italian, 
+      Expensive, Delicious, Boring : Quality ;
+}

testsuite/lpgf/Foods.trees

@@ -0,0 +1,29 @@
+Foods: Pred (This Pizza) (Very Boring)
+FoodsEng: this pizza is very boring
+
+Foods: Pred (That Pizza) Delicious
+FoodsEng: that pizza is delicious
+
+Foods: Pred (That Wine) Boring
+FoodsEng: that wine is boring
+
+Foods: Pred (This Cheese) Fresh
+FoodsEng: this cheese is fresh
+
+Foods: Pred (Those Fish) Boring
+FoodsEng: those fish are boring
+
+Foods: Pred (This Cheese) Warm
+FoodsEng: this cheese is warm
+
+Foods: Pred (That (Mod Boring (Mod Italian Pizza))) Italian
+FoodsEng: that boring Italian pizza is Italian
+
+Foods: Pred (Those Cheese) Expensive
+FoodsEng: those cheeses are expensive
+
+Foods: Pred (Those Wine) Italian
+FoodsEng: those wines are Italian
+
+Foods: Pred (This Wine) Boring
+FoodsEng: this wine is boring

testsuite/lpgf/FoodsEng.gf

@@ -0,0 +1,43 @@
+-- (c) 2009 Aarne Ranta under LGPL
+
+concrete FoodsEng of Foods = {
+  flags language = en_US;
+  lincat
+    Comment, Quality = {s : Str} ; 
+    Kind = {s : Number => Str} ; 
+    Item = {s : Str ; n : Number} ; 
+  lin
+    Pred item quality = 
+      {s = item.s ++ copula ! item.n ++ quality.s} ;
+    This  = det Sg "this" ;
+    That  = det Sg "that" ;
+    These = det Pl "these" ;
+    Those = det Pl "those" ;
+    Mod quality kind = 
+      {s = \\n => quality.s ++ kind.s ! n} ;
+    Wine = regNoun "wine" ;
+    Cheese = regNoun "cheese" ;
+    Fish = noun "fish" "fish" ;
+    Pizza = regNoun "pizza" ;
+    Very a = {s = "very" ++ a.s} ;
+    Fresh = adj "fresh" ;
+    Warm = adj "warm" ;
+    Italian = adj "Italian" ;
+    Expensive = adj "expensive" ;
+    Delicious = adj "delicious" ;
+    Boring = adj "boring" ;
+  param
+    Number = Sg | Pl ;
+  oper
+    det : Number -> Str -> 
+      {s : Number => Str} -> {s : Str ; n : Number} = 
+        \n,det,noun -> {s = det ++ noun.s ! n ; n = n} ;
+    noun : Str -> Str -> {s : Number => Str} = 
+      \man,men -> {s = table {Sg => man ; Pl => men}} ;
+    regNoun : Str -> {s : Number => Str} = 
+      \car -> noun car (car + "s") ;
+    adj : Str -> {s : Str} = 
+      \cold -> {s = cold} ;
+    copula : Number => Str = 
+      table {Sg => "is" ; Pl => "are"} ;
+}

testsuite/lpgf/Walking.hs

@@ -0,0 +1,72 @@
+import LPGF
+import PGF (Tree, mkCId, mkApp)
+
+import qualified Data.Map as Map
+
+main = return ()
+
+-- Pred John Walk
+tree1 :: Tree
+tree1 = mkApp (mkCId "Pred") [mkApp (mkCId "John") [], mkApp (mkCId "Walk") []]
+
+-- Pred We Walk
+tree2 :: Tree
+tree2 = mkApp (mkCId "Pred") [mkApp (mkCId "We") [], mkApp (mkCId "Walk") []]
+
+-- And (Pred John Walk) (Pred We Walk)
+tree3 :: Tree
+tree3 = mkApp (mkCId "And") [tree1, tree2]
+
+-- Initial LPGF, Figures 6 & 7
+walking :: LPGF
+walking = LPGF {
+  absname = mkCId "Walking",
+  abstract = Abstr {
+    -- cats = Map.fromList [
+    --   (mkCId "S", ()),
+    --   (mkCId "NP", ()),
+    --   (mkCId "VP", ())
+    -- ],
+    -- funs = Map.fromList [
+    --   (mkCId "And", Type [mkCId "S", mkCId "S"] (mkCId "S")),
+    --   (mkCId "Pred", Type [mkCId "NP", mkCId "VP"] (mkCId "S")),
+    --   (mkCId "John", Type [] (mkCId "NP")),
+    --   (mkCId "We", Type [] (mkCId "NP")),
+    --   (mkCId "Walk", Type [] (mkCId "VP"))
+    -- ]
+  },
+  concretes = Map.fromList [
+    (mkCId "WalkingEng", Concr {
+      -- lincats = Map.fromList [
+      --   (mkCId "S", LTStr),
+      --   (mkCId "NP", LTProduct [LTStr, LTInt 2]),
+      --   (mkCId "VP", LTProduct [LTStr, LTStr])
+      -- ],
+      lins = Map.fromList [
+        (mkCId "And", mkConcat [LFArgument 1, LFToken "and", LFArgument 2]),
+        -- (mkCId "Pred", mkConcat [LFProjection (LFArgument 1) (LFInt 1), LFProjection (LFArgument 2) (LFProjection (LFArgument 1) (LFInt 2))]),
+        (mkCId "Pred", mkConcat [LFProjection (LFArgument 1) (LFInt 1), LFProjection (LFProjection (LFArgument 2) (LFInt 1)) (LFProjection (LFArgument 1) (LFInt 2))]),
+        (mkCId "John", LFTuple [LFToken "John", LFInt 1]),
+        (mkCId "We", LFTuple [LFToken "we", LFInt 2]),
+        -- (mkCId "Walk", LFTuple [LFToken "walks", LFToken "walk"])
+        (mkCId "Walk", LFTuple [LFTuple [LFToken "walks", LFToken "walk"]])
+      ]
+    }),
+    (mkCId "WalkingGer", Concr {
+      -- lincats = Map.fromList [
+      --   (mkCId "S", LTStr),
+      --   (mkCId "NP", LTProduct [LTStr, LTInt 2, LTInt 3]),
+      --   (mkCId "VP", LTProduct [LTProduct [LTStr, LTStr, LTStr], LTProduct [LTStr, LTStr, LTStr]])
+      -- ],
+      lins = Map.fromList [
+        (mkCId "And", mkConcat [LFArgument 1, LFToken "und", LFArgument 2]),
+        -- (mkCId "Pred", mkConcat [LFProjection (LFArgument 1) (LFInt 1), LFProjection (LFProjection (LFArgument 2) (LFProjection (LFArgument 1) (LFInt 2))) (LFProjection (LFArgument 1) (LFInt 3))]),
+        (mkCId "Pred", mkConcat [LFProjection (LFArgument 1) (LFInt 1), LFProjection (LFProjection (LFProjection (LFArgument 2) (LFInt 1)) (LFProjection (LFArgument 1) (LFInt 2))) (LFProjection (LFArgument 1) (LFInt 3))]),
+        (mkCId "John", LFTuple [LFToken "John", LFInt 1, LFInt 3]),
+        (mkCId "We", LFTuple [LFToken "wir", LFInt 2, LFInt 1]),
+        -- (mkCId "Walk", LFTuple [LFTuple [LFToken "gehe", LFToken "gehst", LFToken "geht"], LFTuple [LFToken "gehen", LFToken "geht", LFToken "gehen"]])
+        (mkCId "Walk", LFTuple [LFTuple [LFTuple [LFToken "gehe", LFToken "gehst", LFToken "geht"], LFTuple [LFToken "gehen", LFToken "geht", LFToken "gehen"]]])
+      ]
+    })
+  ]
+}

testsuite/lpgf/Walking.trees

@@ -0,0 +1,11 @@
+Walking: Pred John Walk
+WalkingEng: John walks
+WalkingGer: John geht
+
+Walking: Pred We Walk
+WalkingEng: we walk
+WalkingGer: wir gehen
+
+Walking: And (Pred John Walk) (Pred We Walk)
+WalkingEng: John walks and we walk
+WalkingGer: John geht und wir gehen

testsuite/lpgf/run.hs

@@ -1,90 +1,59 @@
 import LPGF
-import PGF (Tree, mkCId, mkApp, showLanguage, showExpr)
+import PGF (showLanguage, readExpr)
 import GF (compileToLPGF, writeLPGF)
 import GF.Support (noOptions)
 
 import Control.Monad (forM_)
+import qualified Data.List as L
 import qualified Data.Map as Map
 import Text.Printf (printf)
+import System.Directory (listDirectory)
+import System.FilePath ((</>), (<.>), takeBaseName, takeExtension)
+
+dir :: FilePath
+dir = "testsuite" </> "lpgf"
 
 main :: IO ()
 main = do
+  doGrammar "Walking"
+  doGrammar "Foods"
+
+doGrammar :: String -> IO ()
+doGrammar gname = do
+  -- Collect concrete modules
+  mods <- map (dir </>)
+        . filter (\p -> gname `L.isPrefixOf` takeBaseName p && takeExtension p == ".gf")
+        <$> listDirectory dir
+
   -- Compile LPGF
-  lpgf <- compileToLPGF noOptions ["testsuite/lpgf/WalkingEng.gf", "testsuite/lpgf/WalkingGer.gf"]
+  lpgf <- compileToLPGF noOptions mods
   writeLPGF noOptions lpgf
+  putStrLn ""
 
   -- Read back from file
-  lpgf <- readLPGF "Walking.lpgf"
+  lpgf <- readLPGF $ gname ++ ".lpgf"
 
-  -- Do some linearization
+  -- Read treebank
-  forM_ [tree1, tree2, tree3] $ \tree -> do
+  gs <- groups . lines <$> readFile (dir </> gname <.> "trees")
-    putStrLn ""
+  forM_ gs $ \grp -> do
-    putStrLn (showExpr [] tree)
+    let ast = drop 2 $ dropWhile (/=':') $ head grp
-    forM_ (Map.toList (concretes lpgf)) $ \(lang,concr) ->
+    printf "%s: %s\n" gname ast
-      printf "%s: %s\n" (showLanguage lang) (linearizeConcr concr tree)
+    let
+      Just tree = readExpr ast
+    -- Do some linearization
+      langs =
+        [ printf "%s: %s" (showLanguage lang) (linearizeConcr concr tree)
+        | (lang,concr) <- Map.toList (concretes lpgf)
+        ]
+    mapM_ putStrLn langs
+    if langs == tail grp
+    then putStrLn "✅\n"
+    else do
+      putStrLn "❌ expected:"
+      mapM_ putStrLn (tail grp)
+      putStrLn ""
+      error "Test failed"
 
--- Pred John Walk
+groups :: [String] -> [[String]]
-tree1 :: Tree
+groups [] = []
-tree1 = mkApp (mkCId "Pred") [mkApp (mkCId "John") [], mkApp (mkCId "Walk") []]
+groups ss = let (a,b) = break (=="") ss in a : groups (drop 1 b)
-
--- Pred We Walk
-tree2 :: Tree
-tree2 = mkApp (mkCId "Pred") [mkApp (mkCId "We") [], mkApp (mkCId "Walk") []]
-
--- And (Pred John Walk) (Pred We Walk)
-tree3 :: Tree
-tree3 = mkApp (mkCId "And") [tree1, tree2]
-
--- Initial LPGF, Figures 6 & 7
-walking :: LPGF
-walking = LPGF {
-  absname = mkCId "Walking",
-  abstract = Abstr {
-    -- cats = Map.fromList [
-    --   (mkCId "S", ()),
-    --   (mkCId "NP", ()),
-    --   (mkCId "VP", ())
-    -- ],
-    -- funs = Map.fromList [
-    --   (mkCId "And", Type [mkCId "S", mkCId "S"] (mkCId "S")),
-    --   (mkCId "Pred", Type [mkCId "NP", mkCId "VP"] (mkCId "S")),
-    --   (mkCId "John", Type [] (mkCId "NP")),
-    --   (mkCId "We", Type [] (mkCId "NP")),
-    --   (mkCId "Walk", Type [] (mkCId "VP"))
-    -- ]
-  },
-  concretes = Map.fromList [
-    (mkCId "WalkingEng", Concr {
-      -- lincats = Map.fromList [
-      --   (mkCId "S", LTStr),
-      --   (mkCId "NP", LTProduct [LTStr, LTInt 2]),
-      --   (mkCId "VP", LTProduct [LTStr, LTStr])
-      -- ],
-      lins = Map.fromList [
-        (mkCId "And", mkConcat [LFArgument 1, LFToken "and", LFArgument 2]),
-        -- (mkCId "Pred", mkConcat [LFProjection (LFArgument 1) (LFInt 1), LFProjection (LFArgument 2) (LFProjection (LFArgument 1) (LFInt 2))]),
-        (mkCId "Pred", mkConcat [LFProjection (LFArgument 1) (LFInt 1), LFProjection (LFProjection (LFArgument 2) (LFInt 1)) (LFProjection (LFArgument 1) (LFInt 2))]),
-        (mkCId "John", LFTuple [LFToken "John", LFInt 1]),
-        (mkCId "We", LFTuple [LFToken "we", LFInt 2]),
-        -- (mkCId "Walk", LFTuple [LFToken "walks", LFToken "walk"])
-        (mkCId "Walk", LFTuple [LFTuple [LFToken "walks", LFToken "walk"]])
-      ]
-    }),
-    (mkCId "WalkingGer", Concr {
-      -- lincats = Map.fromList [
-      --   (mkCId "S", LTStr),
-      --   (mkCId "NP", LTProduct [LTStr, LTInt 2, LTInt 3]),
-      --   (mkCId "VP", LTProduct [LTProduct [LTStr, LTStr, LTStr], LTProduct [LTStr, LTStr, LTStr]])
-      -- ],
-      lins = Map.fromList [
-        (mkCId "And", mkConcat [LFArgument 1, LFToken "und", LFArgument 2]),
-        -- (mkCId "Pred", mkConcat [LFProjection (LFArgument 1) (LFInt 1), LFProjection (LFProjection (LFArgument 2) (LFProjection (LFArgument 1) (LFInt 2))) (LFProjection (LFArgument 1) (LFInt 3))]),
-        (mkCId "Pred", mkConcat [LFProjection (LFArgument 1) (LFInt 1), LFProjection (LFProjection (LFProjection (LFArgument 2) (LFInt 1)) (LFProjection (LFArgument 1) (LFInt 2))) (LFProjection (LFArgument 1) (LFInt 3))]),
-        (mkCId "John", LFTuple [LFToken "John", LFInt 1, LFInt 3]),
-        (mkCId "We", LFTuple [LFToken "wir", LFInt 2, LFInt 1]),
-        -- (mkCId "Walk", LFTuple [LFTuple [LFToken "gehe", LFToken "gehst", LFToken "geht"], LFTuple [LFToken "gehen", LFToken "geht", LFToken "gehen"]])
-        (mkCId "Walk", LFTuple [LFTuple [LFTuple [LFToken "gehe", LFToken "gehst", LFToken "geht"], LFTuple [LFToken "gehen", LFToken "geht", LFToken "gehen"]]])
-      ]
-    })
-  ]
-}