mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-09 04:59:31 -06:00
120 lines
4.4 KiB
Haskell
120 lines
4.4 KiB
Haskell
----------------------------------------------------------------------
|
|
-- |
|
|
-- Module : Rebuild
|
|
-- Maintainer : AR
|
|
-- Stability : (stable)
|
|
-- Portability : (portable)
|
|
--
|
|
-- > CVS $Date: 2005/03/15 17:18:51 $
|
|
-- > CVS $Author: aarne $
|
|
-- > CVS $Revision: 1.11 $
|
|
--
|
|
-- Rebuild a source module from incomplete and its with-instance.
|
|
-----------------------------------------------------------------------------
|
|
|
|
module Rebuild (rebuildModule) where
|
|
|
|
import Grammar
|
|
import ModDeps
|
|
import PrGrammar
|
|
import Lookup
|
|
import Extend
|
|
import Macros
|
|
|
|
import Ident
|
|
import Modules
|
|
import Operations
|
|
|
|
-- | rebuilding instance + interface, and "with" modules, prior to renaming.
|
|
-- AR 24/10/2003
|
|
rebuildModule :: [SourceModule] -> SourceModule -> Err SourceModule
|
|
rebuildModule ms mo@(i,mi) = 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 mi of
|
|
|
|
-- add the information given in interface into an instance module
|
|
ModMod m -> do
|
|
testErr (null is || mstatus m == MSIncomplete)
|
|
("module" +++ prt i +++
|
|
"has open interfaces and must therefore be declared incomplete")
|
|
case mtype m of
|
|
MTInstance i0 -> do
|
|
m1 <- lookupModMod gr i0
|
|
testErr (isModRes m1) ("interface expected instead of" +++ prt i0)
|
|
m' <- do
|
|
js' <- extendMod False i0 i (jments m1) (jments m)
|
|
--- to avoid double inclusions, in instance I of I0 = J0 ** ...
|
|
case extends m of
|
|
[] -> return $ replaceJudgements m js'
|
|
j0:jj -> do
|
|
m0 <- lookupModMod gr j0
|
|
let notInM0 c = not $ isInBinTree (fst c) $ mapTree fst $ jments m0
|
|
let js2 = sorted2tree $ filter notInM0 $ tree2list js'
|
|
if null jj
|
|
then return $ replaceJudgements m js2
|
|
else Bad "FIXME: handle multiple inheritance in instance"
|
|
return $ ModMod m'
|
|
_ -> return mi
|
|
|
|
-- add the instance opens to an incomplete module "with" instances
|
|
ModWith mt stat ext me ops -> do
|
|
let insts = [(inf,inst) | OQualif _ inf inst <- ops]
|
|
let infs = map fst insts
|
|
let stat' = ifNull MSComplete (const MSIncomplete)
|
|
[i | i <- is, notElem i infs]
|
|
testErr (stat' == MSComplete || stat == MSIncomplete)
|
|
("module" +++ prt i +++ "remains incomplete")
|
|
Module mt0 _ fs me' ops0 js <- lookupModMod gr ext
|
|
let ops1 = ops ++ [o | o <- ops0, notElem (openedModule o) infs]
|
|
++ [oQualif i i | i <- map snd insts] ----
|
|
++ [oSimple i | i <- map snd insts] ----
|
|
---- ++ [oSimple ext] ---- to encode dependence
|
|
--- check if me is incomplete
|
|
return $ ModMod $ Module mt0 stat' fs me ops1 js
|
|
---- (mapTree (qualifInstanceInfo insts) js) -- not needed
|
|
|
|
_ -> return mi
|
|
return (i,mi')
|
|
|
|
checkCompleteInstance :: SourceRes -> SourceRes -> Err ()
|
|
checkCompleteInstance abs cnc = ifNull (return ()) (Bad . unlines) $
|
|
checkComplete [f | (f, ResOper (Yes _) _) <- abs'] cnc'
|
|
where
|
|
abs' = tree2list $ jments abs
|
|
cnc' = mapTree fst $ jments cnc
|
|
checkComplete sought given = foldr ckOne [] sought
|
|
where
|
|
ckOne f = if isInBinTree f given
|
|
then id
|
|
else (("Error: no definition given to" +++ prt f):)
|
|
|
|
{- ---- should not be needed
|
|
qualifInstanceInfo :: [(Ident,Ident)] -> (Ident,Info) -> (Ident,Info)
|
|
qualifInstanceInfo insts (c,i) = (c,qualInfo i) where
|
|
|
|
qualInfo i = case i of
|
|
ResOper pty pt -> ResOper (qualP pty) (qualP pt)
|
|
CncCat pty pt pp -> CncCat (qualP pty) (qualP pt) (qualP pp)
|
|
CncFun mp pt pp -> CncFun (qualLin mp) (qualP pt) (qualP pp) ---- mp
|
|
ResParam (Yes ps) -> ResParam (yes (map qualParam ps))
|
|
ResValue pty -> ResValue (qualP pty)
|
|
_ -> i
|
|
qualP pt = case pt of
|
|
Yes t -> yes $ qual t
|
|
May m -> may $ qualId m
|
|
_ -> pt
|
|
qualId x = maybe x id $ lookup x insts
|
|
qual t = case t of
|
|
Q m c -> Q (qualId m) c
|
|
QC m c -> QC (qualId m) c
|
|
_ -> composSafeOp qual t
|
|
qualParam (p,co) = (p,[(x,qual t) | (x,t) <- co])
|
|
qualLin (Just (c,(co,t))) = (Just (c,([(x,qual t) | (x,t) <- co], qual t)))
|
|
qualLin Nothing = Nothing
|
|
|
|
-- NB constructor patterns never appear in interfaces so we need not rename them
|
|
-}
|