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

6
src/compiler/GF/Compile/Abstract/Compute.hs
View File

@@ -72,7 +72,7 @@ computeAbsTermIn lookd xs e = errIn (render (text "computing" <+> ppTerm Unquali
tracd (text "not defined" <+> ppTerm Unqualified 0 t2) $ return t2
look t = case t of
(Q m f) -> case lookd m f of
(Q (m,f)) -> case lookd m f of
Ok (_,md) -> md
_ -> Nothing
_ -> Nothing
@@ -114,11 +114,11 @@ tryMatch (p,t) = do
(PString s, ([],K i,[])) | s==i -> return []
(PInt s, ([],EInt i,[])) | s==i -> return []
(PFloat s,([],EFloat i,[])) | s==i -> return [] --- rounding?
(PP q p pp, ([], QC r f, tt)) |
(PP (q,p) pp, ([], QC (r,f), tt)) |
p `eqStrIdent` f && length pp == length tt -> do
matches <- mapM tryMatch (zip pp tt)
return (concat matches)
(PP q p pp, ([], Q r f, tt)) |
(PP (q,p) pp, ([], Q (r,f), tt)) |
p `eqStrIdent` f && length pp == length tt -> do
matches <- mapM tryMatch (zip pp tt)
return (concat matches)

24
src/compiler/GF/Compile/Abstract/TC.hs
View File

@@ -84,8 +84,8 @@ eval :: Env -> Exp -> Err Val
eval env e = ---- errIn ("eval" +++ prt e +++ "in" +++ prEnv env) $
case e of
Vr x -> lookupVar env x
Q m c -> return $ VCn (m,c)
QC m c -> return $ VCn (m,c) ---- == Q ?
Q c -> return $ VCn c
QC c -> return $ VCn c ---- == Q ?
Sort c -> return $ VType --- the only sort is Type
App f a -> join $ liftM2 app (eval env f) (eval env a)
RecType xs -> do xs <- mapM (\(l,e) -> eval env e >>= \e -> return (l,e)) xs
@@ -161,10 +161,10 @@ checkInferExp th tenv@(k,_,_) e typ = do
inferExp :: Theory -> TCEnv -> Exp -> Err (AExp, Val, [(Val,Val)])
inferExp th tenv@(k,rho,gamma) e = case e of
Vr x -> mkAnnot (AVr x) $ noConstr $ lookupVar gamma x
Q m c | m == cPredefAbs && isPredefCat c
Q (m,c) | m == cPredefAbs && isPredefCat c
-> return (ACn (m,c) vType, vType, [])
| otherwise -> mkAnnot (ACn (m,c)) $ noConstr $ lookupConst th (m,c)
QC m c -> mkAnnot (ACn (m,c)) $ noConstr $ lookupConst th (m,c) ----
| otherwise -> mkAnnot (ACn (m,c)) $ noConstr $ lookupConst th (m,c)
QC c -> mkAnnot (ACn c) $ noConstr $ lookupConst th c ----
EInt i -> return (AInt i, valAbsInt, [])
EFloat i -> return (AFloat i, valAbsFloat, [])
K i -> return (AStr i, valAbsString, [])
@@ -240,7 +240,7 @@ checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $
PString s -> (K s : ps, i, g, k)
PInt n -> (EInt n : ps, i, g, k)
PFloat n -> (EFloat n : ps, i, g, k)
PP m c xs -> (mkApp (Q m c) xss : ps, j, g',k')
PP c xs -> (mkApp (Q c) xss : ps, j, g',k')
where (xss,j,g',k') = foldr p2t ([],i,g,k) xs
PImplArg p -> p2t p (ps,i,g,k)
PTilde t -> (t : ps, i, g, k)
@@ -268,12 +268,12 @@ checkPatt th tenv exp val = do
EFloat i -> return (AFloat i, valAbsFloat, [])
K s -> return (AStr s, valAbsString, [])
Q m c -> do
typ <- lookupConst th (m,c)
return $ (ACn (m,c) typ, typ, [])
QC m c -> do
typ <- lookupConst th (m,c)
return $ (ACn (m,c) typ, typ, []) ----
Q c -> do
typ <- lookupConst th c
return $ (ACn c typ, typ, [])
QC c -> do
typ <- lookupConst th c
return $ (ACn c typ, typ, []) ----
App f t -> do
(f',w,csf) <- checkExpP tenv f val
typ <- whnf w

10
src/compiler/GF/Compile/CheckGrammar.hs
View File

@@ -99,7 +99,7 @@ checkCompleteGrammar gr (am,abs) (cm,cnc) = do
let (cxt,(_,i),_) = typeForm ty
info <- lookupIdent i js
info <- case info of
(AnyInd _ m) -> do (m,info) <- lookupOrigInfo gr m i
(AnyInd _ m) -> do (m,info) <- lookupOrigInfo gr (m,i)
return info
_ -> return info
case info of
@@ -137,14 +137,14 @@ checkCompleteGrammar gr (am,abs) (cm,cnc) = do
checkCnc js i@(c,info) =
case info of
CncFun _ d pn -> case lookupOrigInfo gr am c of
CncFun _ d pn -> case lookupOrigInfo gr (am,c) of
Ok (_,AbsFun (Just (L _ ty)) _ _) ->
do (cont,val) <- linTypeOfType gr cm ty
let linty = (snd (valCat ty),cont,val)
return $ updateTree (c,CncFun (Just linty) d pn) js
_ -> do checkWarn $ text "function" <+> ppIdent c <+> text "is not in abstract"
return js
CncCat _ _ _ -> case lookupOrigInfo gr am c of
CncCat _ _ _ -> case lookupOrigInfo gr (am,c) of
Ok _ -> return $ updateTree i js
_ -> do checkWarn $ text "category" <+> ppIdent c <+> text "is not in abstract"
return js
@@ -206,7 +206,7 @@ checkInfo ms (m,mo) c info = do
ResOverload os tysts -> chIn (0,0) "overloading" $ do
tysts' <- mapM (uncurry $ flip (\(L loc1 t) (L loc2 ty) -> checkLType gr [] t ty >>= \(t,ty) -> return (L loc1 t, L loc2 ty))) tysts -- return explicit ones
tysts0 <- checkErr $ lookupOverload gr m c -- check against inherited ones too
tysts0 <- checkErr $ lookupOverload gr (m,c) -- check against inherited ones too
tysts1 <- mapM (uncurry $ flip (checkLType gr []))
[(mkFunType args val,tr) | (args,(val,tr)) <- tysts0]
--- this can only be a partial guarantee, since matching
@@ -227,7 +227,7 @@ checkInfo ms (m,mo) c info = do
mkPar (L loc (f,co)) =
chIn loc "parameter type" $ do
vs <- checkErr $ liftM combinations $ mapM (\(_,_,ty) -> allParamValues gr ty) co
return $ map (mkApp (QC m f)) vs
return $ map (mkApp (QC (m,f))) vs
checkUniq xss = case xss of
x:y:xs

10
src/compiler/GF/Compile/Concrete/AppPredefined.hs
View File

@@ -71,13 +71,13 @@ appPredefined t = case t of
(x,_) <- appPredefined x0
case f of
-- one-place functions
Q mod f | mod == cPredef ->
Q (mod,f) | mod == cPredef ->
case x of
(K s) | f == cLength -> retb $ EInt $ toInteger $ length s
_ -> retb t
-- two-place functions
App (Q mod f) z0 | mod == cPredef -> do
App (Q (mod,f)) z0 | mod == cPredef -> do
(z,_) <- appPredefined z0
case (norm z, norm x) of
(EInt i, K s) | f == cDrop -> retb $ K (drop (fi i) s)
@@ -96,7 +96,7 @@ appPredefined t = case t of
_ -> retb t ---- prtBad "cannot compute predefined" t
-- three-place functions
App (App (Q mod f) z0) y0 | mod == cPredef -> do
App (App (Q (mod,f)) z0) y0 | mod == cPredef -> do
(y,_) <- appPredefined y0
(z,_) <- appPredefined z0
case (z, y, x) of
@@ -123,8 +123,8 @@ appPredefined t = case t of
-- read makes variables into constants
predefTrue = QC cPredef cPTrue
predefFalse = QC cPredef cPFalse
predefTrue = QC (cPredef,cPTrue)
predefFalse = QC (cPredef,cPFalse)
substring :: String -> String -> Bool
substring s t = case (s,t) of

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

@@ -52,8 +52,8 @@ computeTermOpt rec gr = comput True where
comput full g t = ---- errIn ("subterm" +++ prt t) $ --- for debugging
case t of
Q p c | p == cPredef -> return t
| otherwise -> look p c
Q (p,c) | p == cPredef -> return t
| otherwise -> look (p,c)
Vr x -> do
t' <- maybe (Bad (render (text "no value given to variable" <+> ppIdent x))) return $ lookup x g
@@ -86,9 +86,9 @@ computeTermOpt rec gr = comput True where
as' <- mapM (comp g) as
case h' of
_ | not (null [() | FV _ <- as']) -> compApp g (mkApp h' as')
c@(QC _ _) -> do
c@(QC _) -> do
return $ mkApp c as'
Q mod f | mod == cPredef -> do
Q (mod,f) | mod == cPredef -> do
(t',b) <- appPredefined (mkApp h' as')
if b then return t' else comp g t'
@@ -163,11 +163,11 @@ computeTermOpt rec gr = comput True where
(_,Empty) -> return x
(Empty,_) -> return y
(K a, K b) -> return $ K (a ++ b)
(_, Alts (d,vs)) -> do
(_, Alts d vs) -> do
---- (K a, Alts (d,vs)) -> do
let glx = Glue x
comp g $ Alts (glx d, [(glx v,c) | (v,c) <- vs])
(Alts _, ka) -> checks [do
comp g $ Alts (glx d) [(glx v,c) | (v,c) <- vs]
(Alts _ _, ka) -> checks [do
y' <- strsFromTerm ka
---- (Alts _, K a) -> checks [do
x' <- strsFromTerm x -- this may fail when compiling opers
@@ -183,17 +183,17 @@ computeTermOpt rec gr = comput True where
r <- composOp (comp g) t
returnC r
Alts (d,aa) -> do
Alts d aa -> do
d' <- comp g d
aa' <- mapM (compInAlts g) aa
returnC (Alts (d',aa'))
returnC (Alts d' aa')
-- remove empty
C a b -> do
a' <- comp g a
b' <- comp g b
case (a',b') of
(Alts _, K a) -> checks [do
(Alts _ _, K a) -> checks [do
as <- strsFromTerm a' -- this may fail when compiling opers
return $ variants [
foldr1 C (map K (str2strings (plusStr v (str a)))) | v <- as]
@@ -238,7 +238,7 @@ computeTermOpt rec gr = comput True where
(FV fs, _) -> mapM (\c -> comp g (App c a')) fs >>= return . variants
(Abs _ x b,_) -> comp (ext x a' g) b
(QC _ _,_) -> returnC $ App f' a'
(QC _,_) -> returnC $ App f' a'
(S (T i cs) e,_) -> prawitz g i (flip App a') cs e
(S (V i cs) e,_) -> prawitzV g i (flip App a') cs e
@@ -250,9 +250,9 @@ computeTermOpt rec gr = comput True where
hnf = comput False
comp = comput True
look p c
| rec = lookupResDef gr p c >>= comp []
| otherwise = lookupResDef gr p c
look c
| rec = lookupResDef gr c >>= comp []
| otherwise = lookupResDef gr c
ext x a g = (x,a):g
@@ -264,13 +264,13 @@ computeTermOpt rec gr = comput True where
isCan v = case v of
Con _ -> True
QC _ _ -> True
QC _ -> True
App f a -> isCan f && isCan a
R rs -> all (isCan . snd . snd) rs
_ -> False
compPatternMacro p = case p of
PM m c -> case look m c of
PM c -> case look c of
Ok (EPatt p') -> compPatternMacro p'
_ -> Bad (render (text "pattern expected as value of" $$ nest 2 (ppPatt Unqualified 0 p)))
PAs x p -> do
@@ -384,7 +384,7 @@ computeTermOpt rec gr = comput True where
contP p = case p of
PV x -> [(x,Vr x)]
PC _ ps -> concatMap contP ps
PP _ _ ps -> concatMap contP ps
PP _ ps -> concatMap contP ps
PT _ p -> contP p
PR rs -> concatMap (contP . snd) rs

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

@@ -23,8 +23,8 @@ computeLType gr g0 t = comp (reverse [(b,x, Vr x) | (b,x,_) <- g0] ++ g0) t
_ | Just _ <- isTypeInts ty -> return ty ---- shouldn't be needed
| isPredefConstant ty -> return ty ---- shouldn't be needed
Q m ident -> checkIn (text "module" <+> ppIdent m) $ do
ty' <- checkErr (lookupResDef gr m ident)
Q (m,ident) -> checkIn (text "module" <+> ppIdent m) $ do
ty' <- checkErr (lookupResDef gr (m,ident))
if ty' == ty then return ty else comp g ty' --- is this necessary to test?
Vr ident -> checkLookup ident g -- never needed to compute!
@@ -70,22 +70,22 @@ computeLType gr g0 t = comp (reverse [(b,x, Vr x) | (b,x,_) <- g0] ++ g0) t
inferLType :: SourceGrammar -> Context -> Term -> Check (Term, Type)
inferLType gr g trm = case trm of
Q m ident | isPredef m -> termWith trm $ checkErr (typPredefined ident)
Q (m,ident) | isPredef m -> termWith trm $ checkErr (typPredefined ident)
Q m ident -> checks [
termWith trm $ checkErr (lookupResType gr m ident) >>= computeLType gr g
Q ident -> checks [
termWith trm $ checkErr (lookupResType gr ident) >>= computeLType gr g
,
checkErr (lookupResDef gr m ident) >>= inferLType gr g
checkErr (lookupResDef gr ident) >>= inferLType gr g
,
checkError (text "cannot infer type of constant" <+> ppTerm Unqualified 0 trm)
]
QC m ident | isPredef m -> termWith trm $ checkErr (typPredefined ident)
QC (m,ident) | isPredef m -> termWith trm $ checkErr (typPredefined ident)
QC m ident -> checks [
termWith trm $ checkErr (lookupResType gr m ident) >>= computeLType gr g
QC ident -> checks [
termWith trm $ checkErr (lookupResType gr ident) >>= computeLType gr g
,
checkErr (lookupResDef gr m ident) >>= inferLType gr g
checkErr (lookupResDef gr ident) >>= inferLType gr g
,
checkError (text "cannot infer type of canonical constant" <+> ppTerm Unqualified 0 trm)
]
@@ -188,13 +188,13 @@ inferLType gr g trm = case trm of
ts' <- mapM (\t -> justCheck g t typeStr) ts
return (Strs ts', typeStrs)
Alts (t,aa) -> do
Alts t aa -> do
t' <- justCheck g t typeStr
aa' <- flip mapM aa (\ (c,v) -> do
c' <- justCheck g c typeStr
v' <- checks $ map (justCheck g v) [typeStrs, EPattType typeStr]
return (c',v'))
return (Alts (t',aa'), typeStr)
return (Alts t' aa', typeStr)
RecType r -> do
let (ls,ts) = unzip r
@@ -267,7 +267,7 @@ inferLType gr g trm = case trm of
return (arg,val)
isConstPatt p = case p of
PC _ ps -> True --- all isConstPatt ps
PP _ _ ps -> True --- all isConstPatt ps
PP _ ps -> True --- all isConstPatt ps
PR ps -> all (isConstPatt . snd) ps
PT _ p -> isConstPatt p
PString _ -> True
@@ -283,7 +283,7 @@ inferLType gr g trm = case trm of
_ -> False
inferPatt p = case p of
PP q c ps | q /= cPredef -> checkErr $ liftM valTypeCnc (lookupResType gr q c)
PP (q,c) ps | q /= cPredef -> checkErr $ liftM valTypeCnc (lookupResType gr (q,c))
PAs _ p -> inferPatt p
PNeg p -> inferPatt p
PAlt p q -> checks [inferPatt p, inferPatt q]
@@ -298,7 +298,7 @@ inferLType gr g trm = case trm of
-- the latter permits matching with value type
getOverload :: SourceGrammar -> Context -> Maybe Type -> Term -> Check (Maybe (Term,Type))
getOverload gr g mt ot = case appForm ot of
(f@(Q m c), ts) -> case lookupOverload gr m c of
(f@(Q c), ts) -> case lookupOverload gr c of
Ok typs -> do
ttys <- mapM (inferLType gr g) ts
v <- matchOverload f typs ttys
@@ -390,7 +390,7 @@ checkLType gr g trm typ0 = do
(trm',ty') <- inferLType gr g trm
termWith trm' $ checkEqLType gr g typ ty' trm'
Q _ _ -> do
Q _ -> do
over <- getOverload gr g (Just typ) trm
case over of
Just trty -> return trty
@@ -522,8 +522,8 @@ checkLType gr g trm typ0 = do
pattContext :: SourceGrammar -> Context -> Type -> Patt -> Check Context
pattContext env g typ p = case p of
PV x -> return [(Explicit,x,typ)]
PP q c ps | q /= cPredef -> do ---- why this /=? AR 6/1/2006
t <- checkErr $ lookupResType env q c
PP (q,c) ps | q /= cPredef -> do ---- why this /=? AR 6/1/2006
t <- checkErr $ lookupResType env (q,c)
let (cont,v) = typeFormCnc t
checkCond (text "wrong number of arguments for constructor in" <+> ppPatt Unqualified 0 p)
(length cont == length ps)
@@ -617,15 +617,15 @@ checkIfEqLType gr g t u trm = do
| t == typeInt, Just _ <- isTypeInts u -> True ---- why this ???? AR 11/12/2005
---- this should be made in Rename
(Q m a, Q n b) | a == b -> elem m (allExtendsPlus gr n)
|| elem n (allExtendsPlus gr m)
|| m == n --- for Predef
(QC m a, QC n b) | a == b -> elem m (allExtendsPlus gr n)
|| elem n (allExtendsPlus gr m)
(QC m a, Q n b) | a == b -> elem m (allExtendsPlus gr n)
|| elem n (allExtendsPlus gr m)
(Q m a, QC n b) | a == b -> elem m (allExtendsPlus gr n)
|| elem n (allExtendsPlus gr m)
(Q (m,a), Q (n,b)) | a == b -> elem m (allExtendsPlus gr n)
|| elem n (allExtendsPlus gr m)
|| m == n --- for Predef
(QC (m,a), QC (n,b)) | a == b -> elem m (allExtendsPlus gr n)
|| elem n (allExtendsPlus gr m)
(QC (m,a), Q (n,b)) | a == b -> elem m (allExtendsPlus gr n)
|| elem n (allExtendsPlus gr m)
(Q (m,a), QC (n,b)) | a == b -> elem m (allExtendsPlus gr n)
|| elem n (allExtendsPlus gr m)
(Table a b, Table c d) -> alpha g a c && alpha g b d
(Vr x, Vr y) -> x == y || elem (x,y) g || elem (y,x) g

20
src/compiler/GF/Compile/GrammarToPGF.hs
View File

@@ -125,8 +125,8 @@ mkType scope t =
mkExp :: [Ident] -> A.Term -> C.Expr
mkExp scope t =
case t of
Q _ c -> C.EFun (i2i c)
QC _ c -> C.EFun (i2i c)
Q (_,c) -> C.EFun (i2i c)
QC (_,c) -> C.EFun (i2i c)
Vr x -> case lookup x (zip scope [0..]) of
Just i -> C.EVar i
Nothing -> C.EMeta 0
@@ -140,7 +140,7 @@ mkExp scope t =
mkPatt scope p =
case p of
A.PP _ c ps -> let (scope',ps') = mapAccumL mkPatt scope ps
A.PP (_,c) ps->let (scope',ps') = mapAccumL mkPatt scope ps
in (scope',C.PApp (i2i c) ps')
A.PV x -> (x:scope,C.PVar (i2i x))
A.PAs x p -> let (scope',p') = mkPatt scope p
@@ -180,7 +180,7 @@ mkTerm tr = case tr of
Empty -> C.S []
App _ _ -> prtTrace tr $ C.C 66661 ---- for debugging
Abs _ _ t -> mkTerm t ---- only on toplevel
Alts (td,tvs) ->
Alts td tvs ->
C.K (C.KP (strings td) [C.Alt (strings u) (strings v) | (u,v) <- tvs])
_ -> prtTrace tr $ C.S [C.K (C.KS (render (A.ppTerm Unqualified 0 tr <+> int 66662)))] ---- for debugging
where
@@ -363,7 +363,7 @@ paramValues cgr = (labels,untyps,typs) where
(_,(_,CncCat (Just (L _ ty0)) _ _)) <- jments,
ty <- typsFrom ty0
] ++ [
Q m ty |
Q (m,ty) |
(m,(ty,ResParam _ _)) <- jments
] ++ [ty |
(_,(_,CncFun _ (Just (L _ tr)) _)) <- jments,
@@ -377,8 +377,8 @@ paramValues cgr = (labels,untyps,typs) where
_ -> []
isParam ty = case ty of
Q _ _ -> True
QC _ _ -> True
Q _ -> True
QC _ -> True
RecType rs -> all isParam (map snd rs)
_ -> False
@@ -436,7 +436,7 @@ type2type cgr env@(labels,untyps,typs) ty = case ty of
RecType rs ->
RecType [(mkLab i, t2t t) | (i,(l, t)) <- zip [0..] (unlockTyp rs)]
Table pt vt -> Table (t2t pt) (t2t vt)
QC _ _ -> look ty
QC _ -> look ty
_ -> ty
where
t2t = type2type cgr env
@@ -447,7 +447,7 @@ type2type cgr env@(labels,untyps,typs) ty = case ty of
term2term :: Ident -> SourceGrammar -> ParamEnv -> Term -> Term
term2term fun cgr env@(labels,untyps,typs) tr = case tr of
App _ _ -> mkValCase (unrec tr)
QC _ _ -> mkValCase tr
QC _ -> mkValCase tr
R rs -> R [(mkLab i, (Nothing, t2t t)) |
(i,(l,(_,t))) <- zip [0..] (GM.sortRec (unlock rs))]
P t l -> r2r tr
@@ -523,7 +523,7 @@ term2term fun cgr env@(labels,untyps,typs) tr = case tr of
valNum tr = maybe (valNumFV $ tryFV tr) EInt $ Map.lookup tr untyps
where
tryFV tr = case GM.appForm tr of
(c@(QC _ _), ts) -> [GM.mkApp c ts' | ts' <- combinations (map tryFV ts)]
(c@(QC _), ts) -> [GM.mkApp c ts' | ts' <- combinations (map tryFV ts)]
(FV ts,_) -> ts
_ -> [tr]
valNumFV ts = case ts of

12
src/compiler/GF/Compile/Optimize.hs
View File

@@ -146,10 +146,10 @@ mkLinDefault gr typ = liftM (Abs Explicit varStr) $ mkDefField typ
let T _ cs = mkWildCases t'
return $ T (TWild p) cs
Sort s | s == cStr -> return $ Vr varStr
QC q p -> do vs <- lookupParamValues gr q p
case vs of
v:_ -> return v
_ -> Bad (render (text "no parameter values given to type" <+> ppIdent p))
QC p -> do vs <- lookupParamValues gr p
case vs of
v:_ -> return v
_ -> Bad (render (text "no parameter values given to type" <+> ppQIdent Qualified p))
RecType r -> do
let (ls,ts) = unzip r
ts <- mapM mkDefField ts
@@ -181,7 +181,7 @@ evalPrintname gr c ppr lin =
C x y -> C (oneBranch x) (oneBranch y)
S x _ -> oneBranch x
P x _ -> oneBranch x
Alts (d,_) -> oneBranch d
Alts d _ -> oneBranch d
_ -> t
--- very unclean cleaner
@@ -222,7 +222,7 @@ replace :: Term -> Term -> Term -> Term
replace old new trm =
case trm of
-- these are the important cases, since they can correspond to patterns
QC _ _ | trm == old -> new
QC _ | trm == old -> new
App _ _ | trm == old -> new
R _ | trm == old -> new
App x y -> App (replace old new x) (replace old new y)

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

@@ -68,7 +68,7 @@ refreshCase (p,t) = liftM2 (,) (refreshPatt p) (refresh t)
refreshPatt p = case p of
PV x -> liftM PV (refVar x)
PC c ps -> liftM (PC c) (mapM refreshPatt ps)
PP q c ps -> liftM (PP q c) (mapM refreshPatt ps)
PP c ps -> liftM (PP c) (mapM refreshPatt ps)
PR r -> liftM PR (mapPairsM refreshPatt r)
PT t p' -> liftM2 PT (refresh t) (refreshPatt p')

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

@@ -69,13 +69,13 @@ renameIdentTerm env@(act,imps) t =
case t of
Vr c -> ident predefAbs c
Cn c -> ident (\_ s -> checkError s) c
Q m' c | m' == cPredef {- && isInPredefined c -} -> return t
Q m' c -> do
Q (m',c) | m' == cPredef {- && isInPredefined c -} -> return t
Q (m',c) -> do
m <- checkErr (lookupErr m' qualifs)
f <- lookupTree showIdent c m
return $ f c
QC m' c | m' == cPredef {- && isInPredefined c -} -> return t
QC m' c -> do
QC (m',c) | m' == cPredef {- && isInPredefined c -} -> return t
QC (m',c) -> do
m <- checkErr (lookupErr m' qualifs)
f <- lookupTree showIdent c m
return $ f c
@@ -87,7 +87,7 @@ renameIdentTerm env@(act,imps) t =
-- this facility is mainly for BWC with GF1: you need not import PredefAbs
predefAbs c s
| isPredefCat c = return $ Q cPredefAbs c
| isPredefCat c = return $ Q (cPredefAbs,c)
| otherwise = checkError s
ident alt c = case lookupTree showIdent c act of
@@ -105,12 +105,12 @@ renameIdentTerm env@(act,imps) t =
info2status :: Maybe Ident -> (Ident,Info) -> StatusInfo
info2status mq (c,i) = case i of
AbsFun _ _ Nothing -> maybe Con QC mq
ResValue _ -> maybe Con QC mq
ResParam _ _ -> maybe Con QC mq
AnyInd True m -> maybe Con (const (QC m)) mq
AnyInd False m -> maybe Cn (const (Q m)) mq
_ -> maybe Cn Q mq
AbsFun _ _ Nothing -> maybe Con (curry QC) mq
ResValue _ -> maybe Con (curry QC) mq
ResParam _ _ -> maybe Con (curry QC) mq
AnyInd True m -> maybe Con (const (curry QC m)) mq
AnyInd False m -> maybe Cn (const (curry Q m)) mq
_ -> maybe Cn (curry Q) mq
tree2status :: OpenSpec -> BinTree Ident Info -> BinTree Ident StatusInfo
tree2status o = case o of
@@ -192,8 +192,8 @@ renameTerm env vars = ren vars where
| otherwise -> renid trm
Cn _ -> renid trm
Con _ -> renid trm
Q _ _ -> renid trm
QC _ _ -> renid trm
Q _ -> renid trm
QC _ -> renid trm
T i cs -> do
i' <- case i of
TTyped ty -> liftM TTyped $ ren vs ty -- the only annotation in source
@@ -211,7 +211,7 @@ renameTerm env vars = ren vars where
P t@(Vr r) l -- Here we have $r.l$ and this is ambiguous it could be either
-- record projection from variable or constant $r$ or qualified expression with module $r$
| elem r vs -> return trm -- try var proj first ..
| otherwise -> checks [ renid (Q r (label2ident l)) -- .. and qualified expression second.
| otherwise -> checks [ renid (Q (r,label2ident l)) -- .. and qualified expression second.
, renid t >>= \t -> return (P t l) -- try as a constant at the end
, checkError (text "unknown qualified constant" <+> ppTerm Unqualified 0 trm)
]
@@ -236,34 +236,34 @@ renamePattern env patt = case patt of
PMacro c -> do
c' <- renid $ Vr c
case c' of
Q p d -> renp $ PM p d
Q d -> renp $ PM d
_ -> checkError (text "unresolved pattern" <+> ppPatt Unqualified 0 patt)
PC c ps -> do
c' <- renid $ Cn c
case c' of
QC m c -> do psvss <- mapM renp ps
let (ps,vs) = unzip psvss
return (PP m c ps, concat vs)
Q _ _ -> checkError (text "data constructor expected but" <+> ppTerm Qualified 0 c' <+> text "is found instead")
_ -> checkError (text "unresolved data constructor" <+> ppTerm Qualified 0 c')
QC c -> do psvss <- mapM renp ps
let (ps,vs) = unzip psvss
return (PP c ps, concat vs)
Q _ -> checkError (text "data constructor expected but" <+> ppTerm Qualified 0 c' <+> text "is found instead")
_ -> checkError (text "unresolved data constructor" <+> ppTerm Qualified 0 c')
PP p c ps -> do
(QC p' c') <- renid (QC p c)
PP c ps -> do
(QC c') <- renid (QC c)
psvss <- mapM renp ps
let (ps',vs) = unzip psvss
return (PP p' c' ps', concat vs)
return (PP c' ps', concat vs)
PM p c -> do
x <- renid (Q p c)
(p',c') <- case x of
(Q p' c') -> return (p',c')
_ -> checkError (text "not a pattern macro" <+> ppPatt Qualified 0 patt)
return (PM p' c', [])
PM c -> do
x <- renid (Q c)
c' <- case x of
(Q c') -> return c'
_ -> checkError (text "not a pattern macro" <+> ppPatt Qualified 0 patt)
return (PM c', [])
PV x -> checks [ renid (Vr x) >>= \t' -> case t' of
QC m c -> return (PP m c [],[])
_ -> checkError (text "not a constructor")
QC c -> return (PP c [],[])
_ -> checkError (text "not a constructor")
, return (patt, [x])
]

6
src/compiler/GF/Compile/SubExOpt.hs
View File

@@ -58,8 +58,8 @@ unsubexpModule sm@(i,mo)
ResOper pty (Just (L loc t)) -> [(c, ResOper pty (Just (L loc (unparTerm t))))]
_ -> [(c,info)]
unparTerm t = case t of
Q m c | isOperIdent c -> --- name convention of subexp opers
errVal t $ liftM unparTerm $ lookupResDef gr m c
Q (m,c) | isOperIdent c -> --- name convention of subexp opers
errVal t $ liftM unparTerm $ lookupResDef gr (m,c)
_ -> C.composSafeOp unparTerm t
gr = M.MGrammar [sm]
rebuild = buildTree . concat
@@ -84,7 +84,7 @@ addSubexpConsts mo tree lins = do
return (f,ResOper ty (Just (L loc trm')))
_ -> return (f,def)
recomp f t = case Map.lookup t tree of
Just (_,id) | operIdent id /= f -> return $ Q mo (operIdent id)
Just (_,id) | operIdent id /= f -> return $ Q (mo, operIdent id)
_ -> C.composOp (recomp f) t
list = Map.toList tree

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

@@ -142,10 +142,10 @@ extendMod gr isCompl (name,cond) base old new = foldM try new $ Map.toList old
Just j -> case unifyAnyInfo name i j of
Ok k -> return $ updateTree (c,k) new
Bad _ -> do (base,j) <- case j of
AnyInd _ m -> lookupOrigInfo gr m c
AnyInd _ m -> lookupOrigInfo gr (m,c)
_ -> return (base,j)
(name,i) <- case i of
AnyInd _ m -> lookupOrigInfo gr m c
AnyInd _ m -> lookupOrigInfo gr (m,c)
_ -> return (name,i)
fail $ render (text "cannot unify the information" $$
nest 4 (ppJudgement Qualified (c,i)) $$