Fix lin2string and pass all unittests and Phrasebook

src/runtime/haskell/LPGF.hs

@@ -17,6 +17,7 @@ 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)
+import Data.Either (isLeft)
 import qualified Data.IntMap as IntMap
 import qualified Data.Map.Strict as Map
 import Data.Text (Text)
@@ -133,6 +134,7 @@ instance Binary LinFun where
 
     PreIx ps d       -> putWord8 15 >> put (ps,d)
     TokenIx i        -> putWord8 14 >> put i
+
   get = do
     tag <- getWord8
     case tag of
@@ -230,7 +232,8 @@ eval cxt t = case t of
       (Missing f, _) -> Missing f
       (_, Missing f) -> Missing f
       (Tuple vs, Ix i) -> vs !! (i-1)
-      (tp@(Tuple _), tv@(Tuple _)) | all isIx (flattenTuple tv) -> foldl (\(Tuple vs) (Ix i) -> vs !! (i-1)) tp (flattenTuple tv)
+      -- (tp@(Tuple _), tv@(Tuple _)) | all isIx (flattenTuple tv) -> foldl (\(Tuple vs) (Ix i) -> vs !! (i-1)) tp (flattenTuple tv)
+      (t', tv@(Tuple _)) -> eval cxt $ foldl Projection t' (flattenTuple tv)
       (t',u') -> error $ printf "Incompatible projection:\n- %s\n⇓ %s\n- %s\n⇓ %s" (show t) (show t') (show u) (show u')
   Argument i -> cxArgs cxt !! (i-1)
 
@@ -247,28 +250,53 @@ flattenTuple = \case
   Tuple vs -> concatMap flattenTuple vs
   lf -> [lf]
 
--- | Turn concrete syntax terms into an actual string
+-- | Turn concrete syntax terms into an actual string.
+-- This is done in two passes, first to flatten concats & evaluate pre's, then to
+-- apply BIND and other predefs.
 lin2string :: LinFun -> Text
-lin2string l = case l of
+lin2string lf = T.unwords $ join $ flatten [lf]
-  Empty -> ""
+  where
-  Bind -> "" -- when encountered at beginning/end
+    -- Process bind et al into final token list
-  Space -> "" -- when encountered at beginning/end
+    join :: [Either LinFun Text] -> [Text]
-  Token tok -> tok
+    join elt = case elt of
-  Missing cid -> T.pack $ printf "[%s]" (show cid)
+      Right tok:Left Bind:ls ->
-  Tuple [l] -> lin2string l
+        case join ls of
-  Tuple (l:_) -> lin2string l -- unselected table, just choose first option (see e.g. FoodsJpn)
+          next:ls' -> tok `T.append` next : ls'
-  Pre pts df -> lin2string df -- when encountered at end
+          _ -> []
-  Concat (Pre pts df) l2 -> lin2string $ Concat l1 l2
+      Right tok:ls -> tok : join ls
-    where
+      Left Space:ls -> join ls
-      l2' = lin2string l2
+      Left Capit:ls ->
-      matches = [ l | (pfxs, l) <- pts, any (`T.isPrefixOf` l2') pfxs ]
+        case join ls of
-      l1 = if null matches then df else head matches
+          next:ls' -> T.toUpper (T.take 1 next) `T.append` T.drop 1 next : ls'
-  Concat l1 (Concat Bind l2) -> lin2string l1 `T.append` lin2string l2
+          _ -> []
-  Concat l1 (Concat Space l2) -> lin2string $ Concat l1 l2
+      Left AllCapit:ls ->
-  Concat Capit l2 -> let l = lin2string l2 in T.toUpper (T.take 1 l) `T.append` T.drop 1 l
+        case join ls of
-  Concat AllCapit l2 -> let tks = T.words (lin2string l2) in T.unwords $ T.toUpper (head tks) : tail tks
+          next:ls' -> T.toUpper next : ls'
-  Concat l1 l2 -> T.unwords $ filter (not.T.null) [lin2string l1, lin2string l2]
+          _ -> []
-  x -> T.pack $ printf "[%s]" (show x)
+      Left (Missing cid):ls -> join (Right (T.pack (printf "[%s]" (show cid))) : ls)
+      [] -> []
+      x -> error $ printf "Unhandled term in lin2string: %s" (show x)
+
+    -- Process concats, tuples, pre into flat list
+    flatten :: [LinFun] -> [Either LinFun Text]
+    flatten [] = []
+    flatten (l:ls) = case l of
+      Empty -> flatten ls
+      Token "" -> flatten ls
+      Token tok -> Right tok : flatten ls
+      Concat l1 l2 -> flatten (l1 : l2 : ls)
+      Tuple [l] -> flatten (l:ls)
+      Tuple (l:_) -> flatten (l:ls) -- unselected table, just choose first option (see e.g. FoodsJpn)
+      Pre pts df ->
+        let
+          f = flatten ls
+          ch = case dropWhile isLeft f of
+            Right next:_ ->
+              let matches = [ l | (pfxs, l) <- pts, any (`T.isPrefixOf` next) pfxs ]
+              in  if null matches then df else head matches
+            _ -> df
+        in flatten (ch:ls)
+      x -> Left x : flatten ls
 
 -- | List indexing with more verbose error messages
 (!!) :: (Show a) => [a] -> Int -> a

testsuite/lpgf/phrasebook/Phrasebook.treebank

@@ -256,7 +256,7 @@ PhrasebookLav: atrakciju parks nav atvērts.
 PhrasebookNor: en fornøyelsespark er ikke åpen.
 PhrasebookPol: wesołe miasteczko nie jest otwarte.
 PhrasebookRon: un parc de distracții nu este deschis.
-PhrasebookSnd:
+PhrasebookSnd: [AmusementPark] کلي ن [AmusementPark].
 PhrasebookSpa: un parque de atracciones no está abierto.
 PhrasebookSwe: en nöjespark är inte öppen.
 PhrasebookTha: สวนสนุก ไม่ เปิด
@@ -592,14 +592,14 @@ PhrasebookLav: tev nav picas.
 PhrasebookNor: du har ikke pizzaer.
 PhrasebookPol: nie masz pizz.
 PhrasebookRon: tu nu ai nişte pizze.
-PhrasebookSnd:
+PhrasebookSnd: [YouFamMale] پيزا [YouFamMale] ن [YouFamMale].
 PhrasebookSpa: no tienes pizzas.
 PhrasebookSwe: du har inte pizzor.
 PhrasebookTha: เธอ ไม่ มี พิซซา
 PhrasebookUrd: تم پیزے نہیں رکھتے ہو
 
 Phrasebook: PQuestion (HowFarFromBy (SuperlPlace TheMostExpensive Pharmacy) (SuperlPlace TheMostPopular Zoo) ByFoot)
-PhrasebookBul: колко далече е най - известният зоопарк от най - скъпата аптека пеша?
+PhrasebookBul: колко далече е най-известният зоопарк от най-скъпата аптека пеша?
 PhrasebookCat: a quina distància està de la farmàcia més cara a peu el zoo més popular?
 PhrasebookChi: [HowFarFromBy] ？
 PhrasebookDan: hvor langt er den populæreste zoologiske have fra det dyreste apotek til fods?
@@ -911,7 +911,7 @@ PhrasebookTha: อ่าน ซิ
 PhrasebookUrd: پڑھنا
 
 Phrasebook: PSentence (SPropNot (PropClosedDay (SuperlPlace TheBest Station) Wednesday))
-PhrasebookBul: най - добрата гара не е затворена в средите.
+PhrasebookBul: най-добрата гара не е затворена в средите.
 PhrasebookCat: la millora estació no és tancada els dimecres.
 PhrasebookChi: 最 好 的 那 个 车 站 在 星 期 三 不 是 关 闭 的 。
 PhrasebookDan: den bedste station har ikke lukket på onsdager.
@@ -1240,7 +1240,7 @@ PhrasebookLav: jūsu meitai nav garlaicīgs sāls.
 PhrasebookNor: datteren deres har ikke kjedelig salt.
 PhrasebookPol: wasza córka nie ma nudnej soli.
 PhrasebookRon: fiica voastră nu are sare plictisitoare.
-PhrasebookSnd:
+PhrasebookSnd: [YouPlurPolFemale] فضول لوڻ [YouPlurPolFemale] ن [YouPlurPolFemale].
 PhrasebookSpa: su hija no tiene sal aburrida.
 PhrasebookSwe: er dotter har inte tråkigt salt.
 PhrasebookTha: ลูกสาว ของ พวกคุณ ไม่ มี เกลือ น่าเบื่อ
@@ -1511,7 +1511,7 @@ PhrasebookTha: ใช่ ค่ะ
 PhrasebookUrd: ہاں
 
 Phrasebook: PQuestion (HowFarBy (SuperlPlace TheWorst Church) ByFoot)
-PhrasebookBul: колко далече е най - лошата църква пеша?
+PhrasebookBul: колко далече е най-лошата църква пеша?
 PhrasebookCat: a quina distància està a peu la pitjora església?
 PhrasebookChi: 步 行 到 最 坏 的 那 所 教 堂 有 多 远 ？
 PhrasebookDan: hvor langt er den dårligste kirke til fods?
@@ -1912,7 +1912,7 @@ PhrasebookLav: Jums nav pārāk auksti āboli.
 PhrasebookNor: Dere har ikke for kalde epler.
 PhrasebookPol: pani nie ma za zimnych jabłek.
 PhrasebookRon: dumneavoastră nu aveţi nişte mere prea reci.
-PhrasebookSnd:
+PhrasebookSnd: [YouPolFemale] بيحد ٿڌا صوف [YouPolFemale] ن [YouPolFemale].
 PhrasebookSpa: no tiene manzanas demasiado frías.
 PhrasebookSwe: ni har inte för kalla äpplen.
 PhrasebookTha: คุณ ไม่ มี แอป เปิ้ล หนาว เกินไป
@@ -2368,14 +2368,14 @@ PhrasebookLav: jums ir pica.
 PhrasebookNor: dere har en pizza.
 PhrasebookPol: wy macie pizzę.
 PhrasebookRon: voi aveţi o pizză.
-PhrasebookSnd:
+PhrasebookSnd: [YouPlurPolFemale] پيزا [YouPlurPolFemale] [YouPlurPolFemale].
 PhrasebookSpa: tienen una pizza.
 PhrasebookSwe: ni har en pizza.
 PhrasebookTha: พวกคุณ มี พิซซา
 PhrasebookUrd: آپ پیزہ رکھتیں ہیں
 
 Phrasebook: PSentence (SPropNot (PropOpenDay (SuperlPlace TheCheapest Supermarket) Thursday))
-PhrasebookBul: най - евтиният супермаркет не е отворен в четвъртъците.
+PhrasebookBul: най-евтиният супермаркет не е отворен в четвъртъците.
 PhrasebookCat: el supermercat més barat no és obert els dijous.
 PhrasebookChi: 最 廉 价 的 那 家 超 级 市 场 在 星 期 四 不 是 开 放 的 。
 PhrasebookDan: det billigste supermarked har ikke åbent på torsdager.

testsuite/lpgf/unittests/Bind.gf

@@ -9,4 +9,6 @@ abstract Bind = {
     softspace : S -> S -> S ;
     capit : S -> S ;
     allcapit : S -> S ;
+    prebind : S -> S ;
+    precapit : S -> S ;
 }

testsuite/lpgf/unittests/Bind.treebank

@@ -18,3 +18,15 @@ BindCnc: hello there goodbye
 
 Bind: concat (capit f1) (allcapit f2)
 BindCnc: Hello there GOODBYE
+
+Bind: prebind f1
+BindCnc: |hello there
+
+Bind: prebind f2
+BindCnc: > goodbye
+
+Bind: precapit f1
+BindCnc: |Hello there
+
+Bind: precapit f2
+BindCnc: > Goodbye

testsuite/lpgf/unittests/BindCnc.gf

@@ -10,4 +10,12 @@ concrete BindCnc of Bind = open Prelude in {
     softspace a b = ss (a.s ++ SOFT_SPACE ++ b.s) ;
     capit a = ss (CAPIT ++ a.s) ;
     allcapit a = ss (ALL_CAPIT ++ a.s) ;
+    prebind a = ss (p ++ a.s) ;
+    precapit a = ss (p ++ CAPIT ++ a.s) ;
+  oper
+    p = pre {
+      "he" => "|" ++ BIND;
+      "H"|"G" => "^" ++ BIND;
+      _ => ">"
+    } ;
 }