enable matching of ++ strings with regular patterns

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"

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 {

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