restored work on Extend and Rename

src/GF/Devel/Compile/Compile.hs

@@ -3,8 +3,7 @@ module GF.Devel.Compile.Compile (batchCompile) where
 -- the main compiler passes
 import GF.Devel.Compile.GetGrammar
 import GF.Devel.Compile.Extend
-----import GF.Compile.Rebuild
-----import GF.Compile.Rename
+import GF.Devel.Compile.Rename
 ----import GF.Grammar.Refresh
 ----import GF.Devel.CheckGrammar
 ----import GF.Devel.Optimize
@@ -147,10 +146,15 @@ compileSourceModule opts env@(k,gr) mo@(i,mi) = do
   let putp  = putPointE opts
       putpp = putPointEsil opts
 
-  mo1  <- ioeErr $ extendModule gr mo
-  intermOut opts (iOpt "show_extend") (prMod mo1)
 
-  return (k,mo1) ----
+  mor <- ioeErr $ renameModule gr mo
+  intermOut opts (iOpt "show_rename") (prMod mor)
+
+  moe <- ioeErr $ extendModule gr mor
+  intermOut opts (iOpt "show_extend") (prMod moe)
+
+
+  return (k,moe) ----
 
 {- ----
   mo1   <- ioeErr $ rebuildModule mos mo
@@ -161,8 +165,6 @@ compileSourceModule opts env@(k,gr) mo@(i,mi) = do
     (_,ModMod n) | not (isCompleteModule n) -> do
       return (k,mo1b)   -- refresh would fail, since not renamed
     _ -> do
-      mo2:_ <- putpp "  renaming " $ ioeErr $ renameModule mos mo1b
-      intermOut opts (iOpt "show_rename") (prMod mo2)
 
       (mo3:_,warnings) <- putpp "  type checking" $ ioeErr $ showCheckModule mos mo2
       if null warnings then return () else putp warnings $ return ()

src/GF/Devel/Compile/Extend.hs

@@ -49,19 +49,22 @@ extendModule gf nmo0 = do
       return (name, mo') 
  where
    extOne name mo (n,cond) = do
-     (m0,isCompl) <- do
-        m <- lookupModule gf n
+     mo0 <- lookupModule gf n
 
-        -- test that the module types match, and find out if the old is complete
-        testErr True ---- (mtype mo == mtype m) 
+     -- test that the module types match
+     testErr True ---- (legalExtension mo mo0) 
                     ("illegal extension type to module" +++ prt name)
-        return (m, isCompleteModule m)
 
-     -- build extension in a way depending on whether the old module is complete
-     js0 <- extendMod isCompl n (isInherited cond) name (mjments m0) (mjments mo)
+     -- find out if the old is complete
+     let isCompl = isCompleteModule mo0
+
+     -- if incomplete, remove it from extension list --- because??
+     let me' = (if isCompl then id else (Prelude.filter ((/=n) . fst))) 
+                 (mextends mo) 
+
+     -- build extension depending on whether the old module is complete
+     js0 <- extendMod isCompl n (isInherited cond) name (mjments mo0) (mjments mo)
 
-     -- if incomplete, throw away extension information
-     let me' = mextends mo ----if isCompl then es else (filter ((/=n) . fst) es) 
      return $ mo {mextends = me', mjments = js0}
 
 -- | When extending a complete module: new information is inserted,
@@ -89,7 +92,7 @@ extendAnyInfo isc n o i j =
       testErr (m1 == m2) $ 
         "different sources of inheritance:" +++ show m1 +++ show m2
       return i
-    _ -> Bad $ "cannot unify information in"---- ++++ prt i ++++ "and" ++++ prt j
+    _ -> Bad $ "cannot unify information in" ++++ prJEntry i ++++ prJEntry j
 
 tryInsert :: Ord a => (b -> b -> Err b) -> (b -> b) ->
              Map a b -> (a,b) -> Err (Map a b)
@@ -103,45 +106,51 @@ tryInsert unif indir tree z@(x, info) = case Data.Map.lookup x tree of
 -- AR 24/10/2003
 rebuildModule :: GF -> SourceModule -> Err SourceModule
 rebuildModule gr mo@(i,mi) = case mtype mi of
+
+  -- copy interface contents to instance
   MTInstance i0 -> do
-          m1 <- lookupModule gr i0
-          testErr (mtype m1 == MTInterface) 
-                  ("interface expected as type of" +++ prt i0)
-          js' <- extendMod False i0 (const True) i (mjments m1) (mjments mi)
-          --- to avoid double inclusions, in instance I of I0 = J0 ** ...
-          case mextends mi of
-            [] -> return $ (i,mi {mjments = js'})
-            j0s -> do 
-              m0s <- mapM (lookupModule gr . fst) j0s ---- restricted?? 12/2007
-              let notInM0 c _  = all (notMember c . mjments) m0s
-              let js2 = filterWithKey notInM0 js'
-              return $ (i,mi {mjments = js2})
+    m1 <- lookupModule gr i0
+    testErr (isInterface m1) ("not an interface:" +++ prt i0)
+    js1 <- extendMod False i0 (const True) i (mjments m1) (mjments mi)
 
-    -- add the instance opens to an incomplete module "with" instances
-    --      ModWith mt stat ext me ops -> do
-    --    ModWith (Module mt stat fs_ me ops_ js_) (ext,incl) ops -> do
+    --- to avoid double inclusions, in instance J of I0 = J0 ** ...
+    case mextends mi of
+      [] -> return $ (i,mi {mjments = js1})
+      es -> do 
+        mes <- mapM (lookupModule gr . fst) es ---- restricted?? 12/2007
+        let notInExts c _  = all (notMember c . mjments) mes
+        let js2 = filterWithKey notInExts js1
+        return $ (i,mi {mjments = js2})
 
+  -- copy functor contents to instantiation, and also add opens
   _ -> case minstances mi of
     [((ext,incl),ops)] -> do
-        let infs  = Prelude.map fst ops
-        let stat' = Prelude.null [i | (_,i) <- minterfaces mi, notElem i infs]
-        testErr stat' ("module" +++ prt i +++ "remains incomplete")
-           --        Module mt0 _ fs me' ops0 js <- lookupModMod gr ext
-        mo0 <- lookupModule gr ext
-        let ops1 = nub $
-                     mopens mi ++   -- N.B. mo0 has been name-resolved already
-                     ops ++ 
-                     [(n,o) | (n,o) <- mopens mo0, notElem o infs] ++
-                     [(i,i) | i <- Prelude.map snd ops] ----
-                     ----    ++ [oSimple i   | i <- map snd ops] ----
+      let interfs  = Prelude.map fst ops
 
-        --- check if me is incomplete
-        let fs1 = union (mflags mi) (mflags mo0)  -- new flags have priority
-        let js0 = [ci | ci@(c,_) <- assocs (mjments mo0), isInherited incl c]
-        let js1 = fromList (assocs (mjments mi) ++ js0)
-        return $ (i,mo0 {
+      -- test that all interfaces are instantiated
+      let isCompl = Prelude.null [i | (_,i) <- minterfaces mi, notElem i interfs]
+      testErr isCompl ("module" +++ prt i +++ "remains incomplete")
+
+      -- look up the functor and build new opens set
+      mi0 <- lookupModule gr ext
+      let 
+        ops1 = nub $
+             mopens mi   -- own opens; N.B. mi0 has been name-resolved already
+          ++ ops         -- instantiating opens
+          ++ [(n,o) | 
+               (n,o) <- mopens mi0, notElem o interfs] -- ftor's non-if opens
+          ++ [(i,i) | i <- Prelude.map snd ops] ----   -- insts w. real names
+
+      -- combine flags; new flags have priority
+      let fs1 = union (mflags mi) (mflags mi0)  
+      
+      -- copy inherited functor judgements
+      let js0 = [ci | ci@(c,_) <- assocs (mjments mi0), isInherited incl c]
+      let js1 = fromList (assocs (mjments mi) ++ js0)
+
+      return $ (i,mi {
           mflags = fs1, 
-          mextends = mextends mi,
+          mextends = mextends mi,  -- extends of instantiation
           mopens = ops1,
           mjments = js1
           })

src/GF/Devel/Compile/Refresh.hs

@@ -0,0 +1,133 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Refresh
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/21 16:22:27 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.6 $
+--
+-- (Description of the module)
+-----------------------------------------------------------------------------
+
+module GF.Devel.Compile.Refresh (refreshTerm, refreshTermN,
+		refreshModule
+	       ) where
+
+import GF.Data.Operations
+import GF.Grammar.Grammar
+import GF.Infra.Ident
+import GF.Infra.Modules
+import GF.Grammar.Macros
+import Control.Monad
+
+refreshTerm :: Term -> Err Term
+refreshTerm = refreshTermN 0
+
+refreshTermN :: Int -> Term -> Err Term
+refreshTermN i e = liftM snd $ refreshTermKN i e
+
+refreshTermKN :: Int -> Term -> Err (Int,Term)
+refreshTermKN i e = liftM (\ (t,(_,i)) -> (i,t)) $ 
+                    appSTM (refresh e) (initIdStateN i)
+
+refresh :: Term -> STM IdState Term
+refresh e = case e of
+
+  Vr x    -> liftM  Vr  (lookVar x)
+  Abs x b -> liftM2 Abs (refVarPlus x)  (refresh b)
+
+  Prod x a b -> do
+    a'  <- refresh a
+    x'  <- refVar  x
+    b'  <- refresh b
+    return $ Prod x' a' b'
+
+  Let (x,(mt,a)) b -> do
+    a'  <- refresh a
+    mt' <- case mt of
+             Just t -> refresh t >>= (return . Just) 
+             _ -> return mt
+    x'  <- refVar x
+    b'  <- refresh b
+    return (Let (x',(mt',a')) b')
+
+  R r  -> liftM R $ refreshRecord r
+
+  ExtR r s -> liftM2 ExtR (refresh r)  (refresh s)
+  
+  T i cc -> liftM2 T (refreshTInfo i) (mapM refreshCase cc)
+
+  _ -> composOp refresh e
+
+refreshCase :: (Patt,Term) -> STM IdState (Patt,Term)
+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)
+  PR r    -> liftM PR     (mapPairsM refreshPatt r)
+  PT t p' -> liftM2 PT    (refresh t) (refreshPatt p')
+
+  PAs x p'   -> liftM2 PAs     (refVar x) (refreshPatt p')
+
+  PSeq p' q' -> liftM2 PSeq    (refreshPatt p') (refreshPatt q')
+  PAlt p' q' -> liftM2 PAlt    (refreshPatt p') (refreshPatt q')
+  PRep p'    -> liftM  PRep    (refreshPatt p')
+  PNeg p'    -> liftM  PNeg    (refreshPatt p')
+
+  _ -> return p
+
+refreshRecord r = case r of
+  [] -> return r
+  (x,(mt,a)):b -> do
+    a'  <- refresh a
+    mt' <- case mt of
+             Just t -> refresh t >>= (return . Just) 
+             _ -> return mt
+    b'  <- refreshRecord b
+    return $ (x,(mt',a')) : b'
+
+refreshTInfo i = case i of
+  TTyped t -> liftM TTyped $ refresh t
+  TComp t -> liftM TComp $ refresh t
+  TWild t -> liftM TWild $ refresh t
+  _ -> return i
+
+-- for abstract syntax
+
+refreshEquation :: Equation -> Err ([Patt],Term)
+refreshEquation pst = err Bad (return . fst) (appSTM (refr pst) initIdState) where
+  refr (ps,t) = liftM2 (,) (mapM refreshPatt ps) (refresh t)
+
+-- for concrete and resource in grammar, before optimizing
+
+refreshGrammar :: SourceGrammar -> Err SourceGrammar
+refreshGrammar = liftM (MGrammar . snd) . foldM refreshModule (0,[]) . modules
+
+refreshModule :: (Int,[SourceModule]) -> SourceModule -> Err (Int,[SourceModule])
+refreshModule (k,ms) mi@(i,m) = case m of
+    ModMod mo@(Module mt fs st me ops js) | (isModCnc mo || isModRes mo) -> do
+      (k',js') <- foldM refreshRes (k,[]) $ tree2list js
+      return (k', (i, ModMod(Module mt fs st me ops (buildTree js'))) : ms)
+    _ -> return (k, mi:ms)
+ where
+  refreshRes (k,cs) ci@(c,info) = case info of
+    ResOper ptyp (Yes trm) -> do   ---- refresh ptyp
+      (k',trm') <- refreshTermKN k trm
+      return $ (k', (c, ResOper ptyp (Yes trm')):cs)
+    ResOverload tyts -> do
+      (k',tyts') <- liftM (\ (t,(_,i)) -> (i,t)) $ 
+                    appSTM (mapPairsM refresh tyts) (initIdStateN k)
+      return $ (k', (c, ResOverload tyts'):cs)
+    CncCat mt (Yes trm) pn -> do   ---- refresh mt, pn
+      (k',trm') <- refreshTermKN k trm
+      return $ (k', (c, CncCat mt (Yes trm') pn):cs)
+    CncFun mt (Yes trm) pn -> do   ---- refresh pn
+      (k',trm') <- refreshTermKN k trm
+      return $ (k', (c, CncFun mt (Yes trm') pn):cs)
+    _ -> return (k, ci:cs)
+

