Add LPGF function for catching errors. Manual fixes to Phrasebook treebank.

src/runtime/haskell/LPGF.hs

@@ -1,5 +1,6 @@
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 -- | Linearisation-only grammar format.
 -- Closely follows description in Section 2 of Angelov, Bringert, Ranta (2009):
@@ -12,6 +13,7 @@ import PGF.CId
 import PGF.Expr (Expr)
 import PGF.Tree (Tree (..), expr2tree, prTree)
 
+import qualified Control.Exception as EX
 import Control.Monad (liftM, liftM2, forM_)
 import qualified Control.Monad.Writer as CMW
 import Data.Binary (Binary, put, get, putWord8, getWord8, encodeFile, decodeFile)
@@ -195,6 +197,13 @@ linearizeConcreteText concr expr = lin2string $ lin (expr2tree expr)
           _ -> Missing f
       x -> error $ printf "Cannot lin: %s" (prTree x)
 
+-- | Run a compatation and catch any exception/errors.
+-- Ideally this library should never throw exceptions, but we're still in development...
+try :: a -> IO (Either String a)
+try comp = do
+  let f = Right <$> EX.evaluate comp
+  EX.catch f (\(e :: EX.SomeException) -> return $ Left (show e))
+
 -- | Evaluation context
 data Context = Context {
   cxArgs :: [LinFun], -- ^  is a sequence of terms

testsuite/lpgf/README.md

@@ -48,11 +48,11 @@ Run each command separately so that memory measurements are isolated.
 The `+RTS -T -RTS` is so that GHC can report its own memory usage.
 
 ```
-stack build --test --bench --no-run-tests --no-run-benchmarks
+stack build --test --bench --no-run-tests --no-run-benchmarks &&
-stack bench --benchmark-arguments "compile pgf  testsuite/lpgf/foods/Foods*.gf +RTS -T -RTS"
+stack bench --benchmark-arguments "compile pgf  testsuite/lpgf/foods/Foods*.gf +RTS -T -RTS" &&
-stack bench --benchmark-arguments "compile lpgf testsuite/lpgf/foods/Foods*.gf +RTS -T -RTS"
+stack bench --benchmark-arguments "compile lpgf testsuite/lpgf/foods/Foods*.gf +RTS -T -RTS" &&
-stack bench --benchmark-arguments "run pgf  Foods.pgf  testsuite/lpgf/foods/Foods-all.trees +RTS -T -RTS"
+stack bench --benchmark-arguments "run pgf  Foods.pgf  testsuite/lpgf/foods/Foods-all.trees +RTS -T -RTS" &&
-stack bench --benchmark-arguments "run pgf2 Foods.pgf  testsuite/lpgf/foods/Foods-all.trees +RTS -T -RTS"
+stack bench --benchmark-arguments "run pgf2 Foods.pgf  testsuite/lpgf/foods/Foods-all.trees +RTS -T -RTS" &&
 stack bench --benchmark-arguments "run lpgf Foods.lpgf testsuite/lpgf/foods/Foods-all.trees +RTS -T -RTS"
 ```
 

testsuite/lpgf/bench.hs

@@ -10,6 +10,7 @@ import GF.Support (Options, Flags (..), Verbosity (..), noOptions, addOptions, m
 import Control.DeepSeq (NFData, force)
 import Control.Exception (evaluate)
 import Control.Monad (when, forM)
+import Data.Either (isLeft)
 import qualified Data.List as L
 import Data.Maybe (fromJust, isJust, isNothing)
 import qualified Data.Map as Map
@@ -105,8 +106,12 @@ main = do
     when doLPGF $ do
       heading "LPGF"
       lpgf <- LPGF.readLPGF (dropExtension (fromJust binaryFile) <.> "lpgf")
-      timePure "- linearise: " (linLPGF lpgf trees)
+      -- timePure "- linearise: " (linLPGF lpgf trees)
-      return ()
+      ress <- time "- linearise: " (linLPGF' lpgf trees)
+      when (any (any isLeft) ress) $ do
+        setSGR [SetColor Foreground Dull Red]
+        putStrLn "Teminated with errors"
+        setSGR [Reset]
 
   stats <- getRTSStats
   printf "Max memory: %s\n" (convertSize (fromIntegral (max_mem_in_use_bytes stats)))
@@ -117,6 +122,7 @@ heading s = do
   putStrLn s
   setSGR [Reset]
 
+-- For accurate timing, IO action must for evaluation itself (e.g., write to file)
 time :: String -> IO a -> IO a
 time desc io = do
   start <- getCurrentTime
@@ -125,6 +131,7 @@ time desc io = do
   putStrLn $ desc ++ show (diffUTCTime end start)
   return r
 
+-- Performs deep evaluation
 timePure :: (NFData a) => String -> a -> IO a
 timePure desc val = time desc (return $ force val)
 
@@ -152,6 +159,10 @@ linLPGF :: LPGF.LPGF -> [PGF.Expr] -> [[Text]]
 linLPGF lpgf trees =
   [ map (LPGF.linearizeConcreteText concr) trees | (_,concr) <- Map.toList (LPGF.concretes lpgf) ]
 
+linLPGF' :: LPGF.LPGF -> [PGF.Expr] -> IO [[Either String Text]]
+linLPGF' lpgf trees =
+  forM (Map.toList (LPGF.concretes lpgf)) $ \(_,concr) -> mapM (LPGF.try . LPGF.linearizeConcreteText concr) trees
+
 -- | Produce human readable file size
 -- Adapted from https://hackage.haskell.org/package/hrfsize
 convertSize :: Integer -> String

testsuite/lpgf/phrasebook/Phrasebook.treebank

@@ -88,7 +88,7 @@ PhrasebookLav: neraksti
 PhrasebookNor: skriv ikke
 PhrasebookPol: nie pisz
 PhrasebookRon: nu scrie
-PhrasebookSnd:
+PhrasebookSnd: ن [VWrite] [VWrite]
 PhrasebookSpa: no escribas
 PhrasebookSwe: skriv inte
 PhrasebookTha: อย่า เขียน
@@ -832,7 +832,7 @@ PhrasebookLav: nelasi
 PhrasebookNor: les ikke
 PhrasebookPol: nie czytaj
 PhrasebookRon: nu citi
-PhrasebookSnd:
+PhrasebookSnd: ن [VRead] [VRead]
 PhrasebookSpa: no leas
 PhrasebookSwe: läs inte
 PhrasebookTha: อย่า อ่าน
@@ -904,7 +904,7 @@ PhrasebookLav: lasiet
 PhrasebookNor: les
 PhrasebookPol: przeczytajcie
 PhrasebookRon: citiţi
-PhrasebookSnd:
+PhrasebookSnd: [VRead] [VRead]
 PhrasebookSpa: leed
 PhrasebookSwe: läs
 PhrasebookTha: อ่าน ซิ
@@ -1072,7 +1072,7 @@ PhrasebookLav: lasi
 PhrasebookNor: les
 PhrasebookPol: przeczytaj
 PhrasebookRon: citeşte
-PhrasebookSnd:
+PhrasebookSnd: [VRead] [VRead]
 PhrasebookSpa: lee
 PhrasebookSwe: läs
 PhrasebookTha: อ่าน ซิ
@@ -1216,7 +1216,7 @@ PhrasebookLav: neraksti
 PhrasebookNor: skriv ikke
 PhrasebookPol: nie pisz
 PhrasebookRon: nu scrie
-PhrasebookSnd:
+PhrasebookSnd: ن [VWrite] [VWrite]
 PhrasebookSpa: no escribas
 PhrasebookSwe: skriv inte
 PhrasebookTha: อย่า เขียน
@@ -1360,7 +1360,7 @@ PhrasebookLav: raksti
 PhrasebookNor: skriv
 PhrasebookPol: napisz
 PhrasebookRon: scrie
-PhrasebookSnd:
+PhrasebookSnd: [VWrite] [VWrite]
 PhrasebookSpa: escribe
 PhrasebookSwe: skriv
 PhrasebookTha: เขียน ซิ
@@ -1480,7 +1480,7 @@ PhrasebookLav: lūdzu nerakstiet
 PhrasebookNor: skriv ikke
 PhrasebookPol: nie pisz
 PhrasebookRon: nu scrie
-PhrasebookSnd:
+PhrasebookSnd: ن [VWrite] [VWrite]
 PhrasebookSpa: no escriba
 PhrasebookSwe: skriv inte
 PhrasebookTha: อย่า เขียน
@@ -1744,7 +1744,7 @@ PhrasebookLav: rakstiet
 PhrasebookNor: skriv
 PhrasebookPol: napiszcie
 PhrasebookRon: scrieţi
-PhrasebookSnd:
+PhrasebookSnd: [VWrite] [VWrite]
 PhrasebookSpa: escribid
 PhrasebookSwe: skriv
 PhrasebookTha: เขียน ซิ
@@ -2344,7 +2344,7 @@ PhrasebookLav: lasi
 PhrasebookNor: les
 PhrasebookPol: przeczytaj
 PhrasebookRon: citeşte
-PhrasebookSnd:
+PhrasebookSnd: [VRead] [VRead]
 PhrasebookSpa: lee
 PhrasebookSwe: läs
 PhrasebookTha: อ่าน ซิ

testsuite/lpgf/run-bench.sh

@@ -12,9 +12,9 @@ FLAGS="+RTS -T -RTS"
 stack build --test --bench --no-run-tests --no-run-benchmarks
 
 printf "\n-- COMPILE --\n\n"
-DEBUG=1 stack bench --benchmark-arguments "compile pgf ${PREFIX}${1}.gf ${FLAGS}"
+stack bench --benchmark-arguments "compile pgf ${PREFIX}${1}.gf ${FLAGS}"
 printf "\n"
-DEBUG=1 stack bench --benchmark-arguments "compile lpgf ${PREFIX}${1}.gf ${FLAGS}"
+stack bench --benchmark-arguments "compile lpgf ${PREFIX}${1}.gf ${FLAGS}"
 
 printf "\n-- RUN -- \n\n"
 stack bench --benchmark-arguments "run pgf Phrasebook.pgf ${TREES} ${FLAGS}"

testsuite/lpgf/test.hs

@@ -68,13 +68,14 @@ doGrammar' path gname cncs = do
   results <- forM gs $ \grp -> do
     let ast = drop 2 $ dropWhile (/=':') $ head grp
     printf "- %s: %s\n" gname ast
-    let
+    let Just tree = readExpr ast
-      Just tree = readExpr ast
+
     -- Linearization into all languages
-      outs =
+    outs <- forM (Map.toList (concretes lpgf)) $ \(lang,concr) -> do
-        [ printf "%s: %s" (showLanguage lang) (linearizeConcrete concr tree)
+      e <- try $ linearizeConcrete concr tree
-        | (lang,concr) <- Map.toList (concretes lpgf)
+      return $ case e of
-        ]
+        Right s -> printf "%s: %s" (showLanguage lang) s
+        Left  e -> printf "%s: ERROR: %s" (showLanguage lang) e
 
     -- filter out missing langs from treebank
     let golds = [ g | o <- outs, g <- tail grp, takeWhile (/=':') o == takeWhile (/=':') g  ]