diff --git a/src/runtime/haskell/LPGF.hs b/src/runtime/haskell/LPGF.hs index 3c47ab385..a1a9f379f 100644 --- a/src/runtime/haskell/LPGF.hs +++ b/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 - Empty -> "" - Bind -> "" -- when encountered at beginning/end - Space -> "" -- when encountered at beginning/end - Token tok -> tok - Missing cid -> T.pack $ printf "[%s]" (show cid) - Tuple [l] -> lin2string l - Tuple (l:_) -> lin2string l -- unselected table, just choose first option (see e.g. FoodsJpn) - Pre pts df -> lin2string df -- when encountered at end - Concat (Pre pts df) l2 -> lin2string $ Concat l1 l2 - where - l2' = lin2string l2 - matches = [ l | (pfxs, l) <- pts, any (`T.isPrefixOf` l2') pfxs ] - l1 = if null matches then df else head matches - Concat l1 (Concat Bind l2) -> lin2string l1 `T.append` lin2string l2 - Concat l1 (Concat Space l2) -> lin2string $ Concat l1 l2 - Concat Capit l2 -> let l = lin2string l2 in T.toUpper (T.take 1 l) `T.append` T.drop 1 l - Concat AllCapit l2 -> let tks = T.words (lin2string l2) in T.unwords $ T.toUpper (head tks) : tail tks - Concat l1 l2 -> T.unwords $ filter (not.T.null) [lin2string l1, lin2string l2] - x -> T.pack $ printf "[%s]" (show x) +lin2string lf = T.unwords $ join $ flatten [lf] + where + -- Process bind et al into final token list + join :: [Either LinFun Text] -> [Text] + join elt = case elt of + Right tok:Left Bind:ls -> + case join ls of + next:ls' -> tok `T.append` next : ls' + _ -> [] + Right tok:ls -> tok : join ls + Left Space:ls -> join ls + Left Capit:ls -> + case join ls of + next:ls' -> T.toUpper (T.take 1 next) `T.append` T.drop 1 next : ls' + _ -> [] + Left AllCapit:ls -> + case join ls of + next:ls' -> T.toUpper next : ls' + _ -> [] + 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 diff --git a/testsuite/lpgf/phrasebook/Phrasebook.treebank b/testsuite/lpgf/phrasebook/Phrasebook.treebank index 443838d44..e4114fed9 100644 --- a/testsuite/lpgf/phrasebook/Phrasebook.treebank +++ b/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. diff --git a/testsuite/lpgf/unittests/Bind.gf b/testsuite/lpgf/unittests/Bind.gf index 09c288cc7..34bb10cf0 100644 --- a/testsuite/lpgf/unittests/Bind.gf +++ b/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 ; } diff --git a/testsuite/lpgf/unittests/Bind.treebank b/testsuite/lpgf/unittests/Bind.treebank index 5716daca0..85b69f442 100644 --- a/testsuite/lpgf/unittests/Bind.treebank +++ b/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 diff --git a/testsuite/lpgf/unittests/BindCnc.gf b/testsuite/lpgf/unittests/BindCnc.gf index 3c6c9bf1b..1ff4c69d4 100644 --- a/testsuite/lpgf/unittests/BindCnc.gf +++ b/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; + _ => ">" + } ; }