implement measured patterns

src/compiler/GF/Compile/Compute/Concrete.hs

@@ -25,6 +25,7 @@ import Control.Applicative
 import qualified Control.Monad.Fail as Fail
 import qualified Data.Map as Map
 import GF.Text.Pretty
+import Debug.Trace
 
 -- * Main entry points
 
@@ -151,13 +152,15 @@ patternMatch v0 ((env0,ps,args0,t):eqs) = match env0 ps eqs args0
           | s1 == s2      -> match env ps eqs args
         (PString s1, VC [])
           | null s1       -> match env ps eqs args
-        (PSeq p1 p2,VStr s)
-                          -> do eqs <- matchStr env (p1:p2:ps) eqs [] [] s [] args
-                                patternMatch v0 eqs
-        (PSeq p1 p2,VC vs)-> do mb_eqs <- matchSeq env (p1:p2:ps) eqs [] vs args
-                                case mb_eqs of
-                                  Just eqs -> patternMatch v0 eqs
-                                  Nothing  -> return v0
+        (PSeq min1 max1 p1 min2 max2 p2,v)
+                          -> case value2string v of
+                               Just s  -> do let n  = length s
+                                                 lo = min1 `max` (n-max2)
+                                                 hi = (n-min2) `min` max1
+                                                 (ds,cs) = splitAt lo s
+                                             eqs <- matchStr env (p1:p2:ps) eqs (hi-lo) (reverse ds) cs args
+                                             patternMatch v0 eqs
+                               Nothing -> return v0
         (PChar, VStr [_]) -> match env ps eqs args
         (PChars cs, VStr [c])
           | elem c cs     -> match env ps eqs args
@@ -173,29 +176,29 @@ patternMatch v0 ((env0,ps,args0,t):eqs) = match env0 ps eqs args0
         Just tnk -> matchRec env pas as (p:ps) eqs (tnk:args)
         Nothing  -> evalError ("Missing value for label" <+> pp lbl)
 
-    matchSeq env ps eqs ws []     args = return (Just eqs)
-    matchSeq env ps eqs ws (v:vs) args = do
-      mb_eqs <- matchSeq env ps eqs (v:ws) vs args
-      case v of
-        VStr []     -> return mb_eqs
-        VStr (c:cs) -> case mb_eqs of
-                         Just eqs -> do eqs <- matchStr env ps eqs ws [c] cs vs args
-                                        return (Just eqs)
-                         Nothing  -> return Nothing
-        _           -> return Nothing
+    value2string (VStr s) = Just s
+    value2string (VC vs)  = fmap unwords (mapM value2string vs)
+    value2string _        = Nothing
 
-    matchStr env ps eqs ws ds []     vs args = do
-      arg1 <- newEvaluatedThunk (vc (reverse (VStr (reverse ds):ws)))
-      arg2 <- newEvaluatedThunk (vc vs)
+    matchStr env ps eqs i ds []     args = do
+      arg1 <- newEvaluatedThunk (vc (reverse ds))
+      arg2 <- newEvaluatedThunk (vc [])
       return ((env,ps,arg1:arg2:args,t) : eqs)
-    matchStr env ps eqs ws ds (c:cs) vs args = do
-      arg1 <- newEvaluatedThunk (vc (reverse (if null ds then ws else VStr (reverse ds):ws)))
-      arg2 <- newEvaluatedThunk (vc (VStr (c:cs):vs))
-      eqs  <- matchStr env ps eqs ws (c:ds) cs vs args
+    matchStr env ps eqs 0 ds cs     args = do
+      arg1 <- newEvaluatedThunk (vc (reverse ds))
+      arg2 <- newEvaluatedThunk (vc cs)
+      return ((env,ps,arg1:arg2:args,t) : eqs)
+    matchStr env ps eqs i ds (c:cs) args = do
+      arg1 <- newEvaluatedThunk (vc (reverse ds))
+      arg2 <- newEvaluatedThunk (vc (c:cs))
+      eqs  <- matchStr env ps eqs (i-1 :: Int) (c:ds) cs args
       return ((env,ps,arg1:arg2:args,t) : eqs)
 
-    vc [x] = x
-    vc xs  = VC xs
+    vc s =
+      case words s of
+        []  -> VC []
+        [w] -> VStr w
+        ws  -> VC (map VStr ws)
 
 value2term i (VApp q tnks) =
   foldM (\e1 tnk -> fmap (App e1) (force tnk [] >>= value2term i)) (QC q) tnks

src/compiler/GF/Compile/GeneratePMCFG.hs

@@ -385,7 +385,7 @@ convertTerm opts sel ctype (Alts s alts)= do CStr s <- convertTerm opts CNil cty
     getPatts p = case p of
       PAlt a b  -> liftM2 (++) (getPatts a) (getPatts b)
       PString s -> return [K s]
-      PSeq a b  -> do
+      PSeq _ _ a _ _ b  -> do
         as <- getPatts a
         bs <- getPatts b
         return [K (s ++ t) | K s <- as, K t <- bs]

src/compiler/GF/Compile/GrammarToCanonical.hs

@@ -247,7 +247,7 @@ convert' gr vs = ppT
 
         pat (PString s) = [s]
         pat (PAlt p1 p2) = pat p1++pat p2
-        pat (PSeq p1 p2) = [s1++s2 | s1<-pat p1, s2<-pat p2]
+        pat (PSeq _ _ p1 _ _ p2) = [s1++s2 | s1<-pat p1, s2<-pat p2]
         pat p = error $ "convert' alts pat: "++show p
 
     fields = map field . filter (not.isLockLabel.fst)

