Working with interfaces.

Working with interfaces.
Created new place for grammar parsers.
Created new script jgf2+.

src/GF/Canon/CMacros.hs

@@ -41,7 +41,7 @@ markXML n i b =
     else ("<subtree" +++ p +++ c ++ ">", "</subtree>") 
    where 
      c = "type=" ++ prt (M.valNode n)
-     p = "position=" ++ show i
+     p = "position=" ++ (show $ reverse i)
 
 -- for XML in JGF 1, use
 markXMLjgf :: Marker

src/GF/Compile/Compile.hs

@@ -13,6 +13,7 @@ import MkResource
 
 -- the main compiler passes
 import GetGrammar
+import Extend
 import Rebuild
 import Rename
 import Refresh
@@ -93,7 +94,7 @@ reverseModules (MGrammar ms) = MGrammar $ reverse ms
 keepResModules :: Options -> SourceGrammar -> SourceGrammar
 keepResModules opts gr = 
   if oElem retainOpers opts 
-    then MGrammar $ reverse [(i,mi) | (i,mi) <- modules gr, isResourceModule mi]
+    then MGrammar $ reverse [(i,mi) | (i,mi@(ModMod m)) <- modules gr, isModRes m]
     else emptyMGrammar
 
 
@@ -157,7 +158,8 @@ makeSourceModule opts env@(k,gr,can) mo@(i,mi) = case mi of
  where
    putp = putPointE opts
 
-compileSourceModule :: Options -> CompileEnv -> SourceModule -> IOE (Int,SourceModule)
+compileSourceModule :: Options -> CompileEnv -> 
+                       SourceModule -> IOE (Int,SourceModule)
 compileSourceModule opts env@(k,gr,can) mo@(i,mi) = do
 
   let putp = putPointE opts
@@ -165,16 +167,25 @@ compileSourceModule opts env@(k,gr,can) mo@(i,mi) = do
 
   mo1   <- ioeErr $ rebuildModule mos mo
 
-  mo2:_ <- putp "  renaming " $ ioeErr $ renameModule mos mo1
+  mo1b  <- ioeErr $ extendModule mos mo1
+  ---- prDebug mo1b
 
-  (mo3:_,warnings) <- putp "  type checking" $ ioeErr $ showCheckModule mos mo2
-  putStrE warnings
+  case mo1b of
+    (_,ModMod n) | not (isCompleteModule n) -> return (k,mo1b)
+    _ -> do
+      mo2:_ <- putp "  renaming " $ ioeErr $ renameModule mos mo1b
 
