---------------------------------------------------------------------- -- | -- Module : Update -- Maintainer : AR -- Stability : (stable) -- Portability : (portable) -- -- > CVS $Date: 2005/05/30 18:39:44 $ -- > CVS $Author: aarne $ -- > CVS $Revision: 1.8 $ -- -- (Description of the module) ----------------------------------------------------------------------------- module GF.Compile.Update (buildAnyTree, extendModule, rebuildModule) where import GF.Infra.Ident import GF.Grammar.Grammar import GF.Grammar.Printer import GF.Infra.Modules import GF.Infra.Option import GF.Data.Operations import Data.List import qualified Data.Map as Map import Control.Monad import Text.PrettyPrint -- | combine a list of definitions into a balanced binary search tree buildAnyTree :: Ident -> [(Ident,Info)] -> Err (BinTree Ident Info) buildAnyTree m = go Map.empty where go map [] = return map go map ((c,j):is) = do case Map.lookup c map of Just i -> case unifyAnyInfo c i j of Ok k -> go (Map.insert c k map) is Bad _ -> fail $ render (text "cannot unify the informations" $$ nest 4 (ppJudgement Qualified (c,i)) $$ text "and" $+$ nest 4 (ppJudgement Qualified (c,j)) $$ text "in module" <+> ppIdent m) Nothing -> go (Map.insert c j map) is extendModule :: [SourceModule] -> SourceModule -> Err SourceModule extendModule ms (name,m) ---- Just to allow inheritance in incomplete concrete (which are not ---- compiled anyway), extensions are not built for them. ---- Should be replaced by real control. AR 4/2/2005 | mstatus m == MSIncomplete && isModCnc m = return (name,m) | otherwise = do m' <- foldM extOne m (extend m) return (name,m') where extOne mo (n,cond) = do m0 <- lookupModule (MGrammar ms) n -- test that the module types match, and find out if the old is complete testErr (sameMType (mtype m) (mtype mo)) ("illegal extension type to module" +++ prIdent name) let isCompl = isCompleteModule m0 -- build extension in a way depending on whether the old module is complete js1 <- extendMod isCompl (n, isInherited cond) name (jments m0) (jments mo) -- if incomplete, throw away extension information return $ if isCompl then mo {jments = js1} else mo {extend = filter ((/=n) . fst) (extend mo) ,mexdeps= nub (n : mexdeps mo) ,jments = js1 } -- | rebuilding instance + interface, and "with" modules, prior to renaming. -- AR 24/10/2003 rebuildModule :: [SourceModule] -> SourceModule -> Err SourceModule rebuildModule ms mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ js_ ps_)) = do let gr = MGrammar ms ---- deps <- moduleDeps ms ---- is <- openInterfaces deps i let is = [] ---- the method above is buggy: try "i -src" for two grs. AR 8/3/2005 mi' <- case mw of -- add the information given in interface into an instance module Nothing -> do testErr (null is || mstatus mi == MSIncomplete) ("module" +++ prIdent i +++ "has open interfaces and must therefore be declared incomplete") case mt of MTInstance i0 -> do m1 <- lookupModule gr i0 testErr (isModRes m1) ("interface expected instead of" +++ prIdent i0) js' <- extendMod False (i0,const True) i (jments m1) (jments mi) --- to avoid double inclusions, in instance I of I0 = J0 ** ... case extends mi of [] -> return $ replaceJudgements mi js' j0s -> do m0s <- mapM (lookupModule gr) j0s let notInM0 c _ = all (not . isInBinTree c . jments) m0s let js2 = filterBinTree notInM0 js' return $ (replaceJudgements mi js2) {positions = Map.union (positions m1) (positions mi)} _ -> return mi -- add the instance opens to an incomplete module "with" instances Just (ext,incl,ops) -> do let (infs,insts) = unzip ops let stat' = ifNull MSComplete (const MSIncomplete) [i | i <- is, notElem i infs] testErr (stat' == MSComplete || stat == MSIncomplete) ("module" +++ prIdent i +++ "remains incomplete") ModInfo mt0 _ fs me' _ ops0 _ js ps0 <- lookupModule gr ext let ops1 = nub $ ops_ ++ -- N.B. js has been name-resolved already [OQualif i j | (i,j) <- ops] ++ [o | o <- ops0, notElem (openedModule o) infs] ++ [OQualif i i | i <- insts] ++ [OSimple i | i <- insts] --- check if me is incomplete let fs1 = fs `addOptions` fs_ -- new flags have priority let js0 = [ci | ci@(c,_) <- tree2list js, isInherited incl c] let js1 = buildTree (tree2list js_ ++ js0) let ps1 = Map.union ps_ ps0 let med1= nub (ext : infs ++ insts ++ med_) return $ ModInfo mt0 stat' fs1 me Nothing ops1 med1 js1 ps1 return (i,mi') -- | When extending a complete module: new information is inserted, -- and the process is interrupted if unification fails. -- If the extended module is incomplete, its judgements are just copied. extendMod :: Bool -> (Ident,Ident -> Bool) -> Ident -> BinTree Ident Info -> BinTree Ident Info -> Err (BinTree Ident Info) extendMod isCompl (name,cond) base old new = foldM try new $ Map.toList old where try new (c,i) | not (cond c) = return new | otherwise = case Map.lookup c new of Just j -> case unifyAnyInfo c i j of Ok k -> return $ updateTree (c,k) new Bad _ -> fail $ render (text "cannot unify the information" $$ nest 4 (ppJudgement Qualified (c,i)) $$ text "in module" <+> ppIdent name <+> text "with" $$ nest 4 (ppJudgement Qualified (c,j)) $$ text "in module" <+> ppIdent base) Nothing -> if isCompl then return $ updateTree (c,indirInfo name i) new else return $ updateTree (c,i) new indirInfo :: Ident -> Info -> Info indirInfo n info = AnyInd b n' where (b,n') = case info of ResValue _ -> (True,n) ResParam _ -> (True,n) AbsFun _ (Just EData) -> (True,n) AnyInd b k -> (b,k) _ -> (False,n) ---- canonical in Abs unifyAnyInfo :: Ident -> Info -> Info -> Err Info unifyAnyInfo c i j = case (i,j) of (AbsCat mc1 mf1, AbsCat mc2 mf2) -> liftM2 AbsCat (unifMaybe mc1 mc2) (unifConstrs mf1 mf2) -- adding constrs (AbsFun mt1 md1, AbsFun mt2 md2) -> liftM2 AbsFun (unifMaybe mt1 mt2) (unifAbsDefs md1 md2) -- adding defs (ResParam mt1, ResParam mt2) -> liftM ResParam $ unifMaybe mt1 mt2 (ResValue mt1, ResValue mt2) -> liftM ResValue $ unifMaybe mt1 mt2 (_, ResOverload ms t) | elem c ms -> return $ ResOverload ms t (ResOper mt1 m1, ResOper mt2 m2) -> liftM2 ResOper (unifMaybe mt1 mt2) (unifMaybe m1 m2) (CncCat mc1 mf1 mp1, CncCat mc2 mf2 mp2) -> liftM3 CncCat (unifMaybe mc1 mc2) (unifMaybe mf1 mf2) (unifMaybe mp1 mp2) (CncFun m mt1 md1, CncFun _ mt2 md2) -> liftM2 (CncFun m) (unifMaybe mt1 mt2) (unifMaybe md1 md2) ---- adding defs (AnyInd b1 m1, AnyInd b2 m2) -> do testErr (b1 == b2) $ "indirection status" testErr (m1 == m2) $ "different sources of indirection" return i _ -> fail "informations" -- | this is what happens when matching two values in the same module unifMaybe :: Eq a => Maybe a -> Maybe a -> Err (Maybe a) unifMaybe Nothing Nothing = return Nothing unifMaybe (Just p1) Nothing = return (Just p1) unifMaybe Nothing (Just p2) = return (Just p2) unifMaybe (Just p1) (Just p2) | p1==p2 = return (Just p1) | otherwise = fail "" unifAbsDefs :: Maybe Term -> Maybe Term -> Err (Maybe Term) unifAbsDefs p1 p2 = case (p1,p2) of (Nothing, _) -> return p2 (_, Nothing) -> return p1 (Just (Eqs bs), Just (Eqs ds)) -> return $ Just $ Eqs $ bs ++ ds --- order! _ -> fail "definitions" unifConstrs :: Maybe [Term] -> Maybe [Term] -> Err (Maybe [Term]) unifConstrs p1 p2 = case (p1,p2) of (Nothing, _) -> return p2 (_, Nothing) -> return p1 (Just bs, Just ds) -> return $ Just $ bs ++ ds