src/compiler/GF/Compile/Rename.hs

@@ -306,10 +306,10 @@ renamePattern env patt =
         (q',ws) <- renp q
         return (PAlt p' q', vs ++ ws)
 
-      PSeq p q -> do
+      PSeq minp maxp p minq maxq q -> do
         (p',vs) <- renp p
         (q',ws) <- renp q
-        return (PSeq p' q', vs ++ ws)
+        return (PSeq minp maxp p' minq maxq q', vs ++ ws)
 
       PRep p -> do
         (p',vs) <- renp p

src/compiler/GF/Compile/TypeCheck/Concrete.hs

@@ -13,6 +13,7 @@ import GF.Grammar.Lockfield (isLockLabel, lockRecType, unlockRecord)
 import GF.Compile.TypeCheck.Primitives
 
 import Data.List
+import Data.Maybe(fromMaybe)
 import Control.Monad
 import GF.Text.Pretty
 
@@ -290,7 +291,7 @@ inferLType gr g trm = case trm of
    inferCase mty (patt,term) = do
      arg  <- maybe (inferPatt patt) return mty
      cont <- pattContext gr g arg patt
-     (_,val) <- inferLType gr (reverse cont ++ g) term
+     (term',val) <- inferLType gr (reverse cont ++ g) term
      return (arg,val)
    isConstPatt p = case p of
      PC _ ps -> True --- all isConstPatt ps
@@ -302,7 +303,7 @@ inferLType gr g trm = case trm of
      PFloat _ -> True
      PChar -> True
      PChars _ -> True
-     PSeq p q -> isConstPatt p && isConstPatt q
+     PSeq _ _ p _ _ q -> isConstPatt p && isConstPatt q
      PAlt p q -> isConstPatt p && isConstPatt q
      PRep p -> isConstPatt p
      PNeg p -> isConstPatt p
@@ -314,12 +315,39 @@ inferLType gr g trm = case trm of
      PAs _ p  -> inferPatt p
      PNeg p   -> inferPatt p
      PAlt p q -> checks [inferPatt p, inferPatt q]
-     PSeq _ _ -> return $ typeStr
+     PSeq _ _ _ _ _ _ -> return $ typeStr
      PRep _   -> return $ typeStr
      PChar    -> return $ typeStr
      PChars _ -> return $ typeStr
      _ -> inferLType gr g (patt2term p) >>= return . snd
 
+measurePatt p =
+  case p of
+    PR ass     -> let p' = PR (map (\(lbl,p) -> let (_,_,p') = measurePatt p in (lbl,p')) ass)
+                  in (0,Nothing,p')
+    PString s  -> let len=length s
+                  in (len,Just len,p)
+    PT t p     -> let (min,max,p') = measurePatt p
+                  in (min,max,PT t p')
+    PAs x p    -> let (min,max,p') = measurePatt p
+                  in (min,max,PAs x p')
+    PImplArg p -> let (min,max,p') = measurePatt p
+                  in (min,max,PImplArg p')
+    PNeg p     -> let (_,_,p') = measurePatt p
+                  in (0,Nothing,PNeg p')
+    PAlt p1 p2 -> let (min1,max1,p1') = measurePatt p1
+                      (min2,max2,p2') = measurePatt p2
+                  in (min min1 min2,liftM2 max max1 max2,PAlt p1' p2')
+    PSeq _ _ p1 _ _ p2
+               -> let (min1,max1,p1') = measurePatt p1
+                      (min2,max2,p2') = measurePatt p2
+                  in (min1+min2,liftM2 (+) max1 max2,PSeq min1 (fromMaybe maxBound max1) p1' min2 (fromMaybe maxBound max2) p2')
+    PRep p     -> let (_,_,p') = measurePatt p
+                  in (0,Nothing,PRep p')
+    PChar      -> (1,Just 1,p)
+    PChars _   -> (1,Just 1,p)
+    _          -> (0,Nothing,p)
+
 -- type inference: Nothing, type checking: Just t
 -- the latter permits matching with value type
 getOverload :: SourceGrammar -> Context -> Maybe Type -> Term -> Check (Maybe (Term,Type))
@@ -596,7 +624,8 @@ checkLType gr g trm typ0 = do
    checkCase arg val (p,t) = do
      cont <- pattContext gr g arg p
      t' <- justCheck (reverse cont ++ g) t val
-     return (p,t')
+     let (_,_,p') = measurePatt p
+     return (p',t')
 
 pattContext :: SourceGrammar -> Context -> Type -> Patt -> Check Context
 pattContext env g typ p = case p of
@@ -633,7 +662,7 @@ pattContext env g typ p = case p of
        fsep pts <+>
        "in pattern alterantives" <+> ppPatt Unqualified 0 p) (null pts)
     return g1 -- must be g1 == g2
-  PSeq p q -> do
+  PSeq _ _ p _ _ q -> do
     g1 <- pattContext env g typ p
     g2 <- pattContext env g typ q
     return $ g1 ++ g2

src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs

@@ -318,7 +318,7 @@ tcPatt ge scope (PString s) ty0 = do
 tcPatt ge scope PChar ty0 = do
   unify ge scope ty0 vtypeStr
   return scope
-tcPatt ge scope (PSeq p1 p2) ty0 = do
+tcPatt ge scope (PSeq _ _ p1 _ _ p2) ty0 = do
   unify ge scope ty0 vtypeStr
   scope <- tcPatt ge scope p1 vtypeStr
   scope <- tcPatt ge scope p2 vtypeStr