diff --git a/src/compiler/GF/Compile/Compute/Concrete.hs b/src/compiler/GF/Compile/Compute/Concrete.hs index a96a154d3..fa84fd0b2 100644 --- a/src/compiler/GF/Compile/Compute/Concrete.hs +++ b/src/compiler/GF/Compile/Compute/Concrete.hs @@ -19,6 +19,7 @@ import GF.Data.Operations(Err(..),err,errIn,maybeErr,mapPairsM) import GF.Data.Utilities(mapFst,mapSnd) import GF.Infra.Option import Data.STRef +import Data.Maybe(fromMaybe) import Control.Monad import Control.Monad.ST import Control.Applicative @@ -134,6 +135,11 @@ patternMatch v0 ((env0,ps,args0,t):eqs) = match env0 ps eqs args0 match env [] eqs args = eval env t args match env (PT ty p :ps) eqs args = match env (p:ps) eqs args match env (PAlt p1 p2:ps) eqs args = match env (p1:ps) ((env,p2:ps,args,t):eqs) args + match env (PM q :ps) eqs args = do t <- lookupGlobal q + case t of + EPatt _ _ p -> match env (p:ps) eqs args + _ -> evalError $ hang "Expected pattern macro:" 4 + (pp t) match env (PV v :ps) eqs (arg:args) = match ((v,arg):env) ps eqs args match env (PAs v p :ps) eqs (arg:args) = match ((v,arg):env) (p:ps) eqs (arg:args) match env (PW :ps) eqs (arg:args) = match env ps eqs args @@ -154,18 +160,16 @@ patternMatch v0 ((env0,ps,args0,t):eqs) = match env0 ps eqs args0 (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 + lo = min1 `max` (n-fromMaybe n max2) + hi = (n-min2) `min` fromMaybe n 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 (PRep minp maxp p, v) - | minp == 0 -> match env ps eqs args - | otherwise -> case value2string v of - Just s -> do let n = length s `div` minp - eqs0 = eqs - eqs <- matchRep env n minp maxp p minp maxp p ps eqs (arg:args) + -> case value2string v of + Just s -> do let n = length s `div` (max minp 1) + eqs <- matchRep env n minp maxp p minp maxp p ps ((env,PString []:ps,(arg:args),t) : eqs) (arg:args) patternMatch v0 eqs Nothing -> return v0 (PChar, VStr [_]) -> match env ps eqs args @@ -202,9 +206,9 @@ patternMatch v0 ((env0,ps,args0,t):eqs) = match env0 ps eqs args0 return ((env,ps,arg1:arg2:args,t) : eqs) matchRep env 0 minp maxp p minq maxq q ps eqs args = do - return ((env,PString []:ps,args,t) : eqs) + return eqs matchRep env n minp maxp p minq maxq q ps eqs args = do - matchRep env (n-1) minp maxp p (minp+minq) (maxp+maxq) (PSeq minp maxp p minq maxq q) ps ((env,q:ps,args,t) : eqs) args + matchRep env (n-1) minp maxp p (minp+minq) (liftM2 (+) maxp maxq) (PSeq minp maxp p minq maxq q) ps ((env,q:ps,args,t) : eqs) args vc s = case words s of diff --git a/src/compiler/GF/Compile/GeneratePMCFG.hs b/src/compiler/GF/Compile/GeneratePMCFG.hs index 106c9097a..07e6fc3ff 100644 --- a/src/compiler/GF/Compile/GeneratePMCFG.hs +++ b/src/compiler/GF/Compile/GeneratePMCFG.hs @@ -379,8 +379,8 @@ convertTerm opts sel ctype (Alts s alts)= do CStr s <- convertTerm opts CNil cty unSym (CStr [SymKS t]) = t unSym _ = ppbug $ hang ("invalid prefix in pre expression:") 4 (Alts s alts) - unPatt (EPatt p) = fmap Strs (getPatts p) - unPatt u = return u + unPatt (EPatt _ _ p) = fmap Strs (getPatts p) + unPatt u = return u getPatts p = case p of PAlt a b -> liftM2 (++) (getPatts a) (getPatts b) diff --git a/src/compiler/GF/Compile/GrammarToCanonical.hs b/src/compiler/GF/Compile/GrammarToCanonical.hs index 9debb63a2..1ed628136 100644 --- a/src/compiler/GF/Compile/GrammarToCanonical.hs +++ b/src/compiler/GF/Compile/GrammarToCanonical.hs @@ -242,7 +242,7 @@ convert' gr vs = ppT pre (K s) = [s] pre Empty = [""] -- Empty == K "" pre (Strs ts) = concatMap pre ts - pre (EPatt p) = pat p + pre (EPatt _ _ p) = pat p pre t = error $ "convert' alts pre: " ++ show t pat (PString s) = [s] diff --git a/src/compiler/GF/Compile/Rename.hs b/src/compiler/GF/Compile/Rename.hs index 75e757ffc..6889a11bf 100644 --- a/src/compiler/GF/Compile/Rename.hs +++ b/src/compiler/GF/Compile/Rename.hs @@ -237,9 +237,9 @@ renameTerm env vars = ren vars where , checkError ("unknown qualified constant" <+> trm) ] - EPatt p -> do + EPatt minp maxp p -> do (p',_) <- renpatt p - return $ EPatt p' + return $ EPatt minp maxp p' _ -> composOp (ren vs) trm diff --git a/src/compiler/GF/Compile/TypeCheck/Concrete.hs b/src/compiler/GF/Compile/TypeCheck/Concrete.hs index 1def7e65c..bce7b8585 100644 --- a/src/compiler/GF/Compile/TypeCheck/Concrete.hs +++ b/src/compiler/GF/Compile/TypeCheck/Concrete.hs @@ -265,9 +265,10 @@ inferLType gr g trm = case trm of EPattType ty -> do ty' <- justCheck g ty typeType return (EPattType ty',typeType) - EPatt p -> do + EPatt _ _ p -> do ty <- inferPatt p - return (trm, EPattType ty) + let (minp,maxp,p') = measurePatt gr p + return (EPatt minp maxp p', EPattType ty) ELin c trm -> do (trm',ty) <- inferLType gr g trm @@ -321,29 +322,34 @@ inferLType gr g trm = case trm of PChars _ -> return $ typeStr _ -> inferLType gr g (patt2term p) >>= return . snd -measurePatt p = +measurePatt gr p = case p of - PR ass -> let p' = PR (map (\(lbl,p) -> let (_,_,p') = measurePatt p in (lbl,p')) ass) + PM q -> case lookupResDef gr q of + Ok t -> case t of + EPatt minp maxp _ -> (minp,maxp,p) + _ -> error "Expected pattern macro" + Bad msg -> error msg + PR ass -> let p' = PR (map (\(lbl,p) -> let (_,_,p') = measurePatt gr 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 + PT t p -> let (min,max,p') = measurePatt gr p in (min,max,PT t p') - PAs x p -> let (min,max,p') = measurePatt p + PAs x p -> let (min,max,p') = measurePatt gr p in (min,max,PAs x p') - PImplArg p -> let (min,max,p') = measurePatt p + PImplArg p -> let (min,max,p') = measurePatt gr p in (min,max,PImplArg p') - PNeg p -> let (_,_,p') = measurePatt p + PNeg p -> let (_,_,p') = measurePatt gr p in (0,Nothing,PNeg p') - PAlt p1 p2 -> let (min1,max1,p1') = measurePatt p1 - (min2,max2,p2') = measurePatt p2 + PAlt p1 p2 -> let (min1,max1,p1') = measurePatt gr p1 + (min2,max2,p2') = measurePatt gr 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 (minp,maxp,p') = measurePatt p - in (0,Nothing,PRep minp (fromMaybe maxBound maxp) p') + -> let (min1,max1,p1') = measurePatt gr p1 + (min2,max2,p2') = measurePatt gr p2 + in (min1+min2,liftM2 (+) max1 max2,PSeq min1 max1 p1' min2 max2 p2') + PRep _ _ p -> let (minp,maxp,p') = measurePatt gr p + in (0,Nothing,PRep minp maxp p') PChar -> (1,Just 1,p) PChars _ -> (1,Just 1,p) _ -> (0,Nothing,p) @@ -624,7 +630,7 @@ 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 - let (_,_,p') = measurePatt p + let (_,_,p') = measurePatt gr p return (p',t') pattContext :: SourceGrammar -> Context -> Type -> Patt -> Check Context diff --git a/src/compiler/GF/Grammar/Binary.hs b/src/compiler/GF/Grammar/Binary.hs index 998c8bb9e..0cff7384a 100644 --- a/src/compiler/GF/Grammar/Binary.hs +++ b/src/compiler/GF/Grammar/Binary.hs @@ -182,7 +182,7 @@ instance Binary Term where put (QC x) = putWord8 25 >> put x put (C x y) = putWord8 26 >> put (x,y) put (Glue x y) = putWord8 27 >> put (x,y) - put (EPatt x) = putWord8 28 >> put x + put (EPatt x y z) = putWord8 28 >> put (x,y,z) put (EPattType x) = putWord8 29 >> put x put (ELincat x y) = putWord8 30 >> put (x,y) put (ELin x y) = putWord8 31 >> put (x,y) @@ -221,7 +221,7 @@ instance Binary Term where 25 -> get >>= \x -> return (QC x) 26 -> get >>= \(x,y) -> return (C x y) 27 -> get >>= \(x,y) -> return (Glue x y) - 28 -> get >>= \x -> return (EPatt x) + 28 -> get >>= \(x,y,z) -> return (EPatt x y z) 29 -> get >>= \x -> return (EPattType x) 30 -> get >>= \(x,y) -> return (ELincat x y) 31 -> get >>= \(x,y) -> return (ELin x y) diff --git a/src/compiler/GF/Grammar/Grammar.hs b/src/compiler/GF/Grammar/Grammar.hs index 3575b782c..cbd5f0a5b 100644 --- a/src/compiler/GF/Grammar/Grammar.hs +++ b/src/compiler/GF/Grammar/Grammar.hs @@ -386,7 +386,7 @@ data Term = | C Term Term -- ^ concatenation: @s ++ t@ | Glue Term Term -- ^ agglutination: @s + t@ - | EPatt Patt -- ^ pattern (in macro definition): # p + | EPatt Int (Maybe Int) Patt -- ^ pattern (in macro definition): # p | EPattType Term -- ^ pattern type: pattern T | ELincat Ident Term -- ^ boxed linearization type of Ident @@ -421,12 +421,12 @@ data Patt = -- regular expression patterns | PNeg Patt -- ^ negated pattern: -p | PAlt Patt Patt -- ^ disjunctive pattern: p1 | p2 - | PSeq {-# UNPACK #-} !Int {-# UNPACK #-} !Int Patt {-# UNPACK #-} !Int {-# UNPACK #-} !Int Patt + | PSeq Int (Maybe Int) Patt Int (Maybe Int) Patt -- ^ sequence of token parts: p + q -- In the constructor PSeq minp maxp p minq maxq q, -- minp/maxp and minq/maxq are the minimal/maximal -- length of a matching string for p/q. - | PRep {-# UNPACK #-} !Int {-# UNPACK #-} !Int Patt + | PRep Int (Maybe Int) Patt -- ^ repetition of token part: p* -- In the constructor PRep minp maxp p, -- minp/maxp is the minimal/maximal length of diff --git a/src/compiler/GF/Grammar/Macros.hs b/src/compiler/GF/Grammar/Macros.hs index 9dcc83f0b..bad091c55 100644 --- a/src/compiler/GF/Grammar/Macros.hs +++ b/src/compiler/GF/Grammar/Macros.hs @@ -384,7 +384,7 @@ term2patt trm = case termForm trm of return (PNeg a') Ok ([], Cn id, [a]) | id == cRep -> do a' <- term2patt a - return (PRep 0 maxBound a') + return (PRep 0 Nothing a') Ok ([], Cn id, []) | id == cRep -> do return PChar Ok ([], Cn id,[K s]) | id == cChars -> do @@ -392,7 +392,7 @@ term2patt trm = case termForm trm of Ok ([], Cn id, [a,b]) | id == cSeq -> do a' <- term2patt a b' <- term2patt b - return (PSeq 0 maxBound a' 0 maxBound b') + return (PSeq 0 Nothing a' 0 Nothing b') Ok ([], Cn id, [a,b]) | id == cAlt -> do a' <- term2patt a b' <- term2patt b @@ -475,8 +475,8 @@ composPattOp op patt = PImplArg p -> liftM PImplArg (op p) PNeg p -> liftM PNeg (op p) PAlt p1 p2 -> liftM2 PAlt (op p1) (op p2) - PSeq _ _ p1 _ _ p2 -> liftM2 (\p1 p2 -> PSeq 0 maxBound p1 0 maxBound p2) (op p1) (op p2) - PRep _ _ p -> liftM (PRep 0 maxBound) (op p) + PSeq _ _ p1 _ _ p2 -> liftM2 (\p1 p2 -> PSeq 0 Nothing p1 0 Nothing p2) (op p1) (op p2) + PRep _ _ p -> liftM (PRep 0 Nothing) (op p) _ -> return patt -- covers cases without subpatterns collectOp :: Monoid m => (Term -> m) -> Term -> m diff --git a/src/compiler/GF/Grammar/Parser.y b/src/compiler/GF/Grammar/Parser.y index 58742416d..5959480ef 100644 --- a/src/compiler/GF/Grammar/Parser.y +++ b/src/compiler/GF/Grammar/Parser.y @@ -444,7 +444,7 @@ Exp4 | 'pre' '{' String ';' ListAltern '}' { Alts (K $3) $5 } | 'pre' '{' Ident ';' ListAltern '}' { Alts (Vr $3) $5 } | 'strs' '{' ListExp '}' { Strs $3 } - | '#' Patt3 { EPatt $2 } + | '#' Patt3 { EPatt 0 Nothing $2 } | 'pattern' Exp5 { EPattType $2 } | 'lincat' Ident Exp5 { ELincat $2 $3 } | 'lin' Ident Exp5 { ELin $2 $3 } @@ -485,14 +485,14 @@ Exps Patt :: { Patt } Patt : Patt '|' Patt1 { PAlt $1 $3 } - | Patt '+' Patt1 { PSeq 0 maxBound $1 0 maxBound $3 } + | Patt '+' Patt1 { PSeq 0 Nothing $1 0 Nothing $3 } | Patt1 { $1 } Patt1 :: { Patt } Patt1 : Ident ListPatt { PC $1 $2 } | ModuleName '.' Ident ListPatt { PP ($1,$3) $4 } - | Patt3 '*' { PRep 0 maxBound $1 } + | Patt3 '*' { PRep 0 Nothing $1 } | Patt2 { $1 } Patt2 :: { Patt } diff --git a/src/compiler/GF/Grammar/PatternMatch.hs b/src/compiler/GF/Grammar/PatternMatch.hs index ae10c37c3..53a99fe56 100644 --- a/src/compiler/GF/Grammar/PatternMatch.hs +++ b/src/compiler/GF/Grammar/PatternMatch.hs @@ -24,7 +24,7 @@ import GF.Infra.Ident import GF.Grammar.Macros --import GF.Grammar.Printer ---import Data.List +import Data.Maybe(fromMaybe) import Control.Monad import GF.Text.Pretty --import Debug.Trace @@ -124,7 +124,7 @@ tryMatch (p,t) = do (PSeq min1 max1 p1 min2 max2 p2, ([],K s, [])) -> matchPSeq min1 max1 p1 min2 max2 p2 s (PRep _ _ p1, ([],K s, [])) -> checks [ - trym (foldr (const (PSeq 0 maxBound p1 0 maxBound)) (PString "") + trym (foldr (const (PSeq 0 Nothing p1 0 Nothing)) (PString "") [1..n]) t' | n <- [0 .. length s] ] >> return [] @@ -140,8 +140,8 @@ tryMatch (p,t) = do matchPSeq min1 max1 p1 min2 max2 p2 s = do let n = length s - lo = min1 `max` (n-max2) - hi = (n-min2) `min` max1 + lo = min1 `max` (n-fromMaybe n max2) + hi = (n-min2) `min` (fromMaybe n max1) cuts = [splitAt i s | i <- [lo..hi]] matches <- checks [mapM tryMatch [(p1,K s1),(p2,K s2)] | (s1,s2) <- cuts] return (concat matches) diff --git a/src/compiler/GF/Grammar/Printer.hs b/src/compiler/GF/Grammar/Printer.hs index a34c665f2..475d77f72 100644 --- a/src/compiler/GF/Grammar/Printer.hs +++ b/src/compiler/GF/Grammar/Printer.hs @@ -213,7 +213,7 @@ ppTerm q d (FV es) = prec d 4 ("variants" <+> braces (fsep (punctuate ';' (m ppTerm q d (AdHocOverload es) = "overload" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es))) ppTerm q d (Alts e xs) = prec d 4 ("pre" <+> braces (ppTerm q 0 e <> ';' <+> fsep (punctuate ';' (map (ppAltern q) xs)))) ppTerm q d (Strs es) = "strs" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es))) -ppTerm q d (EPatt p) = prec d 4 ('#' <+> ppPatt q 2 p) +ppTerm q d (EPatt _ _ p)=prec d 4 ('#' <+> ppPatt q 2 p) ppTerm q d (EPattType t)=prec d 4 ("pattern" <+> ppTerm q 0 t) ppTerm q d (P t l) = prec d 5 (ppTerm q 5 t <> '.' <> l) ppTerm q d (Cn id) = pp id diff --git a/testsuite/compiler/compute/param_table.gf b/testsuite/compiler/compute/param_table.gf index a6a56ba33..e52b252bd 100644 --- a/testsuite/compiler/compute/param_table.gf +++ b/testsuite/compiler/compute/param_table.gf @@ -3,4 +3,12 @@ resource param_table = { param Q = Q1 | Q2 ; param P = P1 | P2 Q ; +oper ab_patt = #["ab"]; + +oper test : Str -> Q = \s -> + case s of { + #ab_patt + _ => Q1 ; + _ => Q2 + } ; + } diff --git a/testsuite/compiler/compute/string_matching.gfs b/testsuite/compiler/compute/string_matching.gfs index 0da0b70e8..72088c964 100644 --- a/testsuite/compiler/compute/string_matching.gfs +++ b/testsuite/compiler/compute/string_matching.gfs @@ -23,3 +23,6 @@ cc x; _ => "?"} : Str> cc x; _ => "?"} : Str> cc x; _ => "?"} : Str> cc x; _ => "?"} : Str> +cc x; _ => "?"} : Str> +cc test "abcd" +cc test "xyz" diff --git a/testsuite/compiler/compute/string_matching.gfs.gold b/testsuite/compiler/compute/string_matching.gfs.gold index c8f218e57..c60c2ab0c 100644 --- a/testsuite/compiler/compute/string_matching.gfs.gold +++ b/testsuite/compiler/compute/string_matching.gfs.gold @@ -22,3 +22,6 @@ param_table.Q2 "abcdefghi" "aaaaxy" "xy" +"xy" +param_table.Q1 +param_table.Q2