diff options
Diffstat (limited to 'src/GF/Compile')
| -rw-r--r-- | src/GF/Compile/CheckGrammar.hs | 6 | ||||
| -rw-r--r-- | src/GF/Compile/Extend.hs | 28 | ||||
| -rw-r--r-- | src/GF/Compile/Rename.hs | 14 |
3 files changed, 36 insertions, 12 deletions
diff --git a/src/GF/Compile/CheckGrammar.hs b/src/GF/Compile/CheckGrammar.hs index 07151d8b7..8fe4cf988 100644 --- a/src/GF/Compile/CheckGrammar.hs +++ b/src/GF/Compile/CheckGrammar.hs @@ -101,7 +101,7 @@ checkResInfo gr (c,info) = do ty' <- check ty typeType >>= comp . fst (de',_) <- check de ty' return (Yes ty', Yes de') - (Nope, Yes de) -> do + (_, Yes de) -> do (de',ty') <- infer de return (Yes ty', Yes de') _ -> return (pty, pde) --- other cases are uninteresting @@ -611,6 +611,10 @@ checkEqLType env t u trm = do || elem n (allExtends env m) (QC m a, QC n b) | a == b -> elem m (allExtends env n) || elem n (allExtends env m) + (QC m a, Q n b) | a == b -> elem m (allExtends env n) + || elem n (allExtends env m) + (Q m a, QC n b) | a == b -> elem m (allExtends env n) + || elem n (allExtends env m) (RecType rs, RecType ts) -> and [alpha g a b && l == k --- too strong req | ((l,a),(k,b)) <- zip rs ts] diff --git a/src/GF/Compile/Extend.hs b/src/GF/Compile/Extend.hs index 582a1e6ae..348cdf71d 100644 --- a/src/GF/Compile/Extend.hs +++ b/src/GF/Compile/Extend.hs @@ -27,8 +27,9 @@ extendModInfo name old new = case (old,new) of extendMod :: Ident -> BinTree (Ident,Info) -> BinTree (Ident,Info) -> Err (BinTree (Ident,Info)) -extendMod name old new = - foldM (tryInsert (extendAnyInfo name) (indirInfo name)) new $ tree2list old +extendMod name old new = foldM try new $ tree2list old where + try t i@(c,_) = errIn ("constant" +++ prt c) $ + tryInsert (extendAnyInfo name) (indirInfo name) t i indirInfo :: Ident -> Info -> Info indirInfo n info = AnyInd b n' where @@ -58,7 +59,7 @@ perhIndir n p = case p of _ -> p extendAnyInfo :: Ident -> Info -> Info -> Err Info -extendAnyInfo n i j = case (i,j) of +extendAnyInfo n i j = errIn ("building extension for" +++ prt n) $ case (i,j) of (AbsCat mc1 mf1, AbsCat mc2 mf2) -> liftM2 AbsCat (updatePerhaps n mc1 mc2) (updatePerhaps n mf1 mf2) --- add cstrs (AbsFun mt1 md1, AbsFun mt2 md2) -> @@ -66,8 +67,7 @@ extendAnyInfo n i j = case (i,j) of (ResParam mt1, ResParam mt2) -> liftM ResParam $ updatePerhaps n mt1 mt2 (ResValue mt1, ResValue mt2) -> liftM ResValue $ updatePerhaps n mt1 mt2 - (ResOper mt1 m1, ResOper mt2 m2) -> - liftM2 ResOper (updatePerhaps n mt1 mt2) (updatePerhaps n m1 m2) + (ResOper mt1 m1, ResOper mt2 m2) -> extendResOper n mt1 m1 mt2 m2 (CncCat mc1 mf1 mp1, CncCat mc2 mf2 mp2) -> liftM3 CncCat (updatePerhaps n mc1 mc2) @@ -75,4 +75,20 @@ extendAnyInfo n i j = case (i,j) of (CncFun m mt1 md1, CncFun _ mt2 md2) -> liftM2 (CncFun m) (updatePerhaps n mt1 mt2) (updatePerhaps n md1 md2) - _ -> Bad $ "cannot unify information for" +++ show n + (AnyInd _ _, ResOper _ _) -> return j ---- + + _ -> Bad $ "cannot unify information in" ++++ show i ++++ "and" ++++ show j + + +-- opers declared in one module and defined in an extension are a special case + +extendResOper n mt1 m1 mt2 m2 = case (m1,m2) of + (Nope,_) -> return $ ResOper (strip mt1) m2 + _ -> liftM2 ResOper (updatePerhaps n mt1 mt2) (updatePerhaps n m1 m2) + where + strip (Yes t) = Yes $ strp t + strip m = m + strp t = case t of + Q _ c -> Vr c + QC _ c -> Vr c + _ -> composSafeOp strp t diff --git a/src/GF/Compile/Rename.hs b/src/GF/Compile/Rename.hs index a4d9b9365..6f652820a 100644 --- a/src/GF/Compile/Rename.hs +++ b/src/GF/Compile/Rename.hs @@ -62,7 +62,7 @@ extendModule ms (name,mod) = case mod of _ -> Bad $ "cannot find extended module" +++ prt n extendMod n (jments m0) js _ -> return js - return $ (name,ModMod (Module mt fs Nothing ops js1)) + return $ (name,ModMod (Module mt fs me ops js1)) type Status = (StatusTree, [(OpenSpec Ident, StatusTree)]) @@ -72,7 +72,9 @@ type StatusTree = BinTree (Ident,StatusInfo) type StatusInfo = Ident -> Term renameIdentTerm :: Status -> Term -> Err Term -renameIdentTerm env@(act,imps) t = case t of +renameIdentTerm env@(act,imps) t = + errIn ("atomic term" +++ prt t +++ "given" +++ unwords (map (prt . fst) qualifs)) $ + case t of Vr c -> do f <- lookupTreeMany prt opens c return $ f c @@ -90,7 +92,8 @@ renameIdentTerm env@(act,imps) t = case t of _ -> return t where opens = act : [st | (OSimple _,st) <- imps] - qualifs = [ (m, st) | (OQualif m _, st) <- imps] + qualifs = [(m, st) | (OQualif m _, st) <- imps] ++ + [(m, st) | (OSimple m, st) <- imps] -- qualifying is always possible --- would it make sense to optimize this by inlining? renameIdentPatt :: Status -> Patt -> Err Patt @@ -117,8 +120,9 @@ tree2status o = case o of buildStatus :: SourceGrammar -> Ident -> SourceModInfo -> Err Status buildStatus gr c mo = let mo' = self2status c mo in case mo of ModMod m -> do - let ops = allOpens m - mods <- mapM (lookupModule gr . openedModule) ops + let gr1 = MGrammar $ (c,mo) : modules gr + ops = [OSimple e | e <- allExtends gr1 c] ++ allOpens m + mods <- mapM (lookupModule gr1 . openedModule) ops let sts = map modInfo2status $ zip ops mods return $ if isModCnc m then (NT, sts) -- the module itself does not define any names |