forked from GitHub/gf-core
246 lines
10 KiB
Haskell
246 lines
10 KiB
Haskell
----------------------------------------------------------------------
|
|
-- |
|
|
-- 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.Grammar.Lookup
|
|
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 m 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 :: SourceGrammar -> SourceModule -> Err SourceModule
|
|
extendModule gr (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 (mextend m)
|
|
return (name,m')
|
|
where
|
|
extOne mo (n,cond) = do
|
|
m0 <- lookupModule gr 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" +++ showIdent name)
|
|
|
|
let isCompl = isCompleteModule m0
|
|
|
|
-- build extension in a way depending on whether the old module is complete
|
|
js1 <- extendMod gr isCompl ((n,m0), isInherited cond) name (jments mo)
|
|
|
|
-- if incomplete, throw away extension information
|
|
return $
|
|
if isCompl
|
|
then mo {jments = js1}
|
|
else mo {mextend= filter ((/=n) . fst) (mextend mo)
|
|
,mexdeps= nub (n : mexdeps mo)
|
|
,jments = js1
|
|
}
|
|
|
|
-- | rebuilding instance + interface, and "with" modules, prior to renaming.
|
|
-- AR 24/10/2003
|
|
rebuildModule :: SourceGrammar -> SourceModule -> Err SourceModule
|
|
rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ src_ js_)) = do
|
|
---- 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" +++ showIdent i +++
|
|
"has open interfaces and must therefore be declared incomplete")
|
|
case mt of
|
|
MTInstance (i0,mincl) -> do
|
|
m1 <- lookupModule gr i0
|
|
testErr (isModRes m1) ("interface expected instead of" +++ showIdent i0)
|
|
js' <- extendMod gr False ((i0,m1), isInherited mincl) i (jments mi)
|
|
--- to avoid double inclusions, in instance I of I0 = J0 ** ...
|
|
case extends mi of
|
|
[] -> return mi{jments=js'}
|
|
j0s -> do
|
|
m0s <- mapM (lookupModule gr) j0s
|
|
let notInM0 c _ = all (not . isInBinTree c . jments) m0s
|
|
let js2 = filterBinTree notInM0 js'
|
|
return mi{jments=js2}
|
|
_ -> 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" +++ showIdent i +++ "remains incomplete")
|
|
ModInfo mt0 _ fs me' _ ops0 _ _ js <- 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 med1= nub (ext : infs ++ insts ++ med_)
|
|
return $ ModInfo mt0 stat' fs1 me Nothing ops1 med1 src_ js1
|
|
|
|
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 :: SourceGrammar ->
|
|
Bool -> (SourceModule,Ident -> Bool) -> Ident ->
|
|
BinTree Ident Info -> Err (BinTree Ident Info)
|
|
extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jments mi)
|
|
where
|
|
try new (c,i0)
|
|
| not (cond c) = return new
|
|
| otherwise = case Map.lookup c new of
|
|
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)
|
|
_ -> return (base,j)
|
|
(name,i) <- case i of
|
|
AnyInd _ m -> lookupOrigInfo gr (m,c)
|
|
_ -> return (name,i)
|
|
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
|
|
where
|
|
i = globalizeLoc (msrc mi) i0
|
|
|
|
indirInfo :: Ident -> Info -> Info
|
|
indirInfo n info = AnyInd b n' where
|
|
(b,n') = case info of
|
|
ResValue _ -> (True,n)
|
|
ResParam _ _ -> (True,n)
|
|
AbsFun _ _ Nothing _ -> (True,n)
|
|
AnyInd b k -> (b,k)
|
|
_ -> (False,n) ---- canonical in Abs
|
|
|
|
globalizeLoc fpath i =
|
|
case i of
|
|
AbsCat mc -> AbsCat (fmap gl mc)
|
|
AbsFun mt ma md moper -> AbsFun (fmap gl mt) ma (fmap (fmap gl) md) moper
|
|
ResParam mt mv -> ResParam (fmap gl mt) mv
|
|
ResValue t -> ResValue (gl t)
|
|
ResOper mt m -> ResOper (fmap gl mt) (fmap gl m)
|
|
ResOverload ms os -> ResOverload ms (map (\(x,y) -> (gl x,gl y)) os)
|
|
CncCat mc mf mp -> CncCat (fmap gl mc) (fmap gl mf) (fmap gl mp)
|
|
CncFun m mt md -> CncFun m (fmap gl mt) (fmap gl md)
|
|
AnyInd b m -> AnyInd b m
|
|
where
|
|
gl (L loc0 x) = loc `seq` L (External fpath loc) x
|
|
where
|
|
loc = case loc0 of
|
|
External _ loc -> loc
|
|
loc -> loc
|
|
|
|
unifyAnyInfo :: Ident -> Info -> Info -> Err Info
|
|
unifyAnyInfo m i j = case (i,j) of
|
|
(AbsCat mc1, AbsCat mc2) ->
|
|
liftM AbsCat (unifMaybeL mc1 mc2)
|
|
(AbsFun mt1 ma1 md1 moper1, AbsFun mt2 ma2 md2 moper2) ->
|
|
liftM4 AbsFun (unifMaybeL mt1 mt2) (unifAbsArrity ma1 ma2) (unifAbsDefs md1 md2) (unifMaybe moper1 moper2) -- adding defs
|
|
|
|
(ResParam mt1 mv1, ResParam mt2 mv2) ->
|
|
liftM2 ResParam (unifMaybeL mt1 mt2) (unifMaybe mv1 mv2)
|
|
(ResValue (L l1 t1), ResValue (L l2 t2))
|
|
| t1==t2 -> return (ResValue (L l1 t1))
|
|
| otherwise -> fail ""
|
|
(_, ResOverload ms t) | elem m ms ->
|
|
return $ ResOverload ms t
|
|
(ResOper mt1 m1, ResOper mt2 m2) ->
|
|
liftM2 ResOper (unifMaybeL mt1 mt2) (unifMaybeL m1 m2)
|
|
|
|
(CncCat mc1 mf1 mp1, CncCat mc2 mf2 mp2) ->
|
|
liftM3 CncCat (unifMaybeL mc1 mc2) (unifMaybeL mf1 mf2) (unifMaybeL mp1 mp2)
|
|
(CncFun m mt1 md1, CncFun _ mt2 md2) ->
|
|
liftM2 (CncFun m) (unifMaybeL mt1 mt2) (unifMaybeL 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 ""
|
|
|
|
-- | this is what happens when matching two values in the same module
|
|
unifMaybeL :: Eq a => Maybe (L a) -> Maybe (L a) -> Err (Maybe (L a))
|
|
unifMaybeL Nothing Nothing = return Nothing
|
|
unifMaybeL (Just p1) Nothing = return (Just p1)
|
|
unifMaybeL Nothing (Just p2) = return (Just p2)
|
|
unifMaybeL (Just (L l1 p1)) (Just (L l2 p2))
|
|
| p1==p2 = return (Just (L l1 p1))
|
|
| otherwise = fail ""
|
|
|
|
unifAbsArrity :: Maybe Int -> Maybe Int -> Err (Maybe Int)
|
|
unifAbsArrity Nothing Nothing = return Nothing
|
|
unifAbsArrity (Just a ) Nothing = return (Just a )
|
|
unifAbsArrity Nothing (Just a ) = return (Just a )
|
|
unifAbsArrity (Just a1) (Just a2)
|
|
| a1==a2 = return (Just a1)
|
|
| otherwise = fail ""
|
|
|
|
unifAbsDefs :: Maybe [L Equation] -> Maybe [L Equation] -> Err (Maybe [L Equation])
|
|
unifAbsDefs Nothing Nothing = return Nothing
|
|
unifAbsDefs (Just _ ) Nothing = fail ""
|
|
unifAbsDefs Nothing (Just _ ) = fail ""
|
|
unifAbsDefs (Just xs) (Just ys) = return (Just (xs ++ ys))
|