working on resource doc and exx, fixing bugs

src/GF/API/IOGrammar.hs

@@ -53,11 +53,11 @@ shellStateFromFiles :: Options -> ShellState -> FilePath -> IOE ShellState
 shellStateFromFiles opts st file = case fileSuffix file of
   "gfcm" -> do
      cenv <- compileOne opts (compileEnvShSt st []) file
-     ioeErr $ updateShellState opts st cenv
+     ioeErr $ updateShellState opts Nothing st cenv
   s | elem s ["cf","ebnf"] -> do
      let osb = addOptions (options [beVerbose]) opts
      grts <- compileModule osb st file
-     ioeErr $ updateShellState opts st grts
+     ioeErr $ updateShellState opts Nothing st grts
   _ -> do
      b <- ioeIO $ isOldFile file
      let opts' = if b then (addOption showOld opts) else opts
@@ -66,7 +66,8 @@ shellStateFromFiles opts st file = case fileSuffix file of
                  then addOptions (options [beVerbose]) opts' -- for old no emit
                  else addOptions (options [beVerbose, emitCode]) opts'
      grts <- compileModule osb st file
-     ioeErr $ updateShellState opts' st grts
+     let top = identC $ justModuleName file
+     ioeErr $ updateShellState opts' (Just top) st grts
      --- liftM (changeModTimes rts) $ grammar2shellState opts gr
 
 getShellStateFromFiles :: Options -> FilePath -> IO ShellState

src/GF/Compile/ModDeps.hs

@@ -118,12 +118,14 @@ openInterfaces ds m = do
 
 -- | this function finds out what modules are really needed in the canoncal gr.
 -- its argument is typically a concrete module name
-requiredCanModules :: (Eq i, Show i) => MGrammar i f a -> i -> [i]
-requiredCanModules gr = nub . iterFix (concatMap more) . singleton where
+requiredCanModules :: (Ord i, Show i) => MGrammar i f a -> i -> [i]
+requiredCanModules gr = nub . iterFix (concatMap more) . allExtends gr where
   more i = errVal [] $ do
     m <- lookupModMod gr i
-    return $ extends m ++ map openedModule (opens m)
-
+    return $ extends m ++ [o | o <- map openedModule (opens m), notReuse o]
+  notReuse i = errVal True $ do
+    m <- lookupModMod gr i
+    return $ isModRes m -- to exclude reused Cnc and Abs from required
 
 
 {-

src/GF/Compile/Optimize.hs

@@ -112,8 +112,8 @@ evalCncInfo gr cnc abs (c,info) = case info of
 
     return (c, CncCat ptyp pde' ppr')
 
-  CncFun (mt@(Just (_,ty))) pde ppr -> eIn ("linearization in type" +++  
-                                             show ty +++ "of") $ do
+  CncFun (mt@(Just (_,ty@(cont,val)))) pde ppr -> 
+       eIn ("linearization in type" +++ prt (mkProd (cont,val,[])) ++++ "of function") $ do
     pde' <- case pde of
       Yes de -> do
         liftM yes $ pEval ty de

src/GF/Compile/ShellState.hs

@@ -123,16 +123,18 @@ cncModuleIdST = stateGrammarST
 -- | form a shell state from a canonical grammar
 grammar2shellState :: Options -> (CanonGrammar, G.SourceGrammar) -> Err ShellState 
 grammar2shellState opts (gr,sgr) = 
-  updateShellState opts emptyShellState ((0,sgr,gr),[]) --- is 0 safe?
+  updateShellState opts Nothing emptyShellState ((0,sgr,gr),[]) --- is 0 safe?
 
 -- | update a shell state from a canonical grammar
-updateShellState :: Options -> ShellState -> 
+updateShellState :: Options -> Maybe Ident -> ShellState -> 
                     ((Int,G.SourceGrammar,CanonGrammar),[(FilePath,ModTime)]) ->
                ---- (CanonGrammar,(G.SourceGrammar,[(FilePath,ModTime)])) -> 
                     Err ShellState 
-updateShellState opts sh ((_,sgr,gr),rts) = do 
+updateShellState opts mcnc sh ((_,sgr,gr),rts) = do 
   let cgr0 = M.updateMGrammar (canModules sh) gr
-      a' = M.greatestAbstract cgr0
+  a' <- return $ case mcnc of
+    Just cnc -> err (const Nothing) Just $ M.abstractOfConcrete cgr0 cnc
+    _ -> M.greatestAbstract cgr0
   abstr0 <- case abstract sh of
     Just a -> do
       -- test that abstract is compatible --- unsafe exception for old? 

src/GF/Grammar/Compute.hs

@@ -24,6 +24,7 @@ import Macros
 import Lookup
 import Refresh
 import PatternMatch
+import Lockfield (isLockLabel) ----
 
 import AppPredefined
 
@@ -82,6 +83,12 @@ computeTerm gr = comp where
          (S (T i cs) e,_) -> prawitz g i (flip App a') cs e
 
 	 _ -> returnC $ appPredefined $ App f' a'
+
+     P t l | isLockLabel l -> return $ R [] 
+     ---- a workaround 18/2/2005: take this away and find the reason
+     ---- why earlier compilation destroys the lock field
+
+
      P t l  -> do
        t' <- comp g t
        case t' of

src/GF/Grammar/Lockfield.hs

@@ -12,7 +12,7 @@
 -- Creating and using lock fields in reused resource grammars.
 -----------------------------------------------------------------------------
 
-module Lockfield (lockRecType, unlockRecord, lockLabel) where
+module Lockfield (lockRecType, unlockRecord, lockLabel, isLockLabel) where
 
 import Grammar
 import Ident
@@ -40,3 +40,7 @@ unlockRecord c ft = do
 lockLabel :: Ident -> Label
 lockLabel c = LIdent $ "lock_" ++ prt c ----
 
+isLockLabel :: Label -> Bool
+isLockLabel l = case l of
+  LIdent c -> take 5 c == "lock_"
+  _ -> False

src/GF/Grammar/Lookup.hs

@@ -60,8 +60,17 @@ lookupResType gr m c = do
 
         -- used in reused concrete
         CncCat _ _ _ -> return typeType
-        CncFun (Just (_,(cont,val))) _ _ -> return $ mkProd (cont, val, [])
-
+        CncFun (Just (cat,(cont,val))) _ _ -> do
+          val' <- lockRecType cat val 
+          return $ mkProd (cont, val', [])
+        CncFun _ _ _ -> do
+          a  <- abstractOfConcrete gr m
+          mu <- lookupModMod gr a
+          info <- lookupInfo mu c
+          case info of
+            AbsFun (Yes ty) _ -> return $ redirectTerm m ty 
+            AbsCat _ _ -> return typeType
+            _ -> prtBad "cannot find type of reused function" c
         AnyInd _ n        -> lookupResType gr n c
         ResParam _        -> return $ typePType
         ResValue (Yes t)  -> return $ qualifAnnotPar m t

src/GF/Grammar/Macros.hs

@@ -486,6 +486,12 @@ patt2term pt = case pt of
   PInt i    -> EInt i
   PString s -> K s 
 
+redirectTerm :: Ident -> Term -> Term
+redirectTerm n t = case t of
+  QC _ f -> QC n f
+  Q _ f  -> Q  n f
+  _ -> composSafeOp (redirectTerm n) t
+
 -- to gather s-fields; assumes term in normal form, preserves label
 allLinFields :: Term -> Err [[(Label,Term)]]
 allLinFields trm = case unComputed trm of