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

putting pattern macros in place (not properly tested yet)

Browse Source
This commit is contained in:
aarne
2008-03-15 21:02:59 +00:00
parent e60237136b
commit 6cbb8086c8
12 changed files with 131 additions and 46 deletions
Download Patch File Download Diff File Expand all files Collapse all files

24
src/GF/Compile/Rename.hs
View File

@@ -226,6 +226,10 @@ renameTerm env vars = ren vars where
Ok t -> return t -- const proj last
_ -> prtBad "unknown qualified constant" trm
EPatt p -> do
(p',_) <- renpatt p
return $ EPatt p'
_ -> composOp (ren vs) trm
renid = renameIdentTerm env
@@ -239,11 +243,17 @@ renameTerm env vars = ren vars where
renamePattern :: Status -> Patt -> Err (Patt,[Ident])
renamePattern env patt = case patt of
PMacro c -> do
c' <- renid $ Vr c
case c' of
Q p d -> renp $ PM p d
_ -> prtBad "unresolved pattern" patt
PC c ps -> do
c' <- renameIdentTerm env $ Cn c
case c' of
QC p d -> renp $ PP p d ps
Q p d -> renp $ PP p d ps
-- Q p d -> renp $ PP p d ps --- why this? AR 15/3/2008
_ -> prtBad "unresolved pattern" c' ---- (PC c ps', concat vs)
PP p c ps -> do
@@ -255,8 +265,14 @@ renamePattern env patt = case patt of
let (ps',vs) = unzip psvss
return (PP p' c' ps', concat vs)
PV x -> case renid patt of
Ok p -> return (p,[])
PM p c -> do
(p', c') <- case renameIdentTerm env (Q p c) of
Ok (Q p' c') -> return (p',c')
_ -> prtBad "not a pattern macro" patt
return (PM p' c', [])
PV x -> case renid (Vr x) of
Ok (QC m c) -> return (PP m c [],[])
_ -> return (patt, [x])
PR r -> do
@@ -291,7 +307,7 @@ renamePattern env patt = case patt of
where
renp = renamePattern env
renid = renameIdentPatt env
renid = renameIdentTerm env
renameParam :: Status -> (Ident, Context) -> Err (Ident, Context)
renameParam env (c,co) = do

9
src/GF/Devel/CheckGrammar.hs
View File

@@ -580,6 +580,13 @@ inferLType gr trm = case trm of
--- checkIfComplexVariantType trm ty
check trm ty
EPattType ty -> do
ty' <- justCheck ty typeType
return (ty',typeType)
EPatt p -> do
ty <- inferPatt p
return (trm, EPattType ty)
_ -> prtFail "cannot infer lintype of" trm
where
@@ -616,6 +623,7 @@ inferLType gr trm = case trm of
PInt _ -> True
PFloat _ -> True
PChar -> True
PChars _ -> True
PSeq p q -> isConstPatt p && isConstPatt q
PAlt p q -> isConstPatt p && isConstPatt q
PRep p -> isConstPatt p
@@ -631,6 +639,7 @@ inferLType gr trm = case trm of
PSeq _ _ -> return $ typeStr
PRep _ -> return $ typeStr
PChar -> return $ typeStr
PChars _ -> return $ typeStr
_ -> infer (patt2term p) >>= return . snd

30
src/GF/Devel/Compute.hs
View File

@@ -306,7 +306,8 @@ computeTermOpt rec gr = comput True where
case allParamValues gr ptyp of
Ok vs -> do
cs' <- mapM (compBranchOpt g) cs
ps0 <- mapM (compPatternMacro . fst) cs
cs' <- mapM (compBranchOpt g) (zip ps0 (map snd cs))
sts <- mapM (matchPattern cs') vs
ts <- mapM (\ (c,g') -> comp (g' ++ g) c) sts
ps <- mapM term2patt vs
@@ -382,6 +383,33 @@ computeTermOpt rec gr = comput True where
R rs -> all (isCan . snd . snd) rs
_ -> False
compPatternMacro p = case p of
PM m c -> case look m c of
Ok (EPatt p') -> compPatternMacro p'
_ -> prtBad "pattern expected as value of" p ---- should be in CheckGr
PAs x p -> do
p' <- compPatternMacro p
return $ PAs x p'
PAlt p q -> do
p' <- compPatternMacro p
q' <- compPatternMacro q
return $ PAlt p' q'
PSeq p q -> do
p' <- compPatternMacro p
q' <- compPatternMacro q
return $ PSeq p' q'
PRep p -> do
p' <- compPatternMacro p
return $ PRep p'
PNeg p -> do
p' <- compPatternMacro p
return $ PNeg p'
PR rs -> do
rs' <- mapPairsM compPatternMacro rs
return $ PR rs'
_ -> return p
compBranch g (p,v) = do
let g' = contP p ++ g
v' <- comp g' v

9
src/GF/Grammar/Grammar.hs
View File

@@ -158,6 +158,9 @@ data Term =
| C Term Term -- ^ concatenation: @s ++ t@
| Glue Term Term -- ^ agglutination: @s + t@
| EPatt Patt -- ^ pattern (in macro definition): # p
| EPattType Term -- ^ pattern type: pattern T
| FV [Term] -- ^ alternatives in free variation: @variants { s ; ... }@
| Alts (Term, [(Term, Term)]) -- ^ alternatives by prefix: @pre {t ; s\/c ; ...}@
@@ -190,8 +193,10 @@ data Patt =
| PAlt Patt Patt -- ^ disjunctive pattern: p1 | p2
| PSeq Patt Patt -- ^ sequence of token parts: p + q
| PRep Patt -- ^ repetition of token part: p*
| PChar -- ^ string of length one
| PChars [Char] -- ^ character list
| PChar -- ^ string of length one: ?
| PChars [Char] -- ^ character list: ["aeiou"]
| PMacro Ident -- #p
| PM Ident Ident -- #m.p
deriving (Read, Show, Eq, Ord)

20
src/GF/Grammar/Macros.hs
View File

@@ -503,6 +503,10 @@ term2patt trm = case termForm trm of
Ok ([], QC p c, aa) -> do
aa' <- mapM term2patt aa
return (PP p c aa')
Ok ([], Q p c, []) -> do
return (PM p c)
Ok ([], R r, []) -> do
let (ll,aa) = unzipR r
aa' <- mapM term2patt aa
@@ -523,6 +527,8 @@ term2patt trm = case termForm trm of
return (PRep a')
Ok ([], Cn (IC "?"), []) -> do
return PChar
Ok ([], Cn (IC "[]"),[K s]) -> do
return $ PChars s
Ok ([], Cn (IC "+"), [a,b]) -> do
a' <- term2patt a
b' <- term2patt b
@@ -532,6 +538,8 @@ term2patt trm = case termForm trm of
b' <- term2patt b
return (PAlt a' b')
Ok ([], Cn c, []) -> do
return (PMacro c)
_ -> prtBad "no pattern corresponds to term" trm
@@ -540,8 +548,12 @@ patt2term pt = case pt of
PV x -> Vr x
PW -> Vr wildIdent --- not parsable, should not occur
PVal t i -> Val t i
PMacro c -> Cn c
PM p c -> Q p c
PC c pp -> mkApp (Con c) (map patt2term pp)
PP p c pp -> mkApp (QC p c) (map patt2term pp)
PR r -> R [assign l (patt2term p) | (l,p) <- r]
PT _ p -> patt2term p
PInt i -> EInt i
@@ -550,6 +562,7 @@ patt2term pt = case pt of
PAs x p -> appc "@" [Vr x, patt2term p] --- an encoding
PChar -> appc "?" [] --- an encoding
PChars s -> appc "[]" [K s] --- an encoding
PSeq a b -> appc "+" [(patt2term a), (patt2term b)] --- an encoding
PAlt a b -> appc "|" [(patt2term a), (patt2term b)] --- an encoding
PRep a -> appc "*" [(patt2term a)] --- an encoding
@@ -731,7 +744,12 @@ composOp co trm =
return (Alts (t',aa'))
FV ts -> mapM co ts >>= return . FV
Strs tt -> mapM co tt >>= return . Strs
_ -> return trm -- covers K, Vr, Cn, Sort
EPattType ty ->
do ty' <- co ty
return (EPattType ty')
_ -> return trm -- covers K, Vr, Cn, Sort, EPatt
getTableType :: TInfo -> Err Type
getTableType i = case i of

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

@@ -111,13 +111,15 @@ tryMatch (p,t) = do
matches <- checks [mapM tryMatch [(p1,K s1),(p2,K s2)] | (s1,s2) <- cuts]
return (concat matches)
(PChar, ([],K [_],[])) -> return []
(PRep p1, ([],K s, [])) -> checks [
trym (foldr (const (PSeq p1)) (PString "")
[1..n]) t' | n <- [0 .. length s]
] >>
return []
(PChar, ([],K [_], [])) -> return []
(PChars cs, ([],K [c], [])) | elem c cs -> return []
_ -> prtBad "no match in case expr for" t
isInConstantForm :: Term -> Bool

4
src/GF/Source/GF.cf
View File

@@ -192,8 +192,8 @@ EPre. Exp4 ::= "pre" "{" Exp ";" [Altern] "}" ;
EStrs. Exp4 ::= "strs" "{" [Exp] "}" ;
EConAt. Exp4 ::= PIdent "@" Exp6 ; --%
EPatt. Exp4 ::= "pattern" Patt2 ;
EPattType. Exp4 ::= "pattern" "type" Exp5 ;
EPatt. Exp4 ::= "#" Patt2 ;
EPattType. Exp4 ::= "pattern" Exp5 ;
ESelect. Exp3 ::= Exp3 "!" Exp4 ;
ETupTyp. Exp3 ::= Exp3 "*" Exp4 ;

4
src/GF/Source/GrammarToSource.hs
View File

@@ -191,6 +191,9 @@ trt trm = case trm of
EInt i -> P.EInt i
EFloat i -> P.EFloat i
EPatt p -> P.EPatt (trp p)
EPattType t -> P.EPattType (trt t)
Glue a b -> P.EGlue (trt a) (trt b)
Alts (t, tt) -> P.EPre (trt t) [P.Alt (trt v) (trt c) | (v,c) <- tt]
FV ts -> P.EVariants $ map trt ts
@@ -221,6 +224,7 @@ trp p = case p of
PNeg p -> P.PNeg (trp p)
PChar -> P.PChar
PChars s -> P.PChars s
PM m c -> P.PM (tri m) (tri c)
trAssign (lab, (mty, t)) = maybe (P.LDDef x t') (\ty -> P.LDFull x (trt ty) t') mty

2
src/GF/Source/LexGF.hs
View File

@@ -88,7 +88,7 @@ eitherResIdent tv s = treeFind resWords
| s > a = treeFind right
| s == a = t
resWords = b "lincat" (b "def" (b "Type" (b "Str" (b "PType" (b "Lin" N N) N) (b "Tok" (b "Strs" N N) N)) (b "cat" (b "case" (b "abstract" N N) N) (b "data" (b "concrete" N N) N))) (b "include" (b "fun" (b "fn" (b "flags" N N) N) (b "in" (b "grammar" N N) N)) (b "interface" (b "instance" (b "incomplete" N N) N) (b "lin" (b "let" N N) N)))) (b "resource" (b "out" (b "of" (b "lintype" (b "lindef" N N) N) (b "oper" (b "open" N N) N)) (b "pattern" (b "param" (b "package" N N) N) (b "printname" (b "pre" N N) N))) (b "type" (b "table" (b "strs" (b "reuse" N N) N) (b "transfer" (b "tokenizer" N N) N)) (b "variants" (b "var" (b "union" N N) N) (b "with" (b "where" N N) N))))
resWords = b "lincat" (b "def" (b "Type" (b "Str" (b "PType" (b "Lin" N N) N) (b "Tok" (b "Strs" N N) N)) (b "cat" (b "case" (b "abstract" N N) N) (b "data" (b "concrete" N N) N))) (b "include" (b "fun" (b "fn" (b "flags" N N) N) (b "in" (b "grammar" N N) N)) (b "interface" (b "instance" (b "incomplete" N N) N) (b "lin" (b "let" N N) N)))) (b "resource" (b "out" (b "of" (b "lintype" (b "lindef" N N) N) (b "oper" (b "open" N N) N)) (b "pattern" (b "param" (b "package" N N) N) (b "printname" (b "pre" N N) N))) (b "union" (b "table" (b "strs" (b "reuse" N N) N) (b "transfer" (b "tokenizer" N N) N)) (b "where" (b "variants" (b "var" N N) N) (b "with" N N))))
where b s = B s (TS s)
unescapeInitTail :: String -> String

60
src/GF/Source/ParGF.hs
View File

File diff suppressed because one or more lines are too long

4
src/GF/Source/PrintGF.hs
View File

@@ -355,8 +355,8 @@ instance Print Exp where
EPre exp alterns -> prPrec i 4 (concatD [doc (showString "pre") , doc (showString "{") , prt 0 exp , doc (showString ";") , prt 0 alterns , doc (showString "}")])
EStrs exps -> prPrec i 4 (concatD [doc (showString "strs") , doc (showString "{") , prt 0 exps , doc (showString "}")])
EConAt pident exp -> prPrec i 4 (concatD [prt 0 pident , doc (showString "@") , prt 6 exp])
EPatt patt -> prPrec i 4 (concatD [doc (showString "pattern") , prt 2 patt])
EPattType exp -> prPrec i 4 (concatD [doc (showString "pattern") , doc (showString "type") , prt 5 exp])
EPatt patt -> prPrec i 4 (concatD [doc (showString "#") , prt 2 patt])
EPattType exp -> prPrec i 4 (concatD [doc (showString "pattern") , prt 5 exp])
ESelect exp0 exp -> prPrec i 3 (concatD [prt 3 exp0 , doc (showString "!") , prt 4 exp])
ETupTyp exp0 exp -> prPrec i 3 (concatD [prt 3 exp0 , doc (showString "*") , prt 4 exp])
EExtend exp0 exp -> prPrec i 3 (concatD [prt 3 exp0 , doc (showString "**") , prt 4 exp])

5
src/GF/Source/SourceToGrammar.hs
View File

@@ -496,6 +496,9 @@ transExp x = case x of
ELetb defs exp -> transExp $ ELet defs exp
EWhere exp defs -> transExp $ ELet defs exp
EPattType typ -> liftM G.EPattType (transExp typ)
EPatt patt -> liftM G.EPatt (transPatt patt)
ELString (LString str) -> return $ G.K str
ELin id -> liftM G.LiT $ transIdent id
@@ -608,6 +611,8 @@ transPatt x = case x of
PAs x p -> liftM2 G.PAs (transIdent x) (transPatt p)
PChar -> return G.PChar
PChars s -> return $ G.PChars s
PMacro c -> liftM G.PMacro $ transIdent c
PM m c -> liftM2 G.PM (transIdent m) (transIdent c)
transBind :: Bind -> Err Ident
transBind x = case x of