working with interfaces

src/GF/Compile/Compile.hs

@@ -186,18 +186,19 @@ generateModuleCode opts path minfo@(name,info) = do
 
   -- for resource, also emit gfr
   case info of
-    ModMod m | isResourceModule info && isCompilableModule info && emit && nomulti -> do
+    ModMod m | isResourceModule info && isCompilable info && emit && nomulti -> do
       let (file,out) = (gfrFile pname, prGrammar (MGrammar [minfo]))
       ioeIO $ writeFile file out >> putStr ("  wrote file" +++ file)
     _ -> return ()
   (file,out) <- do
       code <- return $ MkGFC.prCanonModInfo minfo'
       return (gfcFile pname, code)
-  if isCompilableModule info && emit && nomulti 
+  if isCompilable info && emit && nomulti 
      then ioeIO $ writeFile file out >> putStr ("  wrote file" +++ file)
      else ioeIO $ putStrFlush "no need to save for this module "
   return minfo'
  where 
+   isCompilable _ = True ---- isCompilableModule ---- emit code for interfaces
    nomulti = not $ oElem makeMulti opts
    emit  = oElem emitCode opts
    optim = oElem optimizeCanon opts

src/GF/Compile/Extend.hs

@@ -15,6 +15,7 @@ import Monad
 -- The top-level function $extendModInfo$
 -- 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

src/GF/Compile/ModDeps.hs

@@ -82,7 +82,9 @@ moduleDeps ms = mapM deps ms where
     (MTConcrete _, MTConcrete _) -> True
     (MTInstance _, MTInstance _) -> True
     (MTReuse _, MTReuse _) -> True
-    ---- some more
+    (MTInstance _, MTResource) -> True
+    (MTResource, MTInstance _) -> True
+    ---- some more?
     _ -> mt0 == mt
   -- in the same way; this defines what can be opened
   compatOType mt0 mt = case mt0 of

src/GF/Compile/Rebuild.hs

@@ -11,7 +11,8 @@ import Ident
 import Modules
 import Operations
 
--- rebuilding instance + interface, and "with" modules, prior to renaming. AR 24/10/2003
+-- rebuilding instance + interface, and "with" modules, prior to renaming. 
+-- AR 24/10/2003
 
 rebuildModule :: [SourceModule] -> SourceModule -> Err SourceModule
 rebuildModule ms mo@(i,mi) = do
@@ -28,7 +29,7 @@ rebuildModule ms mo@(i,mi) = do
         MTInstance i0 -> do
           m0 <- lookupModule gr i0
           m' <- case m0 of
-            ModMod m1 | mtype m1 == MTInterface -> do
+            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'
@@ -41,7 +42,8 @@ rebuildModule ms mo@(i,mi) = do
     ModWith mt stat ext 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]
