msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

implemented pattern macros

Browse Source
This commit is contained in:
krangelov
2021-09-29 17:38:53 +02:00
parent 6efb878c43
commit 0229329d7c
14 changed files with 71 additions and 47 deletions
Download Patch File Download Diff File Expand all files Collapse all files

22
src/compiler/GF/Compile/Compute/Concrete.hs
View File

@@ -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

4
src/compiler/GF/Compile/GeneratePMCFG.hs
View File

@@ -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)

2
src/compiler/GF/Compile/GrammarToCanonical.hs
View File

@@ -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]

4
src/compiler/GF/Compile/Rename.hs
View File

@@ -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

38
src/compiler/GF/Compile/TypeCheck/Concrete.hs
View File

@@ -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

4
src/compiler/GF/Grammar/Binary.hs
View File

@@ -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)

6
src/compiler/GF/Grammar/Grammar.hs
View File

@@ -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

8
src/compiler/GF/Grammar/Macros.hs
View File

@@ -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

6
src/compiler/GF/Grammar/Parser.y
View File

@@ -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 }

8
src/compiler/GF/Grammar/PatternMatch.hs
View File

@@ -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)

2
src/compiler/GF/Grammar/Printer.hs
View File

@@ -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

8
testsuite/compiler/compute/param_table.gf
View File

@@ -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
} ;
}

3
testsuite/compiler/compute/string_matching.gfs
View File

@@ -23,3 +23,6 @@ cc <case "abcdefghi" of {""+x => x; _ => "?"} : Str>
cc <case "abcdefghi" of {x+"" => x; _ => "?"} : Str>
cc <case "aaaaxy" of {"a"* + x => x; _ => "?"} : Str>
cc <case "xybbbbb" of {x + "b"* => x; _ => "?"} : Str>
cc <case "xyababbbab" of {x + #ab_patt* => x; _ => "?"} : Str>
cc test "abcd"
cc test "xyz"

3
testsuite/compiler/compute/string_matching.gfs.gold
View File

@@ -22,3 +22,6 @@ param_table.Q2
"abcdefghi"
"aaaaxy"
"xy"
"xy"
param_table.Q1
param_table.Q2