src/GF/Devel/Compile/Rename.hs

@@ -0,0 +1,226 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Rename
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/05/30 18:39:44 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.19 $
+--
+-- AR 14\/5\/2003
+-- The top-level function 'renameGrammar' does several things:
+--
+--   - extends each module symbol table by indirections to extended module
+--
+--   - changes unqualified and as-qualified imports to absolutely qualified
+--
+--   - goes through the definitions and resolves names
+--
+-----------------------------------------------------------------------------
+
+module GF.Devel.Compile.Rename (
+  renameModule
+  ) where
+
+import GF.Devel.Grammar.Modules
+import GF.Devel.Grammar.Judgements
+import GF.Devel.Grammar.Terms
+import GF.Devel.Grammar.Macros
+import GF.Devel.Grammar.PrGF
+import GF.Infra.Ident
+import GF.Devel.Grammar.Lookup
+import GF.Data.Operations
+
+import Control.Monad
+import qualified Data.Map as Map
+import Data.List (nub)
+import Debug.Trace (trace)
+
+{-
+-- | this gives top-level access to renaming term input in the cc command
+renameSourceTerm :: SourceGrammar -> Ident -> Term -> Err Term
+renameSourceTerm g m t = do
+  mo     <- lookupErr m (modules g)
+  status <- buildStatus g m mo
+  renameTerm status [] t
+-}
+
+renameModule :: GF -> SourceModule -> Err SourceModule
+renameModule gf sm@(name,mo) = errIn ("renaming module" +++ prt name) $ do
+  let gf1 = gf {gfmodules = Map.insert name mo (gfmodules gf)}
+  let rename = renameTerm (gf1,sm) []
+  mo1 <- termOpModule rename mo
+  let mo2 = mo1 {mopens = [(i,i) | (_,i) <- mopens mo1]}
+  return (name,mo2)
+
+type RenameEnv = (GF,SourceModule)
+
+renameIdentTerm :: RenameEnv -> Term -> Err Term
+renameIdentTerm (gf, (name,mo)) trm = case trm of
+  Vr i -> looks i
+  Con i -> looks i
+  Q m i -> getQualified m >>= look i
+  _ -> return trm
+ where
+   looks i = do
+     let ts = nub [t | m <- pool, Ok t <- [look i m]]
+     case ts of
+       [t] -> return t 
+       [] | elem i [IC "Int",IC "Float",IC "String"] -> ---- do this better
+            return (Q (IC "PredefAbs") i)
+       [] -> prtBad "identifier not found" i
+       t:_ -> 
+         trace (unwords $ "WARNING":"identifier":prt i:"ambiguous:" : map prt ts) 
+               (return t)
+----       _ -> fail $ unwords $ "identifier" : prt i : "ambiguous:" : map prt ts
+   look i m = do
+     entry <- lookupIdent gf m i
+     return $ case entry of
+       Left j -> if isConstructor j then QC m i else Q m i
+       Right (n,b) -> if b then QC n i else Q n i
+   pool = nub $ name :
+                maybe name id (interfaceName mo) : 
+                IC "Predef" : 
+                map fst (mextends mo) ++ 
+                map snd (mopens mo) 
+   getQualified m = case Map.lookup m qualifMap of
+     Just n -> return n
+     _ -> prtBad "unknown qualifier" m
+   qualifMap = Map.fromList $ 
+     mopens mo ++ 
+     concat [ops | (_,ops) <- minstances mo] ++ 
+     [(m,m) | m <- pool]
+     ---- TODO: check uniqueness of these names
+
+renameTerm :: RenameEnv -> [Ident] -> Term -> Err Term
+renameTerm env vars = ren vars where
+  ren vs trm = case trm of
+    Abs x b    -> liftM  (Abs x) (ren (x:vs) b)
+    Prod x a b -> liftM2 (Prod x) (ren vs a) (ren (x:vs) b)
+    Typed a b  -> liftM2 Typed (ren vs a) (ren vs b)
+    Vr x      
+      | elem x vs -> return trm
+      | otherwise -> renid trm
+    Con _  -> renid trm
+    Q _ _  -> renid trm
+    QC _ _ -> renid trm
+    Eqs eqs -> liftM Eqs $ mapM (renameEquation env vars) eqs
+    T i cs -> do
+      i' <- case i of
+        TTyped ty -> liftM TTyped $ ren vs ty -- the only annotation in source
+        _ -> return i
+      liftM (T i') $ mapM (renCase vs) cs  
+
+    Let (x,(m,a)) b -> do
+      m' <- case m of
+        Just ty -> liftM Just $ ren vs ty
+        _ -> return m
+      a' <- ren vs a
+      b' <- ren (x:vs) b
+      return $ Let (x,(m',a')) b'
+
+    P t@(Vr r) l                     -- for constant t we know it is projection
+      | elem r vs -> return trm                           -- var proj first
+      | otherwise -> case renid (Q r (label2ident l)) of  -- qualif   second
+          Ok t -> return t
+          _ -> case liftM (flip P l) $ renid t of
+            Ok t -> return t                              -- const proj last
+            _ -> prtBad "unknown qualified constant" trm
+
+    _ -> composOp (ren vs) trm
+
+  renid = renameIdentTerm env
+  renCase vs (p,t) = do
+    (p',vs') <- renpatt p
+    t' <- ren (vs' ++ vs) t
+    return (p',t')
+  renpatt = renamePattern env
+
+-- | vars not needed in env, since patterns always overshadow old vars
+renamePattern :: RenameEnv -> Patt -> Err (Patt,[Ident])
+renamePattern env patt = case patt of
+
+  PC c ps -> do
+    c' <- renid $ Vr c
+    case c' of
+      QC p d -> renp $ PP p d ps
+      Q  p d -> renp $ PP p d ps
+      _ -> prtBad "unresolved pattern" c' ---- (PC c ps', concat vs)
+
+  PP p c ps -> do
+
+    (p', c') <- case renid (QC p c) of
+      Ok (QC p' c') -> return (p',c')
+      _ -> return (p,c) --- temporarily, for bw compat
+    psvss <- mapM renp ps
+    let (ps',vs) = unzip psvss
+    return (PP p' c' ps', concat vs)
+
+  PV x -> case renid (Vr x) of
+    Ok (QC m c) -> return (PP m c [],[])
+    _    -> return (patt, [x])
+
+  PR r -> do
+    let (ls,ps) = unzip r
+    psvss <- mapM renp ps
+    let (ps',vs') = unzip psvss
+    return (PR (zip ls ps'), concat vs') 
+
+  PAlt p q -> do
+    (p',vs) <- renp p
+    (q',ws) <- renp q
+    return (PAlt p' q', vs ++ ws)
+
+  PSeq p q -> do
+    (p',vs) <- renp p
+    (q',ws) <- renp q
+    return (PSeq p' q', vs ++ ws)
+
+  PRep p -> do
+    (p',vs) <- renp p
+    return (PRep p', vs)
+
+  PNeg p -> do
+    (p',vs) <- renp p
+    return (PNeg p', vs)
+
+  PAs x p -> do
+    (p',vs) <- renp p
+    return (PAs x p', x:vs)
+
+  _ -> return (patt,[])
+
+ where 
+   renp  = renamePattern env
+   renid = renameIdentTerm env
+
+renameParam :: RenameEnv -> (Ident, Context) -> Err (Ident, Context)
+renameParam env (c,co) = do
+  co' <- renameContext env co
+  return (c,co')
+
+renameContext :: RenameEnv -> Context -> Err Context
+renameContext b = renc [] where
+  renc vs cont = case cont of
+    (x,t) : xts 
+      | isWildIdent x -> do
+          t'   <- ren vs t
+          xts' <- renc vs xts
+          return $ (x,t') : xts'
+      | otherwise -> do
+          t'   <- ren vs t
+          let vs' = x:vs
+          xts' <- renc vs' xts
+          return $ (x,t') : xts'
+    _ -> return cont
+  ren = renameTerm b
+
+-- | vars not needed in env, since patterns always overshadow old vars
+renameEquation :: RenameEnv -> [Ident] -> Equation -> Err Equation
+renameEquation b vs (ps,t) = do
+  (ps',vs') <- liftM unzip $ mapM (renamePattern b) ps
+  t'        <- renameTerm b (concat vs' ++ vs) t
+  return (ps',t')
+