From 56173a9fdbefc0f053aaa42f5d027f65236d43ac Mon Sep 17 00:00:00 2001
From: aarne <aarne@cs.chalmers.se>
Date: Tue, 9 Sep 2008 06:36:36 +0000
Subject: [PATCH] enable matching of ++ strings with regular patterns

---
 lib/resource/Make.hs                 |  4 ++++
 lib/resource/swedish/ParadigmsSwe.gf |  9 ++++++++-
 src/GF/Grammar/PatternMatch.hs       | 22 +++++++++++++++++++---
 3 files changed, 31 insertions(+), 4 deletions(-)

diff --git a/lib/resource/Make.hs b/lib/resource/Make.hs
index 9d42e1e3f..6de938e24 100644
--- a/lib/resource/Make.hs
+++ b/lib/resource/Make.hs
@@ -85,6 +85,9 @@ make xx = do
   ifx "lang" $ do
     mapM_ (gfc pres [] . lang) (optl langsLang)
     copy "*/*.gfo" dir
+  ifx "compat" $ do
+    mapM_ (gfc pres [] . compat) (optl langsLang)
+    copy "*/*.gfo" dir
   ifx "api" $ do
     mapM_ (gfc pres presApiPath . try) (optl langsAPI)
     copy "*/*.gfo" dir
@@ -132,6 +135,7 @@ demos abstr ls = "gr -number=100 | l -treebank " ++ unlexer abstr ls ++
            " | ps -to_html | wf -file=resdemo.html"
 
 lang (lla,la) = lla ++ "/All" ++ la ++ ".gf"
+compat (lla,la) = lla ++ "/Compatibility" ++ la ++ ".gf"
 try  (lla,la) = "api/Try"  ++ la ++ ".gf"
 math (lla,la) = "mathematical/Mathematical"  ++ la ++ ".gf"
 symbolic (lla,la) = "mathematical/Symbolic"  ++ la ++ ".gf"
diff --git a/lib/resource/swedish/ParadigmsSwe.gf b/lib/resource/swedish/ParadigmsSwe.gf
index e49fe2105..32a4d4b43 100644
--- a/lib/resource/swedish/ParadigmsSwe.gf
+++ b/lib/resource/swedish/ParadigmsSwe.gf
@@ -312,9 +312,16 @@ oper
     mkN : (apa : Str) -> N = regN ;
     mkN : Str -> Gender -> N = regGenN ; 
     mkN : (nyckel, nycklar : Str) -> N = mk2N ; 
-    mkN : (museum,museet,museer,museerna : Str) -> N = mk4N
+    mkN : (museum,museet,museer,museerna : Str) -> N = mk4N ;
+    mkN : Str -> N -> N = compoundN ;
   } ;
 
+  compoundN : Str -> N -> N = \s,no -> {
+    s = \\n,d,c => s ++ no.s ! n ! d ! c ;
+    g = no.g ;
+    lock_N = <>
+    } ;
+
   mk4N : (museum,museet,museer,museerna : Str) -> N = \apa,apan,apor,aporna ->  {
     s = nounForms apa apan apor aporna ;
     g = case last apan of {
diff --git a/src/GF/Grammar/PatternMatch.hs b/src/GF/Grammar/PatternMatch.hs
index b96d35b93..92d75f2d3 100644
--- a/src/GF/Grammar/PatternMatch.hs
+++ b/src/GF/Grammar/PatternMatch.hs
@@ -31,9 +31,23 @@ matchPattern :: [(Patt,Term)] -> Term -> Err (Term, Substitution)
 matchPattern pts term = 
   if not (isInConstantForm term)
     then prtBad "variables occur in" term
-  else 
+  else do
+    term' <- mkK term
     errIn ("trying patterns" +++ unwords (intersperse "," (map (prt . fst) pts))) $
-    findMatch [([p],t) | (p,t) <- pts] [term]
+      findMatch [([p],t) | (p,t) <- pts] [term']
+ where
+  -- to capture all Str with string pattern matching
+  mkK s = case s of
+    C _ _ -> do
+      s' <- getS s
+      return (K (unwords s'))
+    _ -> return s
+
+  getS s = case s of
+    K w -> return [w]
+    C v w -> liftM2 (++) (getS v) (getS w)
+    Empty -> return []
+    _ -> prtBad "cannot get string from" s
 
 testOvershadow :: [Patt] -> [Term] -> Err [Patt]
 testOvershadow pts vs = do
@@ -57,7 +71,8 @@ tryMatch (p,t) = do
   t' <- termForm t
   trym p t'
  where
-  isInConstantFormt = True -- tested already
+
+  isInConstantFormt = True -- tested already in matchPattern
   trym p t' =
     case (p,t') of
       (PVal _ i, (_,Val _ j,_)) 
@@ -129,6 +144,7 @@ isInConstantForm trm = case trm of
     Q _ _    -> True
     QC _ _   -> True
     Abs _ _  -> True
+    C c a    -> isInConstantForm c && isInConstantForm a
     App c a  -> isInConstantForm c && isInConstantForm a
     R r      -> all (isInConstantForm . snd . snd) r
     K _      -> True