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

refactoring in GF.Grammar.Grammar

Browse Source
This commit is contained in:
krasimir
2010-05-28 14:15:15 +00:00
parent b3d6f01f40
commit c3f4c3eba7
21 changed files with 216 additions and 217 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -146,14 +146,14 @@ instance Binary Term where
put (V x y) = putWord8 20 >> put (x,y)
put (S x y) = putWord8 21 >> put (x,y)
put (Let x y) = putWord8 22 >> put (x,y)
put (Q x y) = putWord8 23 >> put (x,y)
put (QC x y) = putWord8 24 >> put (x,y)
put (Q x) = putWord8 23 >> put x
put (QC x) = putWord8 24 >> put x
put (C x y) = putWord8 25 >> put (x,y)
put (Glue x y) = putWord8 26 >> put (x,y)
put (EPatt x) = putWord8 27 >> put x
put (EPattType x) = putWord8 28 >> put x
put (FV x) = putWord8 29 >> put x
put (Alts x) = putWord8 30 >> put x
put (Alts x y) = putWord8 30 >> put (x,y)
put (Strs x) = putWord8 31 >> put x
put (ELin x y) = putWord8 32 >> put (x,y)
@@ -182,21 +182,21 @@ instance Binary Term where
20 -> get >>= \(x,y) -> return (V x y)
21 -> get >>= \(x,y) -> return (S x y)
22 -> get >>= \(x,y) -> return (Let x y)
23 -> get >>= \(x,y) -> return (Q x y)
24 -> get >>= \(x,y) -> return (QC x y)
23 -> get >>= \x -> return (Q x)
24 -> get >>= \x -> return (QC x)
25 -> get >>= \(x,y) -> return (C x y)
26 -> get >>= \(x,y) -> return (Glue x y)
27 -> get >>= \x -> return (EPatt x)
28 -> get >>= \x -> return (EPattType x)
29 -> get >>= \x -> return (FV x)
30 -> get >>= \x -> return (Alts x)
30 -> get >>= \(x,y) -> return (Alts x y)
31 -> get >>= \x -> return (Strs x)
32 -> get >>= \(x,y) -> return (ELin x y)
_ -> decodingError
instance Binary Patt where
put (PC x y) = putWord8 0 >> put (x,y)
put (PP x y z) = putWord8 1 >> put (x,y,z)
put (PP x y) = putWord8 1 >> put (x,y)
put (PV x) = putWord8 2 >> put x
put (PW) = putWord8 3
put (PR x) = putWord8 4 >> put x
@@ -212,12 +212,12 @@ instance Binary Patt where
put (PChar) = putWord8 15
put (PChars x) = putWord8 16 >> put x
put (PMacro x) = putWord8 17 >> put x
put (PM x y) = putWord8 18 >> put (x,y)
put (PM x) = putWord8 18 >> put x
put (PTilde x) = putWord8 19 >> put x
get = do tag <- getWord8
case tag of
0 -> get >>= \(x,y) -> return (PC x y)
1 -> get >>= \(x,y,z) -> return (PP x y z)
1 -> get >>= \(x,y) -> return (PP x y)
2 -> get >>= \x -> return (PV x)
3 -> return (PW)
4 -> get >>= \x -> return (PR x)
@@ -233,7 +233,7 @@ instance Binary Patt where
15 -> return (PChar)
16 -> get >>= \x -> return (PChars x)
17 -> get >>= \x -> return (PMacro x)
18 -> get >>= \(x,y) -> return (PM x y)
18 -> get >>= \x -> return (PM x)
19 -> get >>= \x -> return (PTilde x)
_ -> decodingError

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