-  (k',mo3r:_) <- ioeErr $ refreshModule (k,mos) mo3
+      (mo3:_,warnings) <- putp "  type checking" $ ioeErr $ showCheckModule mos mo2
+      putStrE warnings
 
-  mo4:_ <- putp "  optimizing " $ ioeErr $ evalModule mos mo3r
+      (k',mo3r:_) <- ioeErr $ refreshModule (k,mos) mo3
+
+      mo4:_ <- putp "  optimizing " $ ioeErr $ evalModule mos mo3r
+
+      return (k',mo4)
+ where
+   prDebug mo = ioeIO $ putStrLn $ prGrammar $ MGrammar [mo] ---- debug
 
-  return (k',mo4)
 
 generateModuleCode :: Options -> InitPath -> SourceModule -> IOE GFC.CanonModule
 generateModuleCode opts path minfo@(name,info) = do
@@ -186,7 +197,7 @@ generateModuleCode opts path minfo@(name,info) = do
 
   -- for resource, also emit gfr
   case info of
-    ModMod m | isResourceModule info && isCompilable info && emit && nomulti -> do
+    ModMod m | isModRes m && isCompilable info && emit && nomulti -> do
       let (file,out) = (gfrFile pname, prGrammar (MGrammar [minfo]))
       ioeIO $ writeFile file out >> putStr ("  wrote file" +++ file)
     _ -> return ()

src/GF/Compile/Extend.hs

@@ -10,27 +10,56 @@ import Operations
 
 import Monad
 
--- AR 14/5/2003
+-- AR 14/5/2003 -- 11/11
 
--- The top-level function $extendModInfo$
+-- The top-level function $extendModule$
 -- extends a module symbol table by indirections to the module it extends
 
---- this is not in use 5/11/2003
-extendModInfo :: Ident -> SourceModInfo -> SourceModInfo -> Err SourceModInfo
-extendModInfo name old new = case (old,new) of
-  (ModMod m0, ModMod (Module mt st fs _ ops js)) -> do
-    testErr (mtype m0 == mt) ("illegal extension type at module" +++ show name)
-    js' <- extendMod name (jments m0) js
-    return $ ModMod (Module mt st fs Nothing ops js)
+extendModule :: [SourceModule] -> SourceModule -> Err SourceModule
+extendModule ms (name,mod) = case mod of
+  ModMod (Module mt st fs me ops js) -> do
 
--- this is what happens when extending a module: new information is inserted,
--- and the process is interrupted if unification fails
+{- --- building the {s : Str} lincat from js0
+    js  <- case mt of
+      MTConcrete a -> do
+        ModMod ma <- lookupModule (MGrammar ms) a
+        let cats = [c | (c,AbsCat _ _) <- tree2list $ jments ma]
+            jscs = [(c,CncCat (yes defLinType) nope nope) | c <- cats]
+        return $ updatesTreeNondestr jscs js0
+      _ -> return js0
+-}
 
-extendMod :: Ident -> BinTree (Ident,Info) -> BinTree (Ident,Info) -> 
+    case me of
+      -- if the module is an extension of another one...
+      Just n -> do
+        (m0,isCompl) <- do
+          m <- lookupModMod  (MGrammar ms) n
+
+          -- test that the module types match, and find out if the old is complete
+          testErr (sameMType (mtype m) mt) 
+                    ("illegal extension type to module" +++ prt name)
+          return (m,isCompleteModule m)
+
+        -- build extension in a way depending on whether the old module is complete
+        js1 <- extendMod isCompl n (jments m0) js
+
+        -- if incomplete, throw away extension information
+        let me' = if isCompl then me else Nothing 
+        return $ (name,ModMod (Module mt st fs me' ops js1))
+
+      -- if the module is not an extension, just return it
+      _ -> return (name,mod)
+
+-- 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 -> BinTree (Ident,Info) -> BinTree (Ident,Info) -> 
              Err (BinTree (Ident,Info))
-extendMod name old new = foldM try new $ tree2list old where
+extendMod isCompl name old new = foldM try new $ tree2list old where
   try t i@(c,_) = errIn ("constant" +++ prt c) $
-                  tryInsert (extendAnyInfo name) (indirInfo name) t i
+                  tryInsert (extendAnyInfo isCompl name) indirIf t i
+  indirIf = if isCompl then indirInfo name else id
 
 indirInfo :: Ident -> Info -> Info
 indirInfo n info = AnyInd b n' where 
@@ -41,46 +70,37 @@ indirInfo n info = AnyInd b n' where
     AnyInd b k -> (b,k)
     _ -> (False,n) ---- canonical in Abs
 
-{- ----
-case info of
-  AbsFun pty ptr -> AbsFun (perhIndir n pty) (perhIndir n ptr)
-  ---- find a suitable indirection for cat info!
-
-  ResOper pty ptr -> ResOper (perhIndir n pty) (perhIndir n ptr)
-  ResParam pp -> ResParam (perhIndir n pp) 
-  _ -> info
-
-  CncCat pty ptr ppr -> CncCat (perhIndir n pty) (perhIndir n ptr) (perhIndir n ppr)
-  CncFun m ptr   ppr -> CncFun m (perhIndir n ptr)                 (perhIndir n ppr)
--}
-
 perhIndir :: Ident -> Perh a -> Perh a
 perhIndir n p = case p of
   Yes _ -> May n
   _ -> p
 
-extendAnyInfo :: Ident -> Info -> Info -> Err Info
-extendAnyInfo n i j = errIn ("building extension for" +++ prt n) $ case (i,j) of
+extendAnyInfo :: Bool -> Ident -> Info -> Info -> Err Info
+extendAnyInfo isc 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
+    liftM2 AbsCat (updn mc1 mc2) (updn mf1 mf2) --- add cstrs
   (AbsFun mt1 md1, AbsFun mt2 md2) -> 
-    liftM2 AbsFun (updatePerhaps n mt1 mt2) (updatePerhaps n md1 md2) --- add defs
-
-  (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) -> extendResOper n mt1 m1 mt2 m2 
-
+    liftM2 AbsFun (updn mt1 mt2) (updn md1 md2) --- add defs
+  (ResParam mt1, ResParam mt2) -> 
+    liftM ResParam $ updn mt1 mt2
+  (ResValue mt1, ResValue mt2) -> 
+    liftM ResValue $ updn mt1 mt2
+  (ResOper mt1 m1, ResOper mt2 m2) ->           ---- extendResOper n mt1 m1 mt2 m2 
+    liftM2 ResOper (updn mt1 mt2) (updn m1 m2)
   (CncCat mc1 mf1 mp1, CncCat mc2 mf2 mp2) -> 
-    liftM3 CncCat (updatePerhaps n mc1 mc2) 
-                  (updatePerhaps n mf1 mf2) (updatePerhaps n mp1 mp2)
+    liftM3 CncCat (updn mc1 mc2) (updn mf1 mf2) (updn mp1 mp2)
   (CncFun m mt1 md1, CncFun _ mt2 md2) -> 
-    liftM2 (CncFun m) (updatePerhaps n mt1 mt2) (updatePerhaps n md1 md2)
+    liftM2 (CncFun m) (updn mt1 mt2) (updn md1 md2)
 
-  (AnyInd _ _, ResOper _ _) -> return j ----
+----  (AnyInd _ _, ResOper _ _) -> return j ----
 
   _ -> Bad $ "cannot unify information in" ++++ show i ++++ "and" ++++ show j
+ where
+   updn = if isc then (updatePerhaps n) else (updatePerhapsHard n)
 
 
+
+{- ---- no more needed: this is done in Rebuild
 -- opers declared in an interface and defined in an instance are a special case
 
 extendResOper n mt1 m1 mt2 m2 = case (m1,m2) of
@@ -93,3 +113,4 @@ extendResOper n mt1 m1 mt2 m2 = case (m1,m2) of
      Q _ c  -> Vr c
      QC _ c -> Vr c
      _ -> composSafeOp strp t
+-}

src/GF/Compile/GrammarToCanon.hs

@@ -38,7 +38,8 @@ redModInfo (c,info) = do
   c'    <- redIdent c
   info' <- case info of
     ModMod m -> do
-      (e,os) <- redExtOpen m
+      let isIncompl = mstatus m == MSIncomplete
+      (e,os) <- if isIncompl then return (Nothing,[]) else redExtOpen m ----
       flags <- mapM redFlag $ flags m 
       (a,mt) <- case mtype m of
          MTConcrete a -> do
@@ -51,7 +52,7 @@ redModInfo (c,info) = do
          MTTransfer x y -> return (c',MTTransfer (om x) (om y)) --- c' not needed
 
       ---- this generates empty GFC. Better: none 
-      let js = if mstatus m == MSIncomplete then NT else jments m
+      let js = if isIncompl then NT else jments m
 
       defss <- mapM (redInfo a) $ tree2list $ js
       defs  <- return $ sorted2tree $ concat defss  -- sorted, but reduced
@@ -62,7 +63,9 @@ redModInfo (c,info) = do
      e' <- case extends m of
        Just e -> liftM Just $ redIdent e
        _ -> return Nothing
-     os' <- mapM (\ (OQualif q _ i) -> liftM (OSimple q) (redIdent i)) $ opens m
+     os' <- mapM (\o -> case o of 
+              OQualif q _ i -> liftM (OSimple q) (redIdent i)
+              _ -> prtBad "cannot translate unqualified open in" c) $ opens m
      return (e',os')
    om = oSimple . openedModule --- normalizing away qualif
 

src/GF/Compile/Rebuild.hs

@@ -19,43 +19,38 @@ rebuildModule ms mo@(i,mi) = do
   let gr = MGrammar ms
   deps <- moduleDeps ms
   is   <- openInterfaces deps i
-  mi' <- case mi of
+  mi'  <- case mi of
 
-    -- add the interface type signatures into an instance module
+    -- add the information given in interface into an instance module
     ModMod m -> do
       testErr (null is || mstatus m == MSIncomplete) 
-              ("module" +++ prt i +++ "must be declared incomplete") 
-      mi' <- case mtype m of
+              ("module" +++ prt i +++ 
+               "has open interfaces and must therefore be declared incomplete") 
+      case mtype m of
         MTInstance i0 -> do
-          m0 <- lookupModule gr i0
-          m' <- case m0 of
-            ModMod m1 | isResourceModule m0 -> do ---- mtype m1 == MTInterface -> do
-----              checkCompleteInstance m1 m -- do this later, in CheckGrammar
-              js' <- extendMod i (jments m1) (jments m)
-              return $ replaceJudgements m js'
-            _ -> prtBad "interface expected instead of" i0
-          return mi -----
+          m1 <- lookupModMod gr i0
+          testErr (isModRes m1) ("interface expected instead of" +++ prt i0)
+          m' <- do
+            js' <- extendMod False i0 (jments m1) (jments m)
+            return $ replaceJudgements m js'
+          return $ ModMod m'
         _ -> return mi
-      return mi'
 
     -- add the instance opens to an incomplete module "with" instances
     ModWith mt stat ext ops -> do
-      let insts = [(inf,inst) |OQualif _ inf inst <- ops]
+      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 stat0 fs me ops0 js <- do
-        mi <- lookupModule gr ext
-        case mi of
-          ModMod m -> return m --- check compatibility of module type
-          _ -> prtBad "expected regular module in 'with' clause, not" ext
+      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] ----
       --- check if me is incomplete
-      return $ ModMod $ Module mt0 stat' fs me ops1 
-                          (mapTree (qualifInstanceInfo insts) js)
+      return $ ModMod $ Module mt0 stat' fs me ops1 js 
+                          ---- (mapTree (qualifInstanceInfo insts) js) -- not needed
 
     _ -> return mi
   return (i,mi')
@@ -72,6 +67,7 @@ checkCompleteInstance abs cnc = ifNull (return ()) (Bad . unlines) $
                       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
 
@@ -95,5 +91,5 @@ qualifInstanceInfo insts (c,i) = (c,qualInfo i) where
   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
+-}

src/GF/Compile/Rename.hs

@@ -33,39 +33,13 @@ renameSourceTerm g m t = do
 
 renameModule :: [SourceModule] -> SourceModule -> Err [SourceModule]
 renameModule ms (name,mod) = errIn ("renaming module" +++ prt name) $ case mod of
-  ModMod (Module mt st fs me ops js) -> do
-    (_,mod1@(ModMod m)) <- extendModule ms (name,mod)
+  ModMod m@(Module mt st fs me ops js) -> do
     let js1 = jments m
-    status <- buildStatus (MGrammar ms) name mod1
+    status <- buildStatus (MGrammar ms) name mod
     js2    <- mapMTree (renameInfo status) js1
     let mod2 = ModMod $ Module mt st fs me (map forceQualif ops) js2
     return $ (name,mod2) : ms
 
-extendModule :: [SourceModule] -> SourceModule -> Err SourceModule
-extendModule ms (name,mod) = case mod of
-  ModMod (Module mt st fs me ops js0) -> do
-    js  <- case mt of
-{- --- building the {s : Str} lincat
-      MTConcrete a -> do
-        ModMod ma <- lookupModule (MGrammar ms) a
-        let cats = [c | (c,AbsCat _ _) <- tree2list $ jments ma]
-            jscs = [(c,CncCat (yes defLinType) nope nope) | c <- cats]
-        return $ updatesTreeNondestr jscs js0
--}
-      _ -> return js0
-    js1 <- case me of
-      Just n -> do
-        m0 <- case lookup n ms of
-          Just (ModMod m) -> do
-            testErr (sameMType (mtype m) mt) 
-                    ("illegal extension type to module" +++ prt name)
-            return m
-          _ -> Bad $ "cannot find extended module" +++ prt n
-        extendMod n (jments m0) js
-      _ -> return js
-    return $ (name,ModMod (Module mt st fs me ops js1))
-
-
 type Status = (StatusTree, [(OpenSpec Ident, StatusTree)])
 
 type StatusTree = BinTree (Ident,StatusInfo)

src/GF/Infra/Modules.hs

@@ -63,6 +63,10 @@ updateModule (Module  mt ms fs me ops js) i t =
 replaceJudgements :: Module i f t -> BinTree (i,t) -> Module i f t
 replaceJudgements (Module mt ms fs me ops _) js = Module mt ms fs me ops js
 
+addOpenQualif :: i -> i -> Module i f t -> Module i f t
+addOpenQualif i j (Module mt ms fs me ops js) = 
+  Module mt ms fs me (oQualif i j : ops) js
+
 allFlags :: MGrammar i f a -> [f]
 allFlags gr = concat $ map flags $ reverse [m | (_, ModMod m) <- modules gr]
 
@@ -191,13 +195,6 @@ data IdentM i = IdentM {
 typeOfModule mi = case mi of
   ModMod m -> mtype m
 
-isResourceModule mi = case typeOfModule mi of
-  MTResource -> True
-  MTReuse _ -> True
-  MTInterface -> True ---
-  MTInstance _ -> True
-  _ -> False
-
 abstractOfConcrete :: (Show i, Eq i) => MGrammar i f a -> i -> Err i
 abstractOfConcrete gr c = do
   m <- lookupModule gr c
@@ -232,6 +229,13 @@ lookupModuleType gr m = do
   mi <- lookupModule gr m
   return $ typeOfModule mi
 
+lookupModMod :: (Show i,Eq i) => MGrammar i f a -> i -> Err (Module i f a)
+lookupModMod gr i = do
+  mo <- lookupModule gr i
+  case mo of 
+    ModMod m -> return m
+    _ -> Bad $ "expected proper module, not" +++ show i
+
 lookupInfo :: (Show i, Ord i) => Module i f a -> i -> Err a
 lookupInfo mo i = lookupTree show i (jments mo)
 
@@ -241,6 +245,8 @@ isModAbs m = case mtype m of
 
 isModRes m = case mtype m of
   MTResource -> True
+  MTReuse _ -> True
+  MTInterface -> True ---
   MTInstance _ -> True
   _ -> False
 
@@ -268,3 +274,7 @@ isCompilableModule m = case m of
     MTInterface -> False
     _ -> mstatus m == MSComplete
   _ -> False ---
+
+-- interface and "incomplete M" are not complete
+isCompleteModule :: (Eq i) =>  Module i f a -> Bool
+isCompleteModule m = mstatus m == MSComplete && mtype m /= MTInterface

src/GF/Shell/Commands.hs

@@ -409,8 +409,9 @@ displaySStateIn env state = (tree',msg,menu) where
   linAll = map lin grs
   separ  = singleton . map unlines . intersperse [replicate 72 '*']
 
-displaySStateJavaX :: CEnv -> SState -> String
-displaySStateJavaX env state = unlines $ tagXML "gfedit" $ concat [
+---- the Boolean is a temporary hack to have two parallel GUIs
+displaySStateJavaX :: Bool -> CEnv -> SState -> String
+displaySStateJavaX isNew env state = unlines $ tagXML "gfedit" $ concat [
   tagXML "linearizations" (concat 
     [tagAttrXML "lin" ("lang", prLanguage lang) ss | (lang,ss) <- lins]),
   tagXML "tree"           tree,
@@ -431,7 +432,7 @@ displaySStateJavaX env state = unlines $ tagXML "gfedit" $ concat [
   zipper = stateSState state
   linAll = map lin lgrs
   gr     = firstStateGrammar env
-  mark   = markOptXML -- markOptJava   
+  mark   = if isNew then markOptXML else markOptJava   
 
 langAbstract = language "Abstract"
 langXML      = language "XML"

src/GF/Shell/JGF.hs

@@ -16,34 +16,34 @@ import UTF8
 
 -- GF editing session controlled by e.g. a Java program. AR 16/11/2001
 
-sessionLineJ :: ShellState -> IO ()
-sessionLineJ env = do
+---- the Boolean is a temporary hack to have two parallel GUIs
+sessionLineJ :: Bool -> ShellState -> IO ()
+sessionLineJ isNew env = do
   putStrLnFlush $ initEditMsgJavaX env
   let env' = addGlobalOptions (options [sizeDisplay "short"]) env
-  editLoopJ env' (initSState)
-
-editLoopJ :: CEnv -> SState -> IO ()
-editLoopJ = editLoopJnewX
+  editLoopJnewX isNew env' (initSState)
 
 -- this is the real version, with XML
 
-editLoopJnewX :: CEnv -> SState -> IO ()
-editLoopJnewX env state = do
+---- the Boolean is a temporary hack to have two parallel GUIs
+editLoopJnewX :: Bool -> CEnv -> SState -> IO ()
+editLoopJnewX isNew env state = do
   c <- getCommandUTF
   case c of
     CQuit -> return ()
 
     c -> do
       (env',state') <- execCommand env c state
+      let inits = initAndEditMsgJavaX isNew env' state'
       let package = case c of
-            CCEnvImport _         -> initAndEditMsgJavaX env' state'
-            CCEnvEmptyAndImport _ -> initAndEditMsgJavaX env' state'
-            CCEnvOpenTerm _       -> initAndEditMsgJavaX env' state'
-            CCEnvOpenString _     -> initAndEditMsgJavaX env' state'
+            CCEnvImport _         -> inits
+            CCEnvEmptyAndImport _ -> inits
+            CCEnvOpenTerm _       -> inits
+            CCEnvOpenString _     -> inits
             CCEnvEmpty            -> initEditMsgJavaX env'
-            _ -> displaySStateJavaX env' state'
+            _ -> displaySStateJavaX isNew env' state'
       putStrLnFlush package
-      editLoopJnewX env' state'
+      editLoopJnewX isNew env' state'
 
 welcome = 
   "An experimental GF Editor for Java." ++ 
@@ -56,5 +56,5 @@ initEditMsgJavaX env = encodeUTF8 $ unlines $ tagXML "gfinit" $
   concat [tagAttrXML "language" ("file",file) [prLanguage lang] |
            (file,lang) <- zip (allGrammarFileNames env) (allLanguages env)]
 
-initAndEditMsgJavaX env state = 
-  initEditMsgJavaX env ++++ displaySStateJavaX env state
+initAndEditMsgJavaX isNew env state = 
+  initEditMsgJavaX env ++++ displaySStateJavaX isNew env state