diff --git a/src/runtime/haskell/LPGF.hs b/src/runtime/haskell/LPGF.hs index 92432b00e..6470727dc 100644 --- a/src/runtime/haskell/LPGF.hs +++ b/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 diff --git a/testsuite/lpgf/README.md b/testsuite/lpgf/README.md index 8ce550e90..c4b9842ae 100644 --- a/testsuite/lpgf/README.md +++ b/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 diff --git a/testsuite/lpgf/test.hs b/testsuite/lpgf/test.hs index 3bb607f81..2de232c98 100644 --- a/testsuite/lpgf/test.hs +++ b/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" - doGrammar "Tables" - doGrammar "Params" - doGrammar "Pre" - doGrammar "Projection" - - doGrammar "Walking" - doGrammar "Foods" - -- doGrammar' "Foods" ["Fre"] + args <- getArgs + case args of + [] -> do + doGrammar "Bind" + doGrammar "Tables" + doGrammar "Params" + doGrammar "Pre" + doGrammar "Projection" + 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 - if langs == tail grp + mapM_ putStrLn outs + + -- 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"