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