From 21f14c2aa1b4666066f2465c61ac2e58fd2272f8 Mon Sep 17 00:00:00 2001
From: "John J. Camilleri" <john@digitalgrammars.com>
Date: Tue, 16 Feb 2021 14:57:33 +0100
Subject: [PATCH] Add support for SOFT_SPACE

---
 src/compiler/GF/Compile/GrammarToLPGF.hs |  3 ++-
 src/runtime/haskell/LPGF.hs              | 11 +++++------
 testsuite/lpgf/Bind.gf                   |  1 +
 testsuite/lpgf/Bind.treebank             |  3 +++
 testsuite/lpgf/Bind.trees                |  1 +
 testsuite/lpgf/BindCnc.gf                |  1 +
 6 files changed, 13 insertions(+), 7 deletions(-)

diff --git a/src/compiler/GF/Compile/GrammarToLPGF.hs b/src/compiler/GF/Compile/GrammarToLPGF.hs
index 575dddaf0..bde6dd510 100644
--- a/src/compiler/GF/Compile/GrammarToLPGF.hs
+++ b/src/compiler/GF/Compile/GrammarToLPGF.hs
@@ -90,10 +90,11 @@ mkCanon2lpgf opts gr am = do
                   term = foldl L.LFProjection tuple (L.LFInt (pidIx+1):pids')
                 return term
 
+              -- https://www.aclweb.org/anthology/W15-3305.pdf
               C.PredefValue (C.PredefId pid) -> case pid of
                 "BIND" -> return L.LFBind
                 "SOFT_BIND" -> return L.LFBind
-                -- "SOFT_SPACE" ->
+                "SOFT_SPACE" -> return L.LFSpace
                 -- "CAPIT" ->
                 -- "ALL_CAPIT" ->
                 _ -> Left $ printf "Unknown predef function: %s" pid
diff --git a/src/runtime/haskell/LPGF.hs b/src/runtime/haskell/LPGF.hs
index 3d1390c2c..d77bb63a8 100644
--- a/src/runtime/haskell/LPGF.hs
+++ b/src/runtime/haskell/LPGF.hs
@@ -48,7 +48,8 @@ data Concr = Concr {
 data LinFun =
   -- Additions
     LFError String -- ^ a runtime error, should probably not be supported at all
-  | LFBind -- ^ bind token
+  | LFBind
+  | LFSpace
   | LFPre [([String], LinFun)] LinFun
 
   -- From original definition in paper
@@ -127,19 +128,14 @@ type Context = [LinFun]
 eval :: Context -> LinFun -> LinFun
 eval cxt t = case t of
   LFError err -> error err
-  LFBind -> LFBind
   LFPre pts df -> LFPre pts' df'
     where
       pts' = [ (strs, eval cxt t) | (strs,t) <- pts]
       df' = eval cxt df
-
-  LFEmpty -> LFEmpty
-  LFToken tok -> LFToken tok
   LFConcat s t -> LFConcat v w
     where
       v = eval cxt s
       w = eval cxt t
-  LFInt i -> LFInt i
   LFTuple ts -> LFTuple vs
     where vs = map (eval cxt) ts
   LFProjection t u ->
@@ -148,12 +144,14 @@ eval cxt t = case t of
       (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)
   LFArgument i -> cxt !! (i-1)
+  _ -> t
 
 -- | Turn concrete syntax terms into an actual string
 lin2string :: LinFun -> String
 lin2string l = case l of
   LFEmpty -> ""
   LFBind -> "" -- when encountered at beginning/end
+  LFSpace -> "" -- when encountered at beginning/end
   LFToken tok -> tok
   LFTuple [l] -> lin2string l
   LFConcat (LFPre pts df) l2 -> lin2string $ LFConcat l1 l2
@@ -162,6 +160,7 @@ lin2string l = case l of
       matches = [ l | (pfxs, l) <- pts, any (`isPrefixOf` l2') pfxs ]
       l1 = if null matches then df else head matches
   LFConcat l1 (LFConcat LFBind l2) -> lin2string l1 ++ lin2string l2
+  LFConcat l1 (LFConcat LFSpace l2) -> lin2string $ LFConcat l1 l2
   LFConcat l1 l2 -> unwords $ filter (not.null) [lin2string l1, lin2string l2]
   x -> printf "[%s]" (show x)
 
diff --git a/testsuite/lpgf/Bind.gf b/testsuite/lpgf/Bind.gf
index fcae20ac3..031703721 100644
--- a/testsuite/lpgf/Bind.gf
+++ b/testsuite/lpgf/Bind.gf
@@ -6,4 +6,5 @@ abstract Bind = {
     concat : S -> S -> S ;
     bind : S -> S -> S ;
     softbind : S -> S -> S ;
+    softspace : S -> S -> S ;
 }
diff --git a/testsuite/lpgf/Bind.treebank b/testsuite/lpgf/Bind.treebank
index 04d8160c3..f9db8c154 100644
--- a/testsuite/lpgf/Bind.treebank
+++ b/testsuite/lpgf/Bind.treebank
@@ -12,3 +12,6 @@ BindCnc: hello theregoodbye
 
 Bind: softbind f1 f2
 BindCnc: hello theregoodbye
+
+Bind: softspace f1 f2
+BindCnc: hello there goodbye
diff --git a/testsuite/lpgf/Bind.trees b/testsuite/lpgf/Bind.trees
index 64bc5fb52..3e849f341 100644
--- a/testsuite/lpgf/Bind.trees
+++ b/testsuite/lpgf/Bind.trees
@@ -3,3 +3,4 @@ f2
 concat f1 f2
 bind f1 f2
 softbind f1 f2
+softspace f1 f2
diff --git a/testsuite/lpgf/BindCnc.gf b/testsuite/lpgf/BindCnc.gf
index 730e158bb..7edbdbcf3 100644
--- a/testsuite/lpgf/BindCnc.gf
+++ b/testsuite/lpgf/BindCnc.gf
@@ -7,4 +7,5 @@ concrete BindCnc of Bind = open Prelude in {
     concat a b = ss (a.s ++ b.s) ;
     bind a b = ss (a.s ++ BIND ++ b.s) ;
     softbind a b = ss (a.s ++ SOFT_BIND ++ b.s) ;
+    softspace a b = ss (a.s ++ SOFT_SPACE ++ b.s) ;
 }