+      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
@@ -52,7 +54,8 @@ rebuildModule ms mo@(i,mi) = do
       let ops1 = ops ++ [o | o <- ops0, notElem (openedModule o) infs]
                      ++ [oQualif i 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 
+                          (mapTree (qualifInstanceInfo insts) js)
 
     _ -> return mi
   return (i,mi')
@@ -75,8 +78,8 @@ 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 mp (qualP pt) (qualP pp) ---- mp
+    CncFun  mp pt pp -> CncFun (qualLin mp) (qualP pt) (qualP pp) ---- mp
-   -----  ResParam (Yes ps) -> ResParam (yes (map qualParam ps)) 
+    ResParam (Yes ps) -> ResParam (yes (map qualParam ps)) 
     ResValue pty ->  ResValue (qualP pty)
     _ -> i
   qualP pt = case pt of
@@ -88,7 +91,9 @@ qualifInstanceInfo insts (c,i) = (c,qualInfo i) where
      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
-
-

src/GF/Compile/Rename.hs

@@ -121,12 +121,12 @@ buildStatus :: SourceGrammar -> Ident -> SourceModInfo -> Err Status
 buildStatus gr c mo = let mo' = self2status c mo in case mo of
   ModMod m -> do
     let gr1 = MGrammar $ (c,mo) : modules gr 
-        ops = [OSimple OQNormal e | e <- allExtends gr1 c] ++ allOpens m
+        ops = [OSimple OQNormal e | e <- allExtendsPlus gr1 c] ++ allOpens m
     mods <- mapM (lookupModule gr1 . openedModule) ops
     let sts = map modInfo2status $ zip ops mods    
     return $ if isModCnc m
-      then (NT, sts) -- the module itself does not define any names
+      then (NT, reverse sts) -- the module itself does not define any names
-      else (mo',sts) -- so the empty ident is not needed
+      else (mo',reverse sts) -- so the empty ident is not needed
 
 modInfo2status :: (OpenSpec Ident,SourceModInfo) -> (OpenSpec Ident, StatusTree)
 modInfo2status (o,i) = (o,case i of

src/GF/Grammar/Compute.hs

@@ -129,10 +129,12 @@ computeTerm gr = comp where
          (K a, Alts (d,vs)) -> do
             let glx = Glue x
             comp g $ Alts (glx d, [(glx v,c) | (v,c) <- vs])
-         (Alts _, K a) -> do
+         (Alts _, K a) -> checks [do
-            x' <- strsFromTerm x
+            x' <- strsFromTerm x -- this may fail when compiling opers
             return $ variants [
               foldr1 C (map K (str2strings (glueStr v (str a)))) | v <- x']
+           ,return $ Glue x y
+           ]
          _ -> do
            mapM_ checkNoArgVars [x,y]
            r <- composOp (comp g) t

src/GF/Grammar/Lookup.hs

@@ -10,19 +10,23 @@ import Monad
 -- lookup in resource and concrete in compiling; for abstract, use Look
 
 lookupResDef :: SourceGrammar -> Ident -> Ident -> Err Term
-lookupResDef gr m c = do
+lookupResDef gr = look True where 
-  mi   <- lookupModule gr m
+  look isTop m c = do
-  case mi of
+    mi   <- lookupModule gr m
-    ModMod mo -> do
+    case mi of
-      info <- lookupInfo mo c
+      ModMod mo -> do
-      case info of
+        info <- lookupInfo mo c
-        ResOper _ (Yes t) -> return $ qualifAnnot m t 
+        case info of
-        ResOper _ Nope    -> return $ Q m c
+          ResOper _ (Yes t) -> return $ qualifAnnot m t 
-        AnyInd _ n        -> lookupResDef gr n c
+          ResOper _ Nope    -> return (Q m c) ---- if isTop then lookExt m c 
-        ResParam _        -> return $ QC m c
+                                 ---- else prtBad "cannot find in exts" c 
-        ResValue _        -> return $ QC m c
+          AnyInd _ n        -> look False n c
-        _   -> Bad $ prt c +++ "is not defined in resource" +++ prt m
+          ResParam _        -> return $ QC m c
-    _ -> Bad $ prt m +++ "is not a resource"
+          ResValue _        -> return $ QC m c
+          _   -> Bad $ prt c +++ "is not defined in resource" +++ prt m
+      _ -> Bad $ prt m +++ "is not a resource"
+  lookExt m c =
+    checks ([look False n c | n <- allExtensions gr m] ++ [return (Q m c)])
 
 lookupResType :: SourceGrammar -> Ident -> Ident -> Err Type
 lookupResType gr m c = do
@@ -40,16 +44,21 @@ lookupResType gr m c = do
     _ -> Bad $ prt m +++ "is not a resource"
 
 lookupParams :: SourceGrammar -> Ident -> Ident -> Err [Param]
-lookupParams gr m c = do
+lookupParams gr = look True where 
-  mi   <- lookupModule gr m
+  look isTop m c = do
-  case mi of
+    mi   <- lookupModule gr m
-    ModMod mo -> do
+    case mi of
-      info <- lookupInfo mo c
+      ModMod mo -> do
-      case info of
+        info <- lookupInfo mo c
-        ResParam (Yes ps) -> return ps
+        case info of
-        AnyInd _ n        -> lookupParams gr n c
+          ResParam (Yes ps) -> return ps
-        _   -> Bad $ prt c +++ "has no parameters defined in resource" +++ prt m
+          ---- ResParam   Nope   -> if isTop then lookExt m c 
-    _ -> Bad $ prt m +++ "is not a resource"
+          ----                       else prtBad "cannot find params in exts" c 
+          AnyInd _ n        -> look False n c
+          _   -> Bad $ prt c +++ "has no parameters defined in resource" +++ prt m
+      _ -> Bad $ prt m +++ "is not a resource"
+  lookExt m c =
+    checks [look False n c | n <- allExtensions gr m]
 
 lookupParamValues :: SourceGrammar -> Ident -> Ident -> Err [Term]
 lookupParamValues gr m c = do

src/GF/Infra/Modules.hs

@@ -133,6 +133,16 @@ allExtendsPlus gr i = case lookupModule gr i of
  where
    exts m = [j | Just j <- [extends m]] ++ [j | MTInstance j <- [mtype m]]
 
+-- conversely: all modules that extend a given module, incl. instances of interface
+allExtensions :: (Show i,Ord i) => MGrammar i f a -> i -> [i]
+allExtensions gr i = case lookupModule gr i of
+  Ok (ModMod m) -> let es = exts i in es ++ concatMap (allExtensions gr) es
+  _ -> []
+ where
+   exts i = [j | (j,m) <- mods, elem (Just i) [extends m] 
+                             || elem (MTInstance i) [mtype m]]
+   mods = [(j,m) | (j,ModMod m) <- modules gr]
+
 -- initial search path: the nonqualified dependencies
 searchPathModule :: Ord i => Module i f a -> [i]
 searchPathModule m = [i | OSimple _ i <- depPathModule m]
@@ -160,7 +170,7 @@ typeOfModule mi = case mi of
 isResourceModule mi = case typeOfModule mi of
   MTResource -> True
   MTReuse _ -> True
----  MTInterface -> True
+  MTInterface -> True ---
   MTInstance _ -> True
   _ -> False
 
@@ -207,6 +217,7 @@ isModAbs m = case mtype m of
 
 isModRes m = case mtype m of
   MTResource -> True
+  MTInstance _ -> True
   _ -> False
 
 isModCnc m = case mtype m of
@@ -219,6 +230,12 @@ isModTrans m = case mtype m of
 
 sameMType m n = case (m,n) of
   (MTConcrete _, MTConcrete _) -> True
+  (MTInstance _, MTInstance _) -> True
+  (MTInstance _, MTResource) -> True
+  (MTInstance _, MTInterface) -> True
+  (MTResource, MTInstance _) -> True
+  (MTResource, MTInterface) -> True
+  (MTInterface,MTResource) -> True
   _ -> m == n
 
 -- don't generate code for interfaces and for incomplete modules
@@ -227,4 +244,3 @@ isCompilableModule m = case m of
     MTInterface -> False
     _ -> mstatus m == MSComplete
   _ -> False ---
-

src/Makefile

@@ -1,5 +1,5 @@
 GHMAKE=ghc 
-GHCFLAGS=-package lang -package util
+GHCFLAGS=-package lang -package util -fglasgow-exts
 GHCFUDFLAG=-package Fudgets
 GHCINCLUDE=-iapi -icompile -igrammar -iinfra -ishell -isource -icanonical -iuseGrammar -icf -ifor-ghc -iparsing
 GHCINCLUDENOFUD=-iapi -icompile -igrammar -iinfra -ishell -isource -icanonical -iuseGrammar -icf -ifor-ghc-nofud -iparsing

src/Today.hs

@@ -1 +1 @@
-module Today where today = "Tue Nov  4 13:55:38 CET 2003"
+module Today where today = "Wed Nov  5 13:15:35 CET 2003"