@@ -145,8 +145,8 @@ data Term =
| Let LocalDef Term -- ^ local definition: @let {t : T = a} in b@
| Q Ident Ident -- ^ qualified constant from a package
| QC Ident Ident -- ^ qualified constructor from a package
| Q QIdent -- ^ qualified constant from a package
| QC QIdent -- ^ qualified constructor from a package
| C Term Term -- ^ concatenation: @s ++ t@
| Glue Term Term -- ^ agglutination: @s + t@
@@ -159,14 +159,14 @@ data Term =
| FV [Term] -- ^ alternatives in free variation: @variants { s ; ... }@
| Alts (Term, [(Term, Term)]) -- ^ alternatives by prefix: @pre {t ; s\/c ; ...}@
| Alts Term [(Term, Term)] -- ^ alternatives by prefix: @pre {t ; s\/c ; ...}@
| Strs [Term] -- ^ conditioning prefix strings: @strs {s ; ...}@
deriving (Show, Eq, Ord)
data Patt =
PC Ident [Patt] -- ^ constructor pattern: @C p1 ... pn@ @C@
| PP Ident Ident [Patt] -- ^ package constructor pattern: @P.C p1 ... pn@ @P.C@
| PP QIdent [Patt] -- ^ package constructor pattern: @P.C p1 ... pn@ @P.C@
| PV Ident -- ^ variable pattern: @x@
| PW -- ^ wild card pattern: @_@
| PR [(Label,Patt)] -- ^ record pattern: @{r = p ; ...}@ -- only concrete
@@ -188,7 +188,7 @@ data Patt =
| PChar -- ^ string of length one: ?
| PChars [Char] -- ^ character list: ["aeiou"]
| PMacro Ident -- #p
| PM Ident Ident -- #m.p
| PM QIdent -- #m.p
deriving (Show, Eq, Ord)

60
src/compiler/GF/Grammar/Lookup.hs
View File

@@ -21,14 +21,14 @@ module GF.Grammar.Lookup (
lookupOrigInfo,
allOrigInfos,
lookupResDef,
lookupResType,
lookupResType,
lookupOverload,
lookupParamValues,
allParamValues,
lookupAbsDef,
lookupLincat,
lookupFunType,
lookupCatContext
lookupParamValues,
allParamValues,
lookupAbsDef,
lookupLincat,
lookupFunType,
lookupCatContext
) where
import GF.Data.Operations
@@ -58,8 +58,8 @@ lookupIdent c t =
lookupIdentInfo :: ModInfo a -> Ident -> Err a
lookupIdentInfo mo i = lookupIdent i (jments mo)
lookupResDef :: SourceGrammar -> Ident -> Ident -> Err Term
lookupResDef gr m c
lookupResDef :: SourceGrammar -> QIdent -> Err Term
lookupResDef gr (m,c)
| isPredefCat c = lock c defLinType
| otherwise = look m c
where
@@ -68,7 +68,7 @@ lookupResDef gr m c
info <- lookupIdentInfo mo c
case info of
ResOper _ (Just (L _ t)) -> return t
ResOper _ Nothing -> return (Q m c)
ResOper _ Nothing -> return (Q (m,c))
CncCat (Just (L _ ty)) _ _ -> lock c ty
CncCat _ _ _ -> lock c defLinType
@@ -76,12 +76,12 @@ lookupResDef gr m c
CncFun _ (Just (L _ tr)) _ -> return tr
AnyInd _ n -> look n c
ResParam _ _ -> return (QC m c)
ResValue _ -> return (QC m c)
ResParam _ _ -> return (QC (m,c))
ResValue _ -> return (QC (m,c))
_ -> Bad $ render (ppIdent c <+> text "is not defined in resource" <+> ppIdent m)
lookupResType :: SourceGrammar -> Ident -> Ident -> Err Type
lookupResType gr m c = do
lookupResType :: SourceGrammar -> QIdent -> Err Type
lookupResType gr (m,c) = do
mo <- lookupModule gr m
info <- lookupIdentInfo mo c
case info of
@@ -92,53 +92,51 @@ lookupResType gr m c = do
CncFun (Just (cat,cont,val)) _ _ -> do
val' <- lock cat val
return $ mkProd cont val' []
AnyInd _ n -> lookupResType gr n c
AnyInd _ n -> lookupResType gr (n,c)
ResParam _ _ -> return typePType
ResValue (L _ t) -> return t
_ -> Bad $ render (ppIdent c <+> text "has no type defined in resource" <+> ppIdent m)
lookupOverload :: SourceGrammar -> Ident -> Ident -> Err [([Type],(Type,Term))]
lookupOverload gr m c = do
lookupOverload :: SourceGrammar -> QIdent -> Err [([Type],(Type,Term))]
lookupOverload gr (m,c) = do
mo <- lookupModule gr m
info <- lookupIdentInfo mo c
case info of
ResOverload os tysts -> do
tss <- mapM (\x -> lookupOverload gr x c) os
tss <- mapM (\x -> lookupOverload gr (x,c)) os
return $ [let (args,val) = typeFormCnc ty in (map (\(b,x,t) -> t) args,(val,tr)) |
(L _ ty,L _ tr) <- tysts] ++
concat tss
AnyInd _ n -> lookupOverload gr n c
AnyInd _ n -> lookupOverload gr (n,c)
_ -> Bad $ render (ppIdent c <+> text "is not an overloaded operation")
-- | returns the original 'Info' and the module where it was found
lookupOrigInfo :: SourceGrammar -> Ident -> Ident -> Err (Ident,Info)
lookupOrigInfo gr m c = do
lookupOrigInfo :: SourceGrammar -> QIdent -> Err (Ident,Info)
lookupOrigInfo gr (m,c) = do
mo <- lookupModule gr m
info <- lookupIdentInfo mo c
case info of
AnyInd _ n -> lookupOrigInfo gr n c
AnyInd _ n -> lookupOrigInfo gr (n,c)
i -> return (m,i)
allOrigInfos :: SourceGrammar -> Ident -> [(Ident,Info)]
allOrigInfos gr m = errVal [] $ do
mo <- lookupModule gr m
return [(c,i) | (c,_) <- tree2list (jments mo), Ok (_,i) <- [look c]]
where
look = lookupOrigInfo gr m
return [(c,i) | (c,_) <- tree2list (jments mo), Ok (_,i) <- [lookupOrigInfo gr (m,c)]]
lookupParamValues :: SourceGrammar -> Ident -> Ident -> Err [Term]
lookupParamValues gr m c = do
(_,info) <- lookupOrigInfo gr m c
lookupParamValues :: SourceGrammar -> QIdent -> Err [Term]
lookupParamValues gr c = do
(_,info) <- lookupOrigInfo gr c
case info of
ResParam _ (Just pvs) -> return pvs
_ -> Bad $ render (ppIdent c <+> text "has no parameter values defined in resource" <+> ppIdent m)
_ -> Bad $ render (ppQIdent Qualified c <+> text "has no parameter values defined")
allParamValues :: SourceGrammar -> Type -> Err [Term]
allParamValues cnc ptyp = case ptyp of
_ | Just n <- isTypeInts ptyp -> return [EInt i | i <- [0..n]]
QC p c -> lookupParamValues cnc p c
Q p c -> lookupResDef cnc p c >>= allParamValues cnc
QC c -> lookupParamValues cnc c
Q c -> lookupResDef cnc c >>= allParamValues cnc
RecType r -> do
let (ls,tys) = unzip $ sortByFst r
tss <- mapM (allParamValues cnc) tys

