diff --git a/src/runtime/haskell/LPGF.hs b/src/runtime/haskell/LPGF.hs index 9c21b1173..f13d94143 100644 --- a/src/runtime/haskell/LPGF.hs +++ b/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) diff --git a/testsuite/lpgf/Foods.gf b/testsuite/lpgf/Foods.gf new file mode 100644 index 000000000..8ea02f39d --- /dev/null +++ b/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 ; +} diff --git a/testsuite/lpgf/Foods.trees b/testsuite/lpgf/Foods.trees new file mode 100644 index 000000000..2253d4acb --- /dev/null +++ b/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 diff --git a/testsuite/lpgf/FoodsEng.gf b/testsuite/lpgf/FoodsEng.gf new file mode 100644 index 000000000..e7359a4ff --- /dev/null +++ b/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"} ; +} diff --git a/testsuite/lpgf/Walking.hs b/testsuite/lpgf/Walking.hs new file mode 100644 index 000000000..a6b312c7a --- /dev/null +++ b/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"]]]) + ] + }) + ] +} diff --git a/testsuite/lpgf/Walking.trees b/testsuite/lpgf/Walking.trees new file mode 100644 index 000000000..a8e50b342 --- /dev/null +++ b/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 diff --git a/testsuite/lpgf/run.hs b/testsuite/lpgf/run.hs index 68b01187f..e26aa8e70 100644 --- a/testsuite/lpgf/run.hs +++ b/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 - forM_ [tree1, tree2, tree3] $ \tree -> do - putStrLn "" - putStrLn (showExpr [] tree) - forM_ (Map.toList (concretes lpgf)) $ \(lang,concr) -> - printf "%s: %s\n" (showLanguage lang) (linearizeConcr concr tree) + -- Read treebank + gs <- groups . lines <$> readFile (dir gname <.> "trees") + forM_ gs $ \grp -> do + let ast = drop 2 $ dropWhile (/=':') $ head grp + printf "%s: %s\n" gname ast + 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 -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"]]]) - ] - }) - ] -} +groups :: [String] -> [[String]] +groups [] = [] +groups ss = let (a,b) = break (=="") ss in a : groups (drop 1 b)