Grammar and languages to run in testsuite can be specified by command line options, see README

src/runtime/haskell/LPGF.hs

@@ -188,7 +188,7 @@ eval cxt t = case t of
     case (eval cxt t, eval cxt u) of
       (LFTuple vs, LFInt i) -> vs !! (i-1)
       (tp@(LFTuple _), LFTuple is) | all isInt is -> foldl (\(LFTuple vs) (LFInt i) -> vs !! (i-1)) tp is
-      (t',u') -> error $ printf "Incompatible projection:\n%s\n%s" (show t) (show u)
+      (t',u') -> error $ printf "Incompatible projection:\n- %s ~> %s\n- %s ~> %s" (show t) (show t') (show u) (show u')
   LFArgument i -> cxt !! (i-1)
   _ -> t
 

testsuite/lpgf/README.md

@@ -8,6 +8,15 @@ Possible exceptions:
 - No handling of variants (design choice)
 - Rendering of missing fucntions
 
+### Running
+
+```
+stack build --test --bench --no-run-tests --no-run-benchmarks
+stack test gf:test:lpgf # all LPGF tests
+stack test gf:test:lpgf --test-arguments="Params" # specific grammar
+stack test gf:test:lpgf --test-arguments="Foods Fre Ger" # specific grammar and languages
+```
+
 ## Benchmark
 
 ### Compilation

testsuite/lpgf/test.hs

@@ -8,35 +8,41 @@ 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.Environment (getArgs)
 import System.Directory (listDirectory)
 import System.FilePath ((</>), (<.>), takeBaseName, takeExtension, dropExtension)
+import Text.Printf (printf)
 
 dir :: FilePath
 dir = "testsuite" </> "lpgf"
 
 main :: IO ()
 main = do
-  doGrammar "Bind"
+  args <- getArgs
-  doGrammar "Tables"
+  case args of
-  doGrammar "Params"
+    [] -> do
-  doGrammar "Pre"
+      doGrammar "Bind"
-  doGrammar "Projection"
+      doGrammar "Tables"
-
+      doGrammar "Params"
-  doGrammar "Walking"
+      doGrammar "Pre"
-  doGrammar "Foods"
+      doGrammar "Projection"
-  -- doGrammar' "Foods" ["Fre"]
+      doGrammar "Walking"
+      doGrammar "Foods"
+    [absname] ->
+      doGrammar absname
+    absname:langs ->
+      doGrammar' absname langs
 
 doGrammar :: String -> IO ()
 doGrammar gname = doGrammar' gname []
 
 doGrammar' :: String -> [String] -> IO ()
 doGrammar' gname cncs = do
-  -- Collect concrete modules
+  -- Collect paths to concrete modules
   mods <- map (dir </>)
         . filter (\p -> gname `L.isPrefixOf` takeBaseName p
                         && takeExtension p == ".gf"
-                        && null cncs || any (`L.isSuffixOf` dropExtension p) cncs
+                        && (null cncs || any (`L.isSuffixOf` dropExtension p) cncs)
                   )
         <$> listDirectory dir
 
@@ -56,16 +62,19 @@ doGrammar' gname cncs = do
     let
       Just tree = readExpr ast
       -- Do some linearization
-      langs =
+      outs =
         [ printf "%s: %s" (showLanguage lang) (linearizeConcrete concr tree)
         | (lang,concr) <- Map.toList (concretes lpgf)
         ]
-    mapM_ putStrLn langs
+    mapM_ putStrLn outs
-    if langs == tail grp
+
+    -- filter out missing langs from treebank
+    let golds = [ g | o <- outs, g <- tail grp, takeWhile (/=':') o == takeWhile (/=':') g  ]
+    if outs == golds
     then putStrLn "✅\n"
     else do
       putStrLn "❌ expected:"
-      mapM_ putStrLn (tail grp)
+      mapM_ putStrLn golds
       putStrLn ""
       error "Test failed"