10
src/compiler/GF/Grammar/MMacros.hs
View File

@@ -134,7 +134,7 @@ getMetaAtom a = case a of
_ -> Bad "the active node is not meta"
-}
cat2val :: Context -> Cat -> Val
cat2val cont cat = vClos $ mkApp (uncurry Q cat) [Meta i | i <- [1..length cont]]
cat2val cont cat = vClos $ mkApp (Q cat) [Meta i | i <- [1..length cont]]
val2cat :: Val -> Err Cat
val2cat v = liftM valCat (val2exp v)
@@ -183,7 +183,7 @@ val2expP safe v = case v of
else substVal g e
VClos g e -> substVal g e
VApp f c -> liftM2 App (val2expP safe f) (val2expP safe c)
VCn c -> return $ uncurry Q c
VCn c -> return $ Q c
VGen i x -> if safe
then Bad (render (text "unsafe val2exp" <+> ppValue Unqualified 0 v))
else return $ Vr $ x --- in editing, no alpha conversions presentv
@@ -234,9 +234,9 @@ qualifTerm m = qualif [] where
qualif xs t = case t of
Abs b x t -> let x' = chV x in Abs b x' $ qualif (x':xs) t
Prod b x a t -> Prod b x (qualif xs a) $ qualif (x:xs) t
Vr x -> let x' = chV x in if (elem x' xs) then (Vr x') else (Q m x)
Cn c -> Q m c
Con c -> QC m c
Vr x -> let x' = chV x in if (elem x' xs) then (Vr x') else (Q (m,x))
Cn c -> Q (m,c)
Con c -> QC (m,c)
_ -> composSafeOp (qualif xs) t
chV x = string2var $ ident2bs x

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

@@ -41,8 +41,8 @@ typeForm t =
App c a ->
let (_, cat, args) = typeForm c
in ([],cat,args ++ [a])
Q m c -> ([],(m,c),[])
QC m c -> ([],(m,c),[])
Q c -> ([],c,[])
QC c -> ([],c,[])
Sort c -> ([],(identW, c),[])
_ -> error (render (text "no normal form of type" <+> ppTerm Unqualified 0 t))
@@ -61,7 +61,7 @@ valCat typ =
valType :: Type -> Type
valType typ =
let (_,cat,xx) = typeForm typ --- not optimal to do in this way
in mkApp (uncurry Q cat) xx
in mkApp (Q cat) xx
valTypeCnc :: Type -> Type
valTypeCnc typ = snd (typeFormCnc typ)
@@ -216,11 +216,11 @@ isTypeInts _ = Nothing
isPredefConstant :: Term -> Bool
isPredefConstant t = case t of
Q mod _ | mod == cPredef || mod == cPredefAbs -> True
_ -> False
Q (mod,_) | mod == cPredef || mod == cPredefAbs -> True
_ -> False
cnPredef :: Ident -> Term
cnPredef f = Q cPredef f
cnPredef f = Q (cPredef,f)
mkSelects :: Term -> [Term] -> Term
mkSelects t tt = foldl S t tt
@@ -333,12 +333,12 @@ term2patt trm = case termForm trm of
Ok ([], Con c, aa) -> do
aa' <- mapM term2patt aa
return (PC c aa')
Ok ([], QC p c, aa) -> do
Ok ([], QC c, aa) -> do
aa' <- mapM term2patt aa
return (PP p c aa')
return (PP c aa')
Ok ([], Q p c, []) -> do
return (PM p c)
Ok ([], Q c, []) -> do
return (PM c)
Ok ([], R r, []) -> do
let (ll,aa) = unzipR r
@@ -381,10 +381,10 @@ patt2term pt = case pt of
PV x -> Vr x
PW -> Vr identW --- not parsable, should not occur
PMacro c -> Cn c
PM p c -> Q p c
PM c -> Q c
PC c pp -> mkApp (Con c) (map patt2term pp)
PP p c pp -> mkApp (QC p c) (map patt2term pp)
PP c pp -> mkApp (QC c) (map patt2term pp)
PR r -> R [assign l (patt2term p) | (l,p) <- r]
PT _ p -> patt2term p
@@ -403,8 +403,8 @@ patt2term pt = case pt of
redirectTerm :: Ident -> Term -> Term
redirectTerm n t = case t of
QC _ f -> QC n f
Q _ f -> Q n f
QC (_,f) -> QC (n,f)
Q (_,f) -> Q (n,f)
_ -> composSafeOp (redirectTerm n) t
-- | to gather ultimate cases in a table; preserves pattern list
@@ -426,7 +426,7 @@ strsFromTerm t = case t of
s' <- strsFromTerm s
t' <- strsFromTerm t
return [glueStr x y | x <- s', y <- t']
Alts (d,vs) -> do
Alts d vs -> do
d0 <- strsFromTerm d
v0 <- mapM (strsFromTerm . fst) vs
c0 <- mapM (strsFromTerm . snd) vs
@@ -516,10 +516,10 @@ composOp co trm =
do v1 <- co s1
v2 <- co s2
return (Glue v1 v2)
Alts (t,aa) ->
Alts t aa ->
do t' <- co t
aa' <- mapM (pairM co) aa
return (Alts (t',aa'))
return (Alts t' aa')
FV ts -> mapM co ts >>= return . FV
Strs tt -> mapM co tt >>= return . Strs
@@ -571,7 +571,7 @@ collectOp co trm = case trm of
Let (x,(mt,a)) b -> maybe [] co mt ++ co a ++ co b
C s1 s2 -> co s1 ++ co s2
Glue s1 s2 -> co s1 ++ co s2
Alts (t,aa) -> let (x,y) = unzip aa in co t ++ concatMap co (x ++ y)
Alts t aa -> let (x,y) = unzip aa in co t ++ concatMap co (x ++ y)
FV ts -> concatMap co ts
Strs tt -> concatMap co tt
_ -> [] -- covers K, Vr, Cn, Sort
@@ -581,7 +581,7 @@ wordsInTerm :: Term -> [String]
wordsInTerm trm = filter (not . null) $ case trm of
K s -> [s]
S c _ -> wo c
Alts (t,aa) -> wo t ++ concatMap (wo . fst) aa
Alts t aa -> wo t ++ concatMap (wo . fst) aa
_ -> collectOp wo trm
where wo = wordsInTerm
@@ -608,8 +608,8 @@ allDependencies ism b =
[(f, nub (concatMap opty (pts i))) | (f,i) <- tree2list b]
where
opersIn t = case t of
Q n c | ism n -> [c]
QC n c | ism n -> [c]
Q (n,c) | ism n -> [c]
QC (n,c) | ism n -> [c]
_ -> collectOp opersIn t
opty (Just (L _ ty)) = opersIn ty
opty _ = []

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

@@ -417,8 +417,8 @@ Exp4
in S (T annot $5) $2 }
| 'variants' '{' ListExp '}' { FV $3 }
| 'pre' '{' ListCase '}' {% mkAlts $3 }
| 'pre' '{' String ';' ListAltern '}' { Alts (K $3, $5) }
| 'pre' '{' Ident ';' ListAltern '}' { Alts (Vr $3, $5) }
| 'pre' '{' String ';' ListAltern '}' { Alts (K $3) $5 }
| 'pre' '{' Ident ';' ListAltern '}' { Alts (Vr $3) $5 }
| 'strs' '{' ListExp '}' { Strs $3 }
| '#' Patt3 { EPatt $2 }
| 'pattern' Exp5 { EPattType $2 }
@@ -468,7 +468,7 @@ Patt
Patt1 :: { Patt }
Patt1
: Ident ListPatt { PC $1 $2 }
| Ident '.' Ident ListPatt { PP $1 $3 $4 }
| Ident '.' Ident ListPatt { PP ($1,$3) $4 }
| Patt3 '*' { PRep $1 }
| Patt2 { $1 }
@@ -484,10 +484,10 @@ Patt3
: '?' { PChar }
| '[' String ']' { PChars $2 }
| '#' Ident { PMacro $2 }
| '#' Ident '.' Ident { PM $2 $4 }
| '#' Ident '.' Ident { PM ($2,$4) }
| '_' { PW }
| Ident { PV $1 }
| Ident '.' Ident { PP $1 $3 [] }
| Ident '.' Ident { PP ($1,$3) [] }
| Integer { PInt $1 }
| Double { PFloat $1 }
| String { PString $1 }
@@ -705,7 +705,7 @@ mkAlts cs = case cs of
_:_ -> do
def <- mkDef (last cs)
alts <- mapM mkAlt (init cs)
return (Alts (def,alts))
return (Alts def alts)
_ -> fail "empty alts"
where
mkDef (_,t) = return t
@@ -720,10 +720,10 @@ mkAlts cs = case cs of
PString s -> return $ Strs [K s]
PV x -> return (Vr x) --- for macros; not yet complete
PMacro x -> return (Vr x) --- for macros; not yet complete
PM m c -> return (Q m c) --- for macros; not yet complete
PM c -> return (Q c) --- for macros; not yet complete
_ -> fail "no strs from pattern"
mkL :: Posn -> Posn -> x -> L x
mkL (Pn l1 _) (Pn l2 _) x = L (l1,l2) x
}
}

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

@@ -87,13 +87,13 @@ tryMatch (p,t) = do
do matches <- mapM tryMatch (zip pp tt)
return (concat matches)
(PP q p pp, ([], QC r f, tt)) |
(PP (q,p) pp, ([], QC (r,f), tt)) |
-- q `eqStrIdent` r && --- not for inherited AR 10/10/2005
p `eqStrIdent` f && length pp == length tt ->
do matches <- mapM tryMatch (zip pp tt)
return (concat matches)
---- hack for AppPredef bug
(PP q p pp, ([], Q r f, tt)) |
(PP (q,p) pp, ([], Q (r,f), tt)) |
-- q `eqStrIdent` r && ---
p `eqStrIdent` f && length pp == length tt ->
do matches <- mapM tryMatch (zip pp tt)
@@ -136,8 +136,8 @@ isInConstantForm :: Term -> Bool
isInConstantForm trm = case trm of
Cn _ -> True
Con _ -> True
Q _ _ -> True
QC _ _ -> True
Q _ -> True
QC _ -> True
Abs _ _ _ -> True
C c a -> isInConstantForm c && isInConstantForm a
App c a -> isInConstantForm c && isInConstantForm a
@@ -151,7 +151,7 @@ varsOfPatt :: Patt -> [Ident]
varsOfPatt p = case p of
PV x -> [x]
PC _ ps -> concat $ map varsOfPatt ps
PP _ _ ps -> concat $ map varsOfPatt ps
PP _ ps -> concat $ map varsOfPatt ps
PR r -> concat $ map (varsOfPatt . snd) r
PT _ q -> varsOfPatt q
_ -> []

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

@@ -17,6 +17,7 @@ module GF.Grammar.Printer
, ppValue
, ppConstrs
, ppPosition
, ppQIdent
) where
import GF.Infra.Ident
@@ -159,15 +160,15 @@ ppTerm q d (ExtR x y) = prec d 3 (ppTerm q 3 x <+> text "**" <+> ppTerm q 4 y)
ppTerm q d (App x y) = prec d 4 (ppTerm q 4 x <+> ppTerm q 5 y)
ppTerm q d (V e es) = text "table" <+> ppTerm q 6 e <+> brackets (fsep (punctuate semi (map (ppTerm q 0) es)))
ppTerm q d (FV es) = text "variants" <+> braces (fsep (punctuate semi (map (ppTerm q 0) es)))
ppTerm q d (Alts (e,xs))=text "pre" <+> braces (ppTerm q 0 e <> semi <+> fsep (punctuate semi (map (ppAltern q) xs)))
ppTerm q d (Alts e xs) = text "pre" <+> braces (ppTerm q 0 e <> semi <+> fsep (punctuate semi (map (ppAltern q) xs)))
ppTerm q d (Strs es) = text "strs" <+> braces (fsep (punctuate semi (map (ppTerm q 0) es)))
ppTerm q d (EPatt p) = prec d 4 (char '#' <+> ppPatt q 2 p)
ppTerm q d (EPattType t)=prec d 4 (text "pattern" <+> ppTerm q 0 t)
ppTerm q d (P t l) = prec d 5 (ppTerm q 5 t <> char '.' <> ppLabel l)
ppTerm q d (Cn id) = ppIdent id
ppTerm q d (Vr id) = ppIdent id
ppTerm q d (Q m id) = ppQIdent q m id
ppTerm q d (QC m id) = ppQIdent q m id
ppTerm q d (Q id) = ppQIdent q id
ppTerm q d (QC id) = char '!' <> ppQIdent q id <> char '!'
ppTerm q d (Sort id) = ppIdent id
ppTerm q d (K s) = str s
ppTerm q d (EInt n) = integer n
@@ -191,16 +192,16 @@ ppPatt q d (PSeq p1 p2) = prec d 0 (ppPatt q 0 p1 <+> char '+' <+> ppPatt q 1 p2
ppPatt q d (PC f ps) = if null ps
then ppIdent f
else prec d 1 (ppIdent f <+> hsep (map (ppPatt q 3) ps))
ppPatt q d (PP f g ps) = if null ps
then ppQIdent q f g
else prec d 1 (ppQIdent q f g <+> hsep (map (ppPatt q 3) ps))
ppPatt q d (PP f ps) = if null ps
then ppQIdent q f
else prec d 1 (ppQIdent q f <+> hsep (map (ppPatt q 3) ps))
ppPatt q d (PRep p) = prec d 1 (ppPatt q 3 p <> char '*')
ppPatt q d (PAs f p) = prec d 2 (ppIdent f <> char '@' <> ppPatt q 3 p)
ppPatt q d (PNeg p) = prec d 2 (char '-' <> ppPatt q 3 p)
ppPatt q d (PChar) = char '?'
ppPatt q d (PChars s) = brackets (str s)
ppPatt q d (PMacro id) = char '#' <> ppIdent id
ppPatt q d (PM m id) = char '#' <> ppIdent m <> char '.' <> ppIdent id
ppPatt q d (PM id) = char '#' <> ppQIdent q id
ppPatt q d PW = char '_'
ppPatt q d (PV id) = ppIdent id
ppPatt q d (PInt n) = integer n
@@ -236,7 +237,7 @@ ppDDecl q (_,id,typ)
| id == identW = ppTerm q 6 typ
| otherwise = parens (ppIdent id <+> colon <+> ppTerm q 0 typ)
ppQIdent q m id =
ppQIdent q (m,id) =
case q of
Qualified -> ppIdent m <> char '.' <> ppIdent id
Unqualified -> ppIdent id

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

@@ -57,8 +57,8 @@ unify e1 e2 g =
let sg = maybe e1 id (lookup s g)
if (sg == Meta s) then extend g s tg else unify sg tg g
(t, Meta s) -> unify e2 e1 g
(Q _ a, Q _ b) | (a == b) -> return g ---- qualif?
(QC _ a, QC _ b) | (a == b) -> return g ----
(Q (_,a), Q (_,b)) | (a == b) -> return g ---- qualif?
(QC (_,a), QC (_,b)) | (a == b)-> return g ----
(Vr x, Vr y) | (x == y) -> return g
(Abs _ x b, Abs _ y c) -> do let c' = substTerm [x] [(y,Vr x)] c
unify b c' g