From d394cacddfcf9e2e3079595e80520aa28d502d7a Mon Sep 17 00:00:00 2001
From: "John J. Camilleri" <john@digitalgrammars.com>
Date: Tue, 16 Feb 2021 15:17:54 +0100
Subject: [PATCH] Add support for CAPIT and ALL_CAPIT

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

diff --git a/src/compiler/GF/Compile/GrammarToLPGF.hs b/src/compiler/GF/Compile/GrammarToLPGF.hs
index bde6dd510..9ae1545dd 100644
--- a/src/compiler/GF/Compile/GrammarToLPGF.hs
+++ b/src/compiler/GF/Compile/GrammarToLPGF.hs
@@ -95,8 +95,8 @@ mkCanon2lpgf opts gr am = do
                 "BIND" -> return L.LFBind
                 "SOFT_BIND" -> return L.LFBind
                 "SOFT_SPACE" -> return L.LFSpace
-                -- "CAPIT" ->
-                -- "ALL_CAPIT" ->
+                "CAPIT" -> return L.LFCapit
+                "ALL_CAPIT" -> return L.LFAllCapit
                 _ -> Left $ printf "Unknown predef function: %s" pid
 
               C.RecordValue rrvs -> do
diff --git a/src/runtime/haskell/LPGF.hs b/src/runtime/haskell/LPGF.hs
index d77bb63a8..66b3adee2 100644
--- a/src/runtime/haskell/LPGF.hs
+++ b/src/runtime/haskell/LPGF.hs
@@ -9,6 +9,7 @@ import PGF.Expr (Expr)
 import PGF.Tree (Tree (..), expr2tree, prTree)
 
 import Data.Binary (Binary, get, put, encodeFile, decodeFile)
+import Data.Char (toUpper)
 import Data.List (isPrefixOf)
 import qualified Data.Map as Map
 import Text.Printf (printf)
@@ -50,6 +51,8 @@ data LinFun =
     LFError String -- ^ a runtime error, should probably not be supported at all
   | LFBind
   | LFSpace
+  | LFCapit
+  | LFAllCapit
   | LFPre [([String], LinFun)] LinFun
 
   -- From original definition in paper
@@ -161,6 +164,8 @@ lin2string l = case l of
       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 LFCapit l2 -> let l = lin2string l2 in toUpper (head l) : tail l
+  LFConcat LFAllCapit l2 -> let tks = words (lin2string l2) in unwords $ map toUpper (head tks) : tail tks
   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 031703721..09c288cc7 100644
--- a/testsuite/lpgf/Bind.gf
+++ b/testsuite/lpgf/Bind.gf
@@ -7,4 +7,6 @@ abstract Bind = {
     bind : S -> S -> S ;
     softbind : S -> S -> S ;
     softspace : S -> S -> S ;
+    capit : S -> S ;
+    allcapit : S -> S ;
 }
diff --git a/testsuite/lpgf/Bind.treebank b/testsuite/lpgf/Bind.treebank
index f9db8c154..5716daca0 100644
--- a/testsuite/lpgf/Bind.treebank
+++ b/testsuite/lpgf/Bind.treebank
@@ -15,3 +15,6 @@ BindCnc: hello theregoodbye
 
 Bind: softspace f1 f2
 BindCnc: hello there goodbye
+
+Bind: concat (capit f1) (allcapit f2)
+BindCnc: Hello there GOODBYE
diff --git a/testsuite/lpgf/Bind.trees b/testsuite/lpgf/Bind.trees
index 3e849f341..93ca90791 100644
--- a/testsuite/lpgf/Bind.trees
+++ b/testsuite/lpgf/Bind.trees
@@ -4,3 +4,4 @@ concat f1 f2
 bind f1 f2
 softbind f1 f2
 softspace f1 f2
+concat (capit f1) (allcapit f2)
diff --git a/testsuite/lpgf/BindCnc.gf b/testsuite/lpgf/BindCnc.gf
index 7edbdbcf3..3c6c9bf1b 100644
--- a/testsuite/lpgf/BindCnc.gf
+++ b/testsuite/lpgf/BindCnc.gf
@@ -8,4 +8,6 @@ concrete BindCnc of Bind = open Prelude in {
     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) ;
+    capit a = ss (CAPIT ++ a.s) ;
+    allcapit a = ss (ALL_CAPIT ++ a.s) ;
 }