summaryrefslogtreecommitdiff
path: root/src/compiler/GF/Grammar
diff options
context:
space:
mode:
Diffstat (limited to 'src/compiler/GF/Grammar')
-rw-r--r--src/compiler/GF/Grammar/Binary.hs20
-rw-r--r--src/compiler/GF/Grammar/Grammar.hs10
-rw-r--r--src/compiler/GF/Grammar/Lookup.hs60
-rw-r--r--src/compiler/GF/Grammar/MMacros.hs10
-rw-r--r--src/compiler/GF/Grammar/Macros.hs42
-rw-r--r--src/compiler/GF/Grammar/Parser.y16
-rw-r--r--src/compiler/GF/Grammar/PatternMatch.hs10
-rw-r--r--src/compiler/GF/Grammar/Printer.hs17
-rw-r--r--src/compiler/GF/Grammar/Unify.hs4
9 files changed, 94 insertions, 95 deletions
diff --git a/src/compiler/GF/Grammar/Binary.hs b/src/compiler/GF/Grammar/Binary.hs
index ff34ae38a..70282d128 100644
--- a/src/compiler/GF/Grammar/Binary.hs
+++ b/src/compiler/GF/Grammar/Binary.hs
@@ -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
diff --git a/src/compiler/GF/Grammar/Grammar.hs b/src/compiler/GF/Grammar/Grammar.hs
index 4aa2ace51..2e6f1f1a7 100644
--- a/src/compiler/GF/Grammar/Grammar.hs
+++ b/src/compiler/GF/Grammar/Grammar.hs
@@ -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)
diff --git a/src/compiler/GF/Grammar/Lookup.hs b/src/compiler/GF/Grammar/Lookup.hs
index 90d8263cd..c355056d5 100644
--- a/src/compiler/GF/Grammar/Lookup.hs
+++ b/src/compiler/GF/Grammar/Lookup.hs
@@ -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
diff --git a/src/compiler/GF/Grammar/MMacros.hs b/src/compiler/GF/Grammar/MMacros.hs
index a7f746b66..233eb768f 100644
--- a/src/compiler/GF/Grammar/MMacros.hs
+++ b/src/compiler/GF/Grammar/MMacros.hs
@@ -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
diff --git a/src/compiler/GF/Grammar/Macros.hs b/src/compiler/GF/Grammar/Macros.hs
index 0653332d2..3380a55c0 100644
--- a/src/compiler/GF/Grammar/Macros.hs
+++ b/src/compiler/GF/Grammar/Macros.hs
@@ -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 _ = []
diff --git a/src/compiler/GF/Grammar/Parser.y b/src/compiler/GF/Grammar/Parser.y
index 867776607..920724019 100644
--- a/src/compiler/GF/Grammar/Parser.y
+++ b/src/compiler/GF/Grammar/Parser.y
@@ -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
-} \ No newline at end of file
+}
diff --git a/src/compiler/GF/Grammar/PatternMatch.hs b/src/compiler/GF/Grammar/PatternMatch.hs
index b8f7eff7d..53ffc3394 100644
--- a/src/compiler/GF/Grammar/PatternMatch.hs
+++ b/src/compiler/GF/Grammar/PatternMatch.hs
@@ -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
_ -> []
diff --git a/src/compiler/GF/Grammar/Printer.hs b/src/compiler/GF/Grammar/Printer.hs
index 6afc2d69a..8a2eae61d 100644
--- a/src/compiler/GF/Grammar/Printer.hs
+++ b/src/compiler/GF/Grammar/Printer.hs
@@ -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
diff --git a/src/compiler/GF/Grammar/Unify.hs b/src/compiler/GF/Grammar/Unify.hs
index 9bb49cfe2..d08de96c7 100644
--- a/src/compiler/GF/Grammar/Unify.hs
+++ b/src/compiler/GF/Grammar/Unify.hs
@@ -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
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 06:04:57 +0000