From a75c3b1907a814e63cdff9cc045bdcaabe055b8f Mon Sep 17 00:00:00 2001
From: aarne <aarne@cs.chalmers.se>
Date: Tue, 20 Jun 2006 15:05:22 +0000
Subject: resource.txt updates ; lock field and lookup book fixes

---
 src/GF/Canon/CanonToGrammar.hs | 4 +++-
 src/GF/Compile/MkConcrete.hs   | 2 +-
 src/GF/Compile/Rename.hs       | 4 +++-
 src/GF/Grammar/Lookup.hs       | 4 +++-
 src/GF/UseGrammar/Parsing.hs   | 9 ++++++---
 5 files changed, 16 insertions(+), 7 deletions(-)

(limited to 'src/GF')

diff --git a/src/GF/Canon/CanonToGrammar.hs b/src/GF/Canon/CanonToGrammar.hs
index 758bddd69..780a953e1 100644
--- a/src/GF/Canon/CanonToGrammar.hs
+++ b/src/GF/Canon/CanonToGrammar.hs
@@ -80,7 +80,9 @@ redInfo (c,info) = errIn ("decompiling abstract" +++ show c) $ do
       xx'   <- mapM redArgVar xx
       body' <- redCTerm body
       ppr'  <- redCTerm ppr
-      return $ G.CncFun Nothing (Yes (F.mkAbs xx' body')) (Yes ppr')
+      cat'  <- redIdent cat
+      return $ G.CncFun (Just (cat', ([],F.typeStr))) -- Nothing 
+        (Yes (F.mkAbs xx' body')) (Yes ppr')
 
     AnyInd b c -> liftM (G.AnyInd b) $ redIdent c
 
diff --git a/src/GF/Compile/MkConcrete.hs b/src/GF/Compile/MkConcrete.hs
index 2bd45a4e5..5413d1b79 100644
--- a/src/GF/Compile/MkConcrete.hs
+++ b/src/GF/Compile/MkConcrete.hs
@@ -82,7 +82,7 @@ mkCncGroups opts0 ((res,path),files) = do
       return 
             (\cat s -> 
                 errVal ([],"No parse") $ 
-                optParseArgErrMsg (options [newMParser, firstCat cat, beVerbose]) gr s >>=
+                optParseArgErrMsg (options [newFParser, firstCat cat, beVerbose]) gr s >>=
                 (\ (ts,e) -> return (map tree2exp ts, e)) , 
             isKnownWord gr)
   putStrLn "Building parser"
diff --git a/src/GF/Compile/Rename.hs b/src/GF/Compile/Rename.hs
index ecabf03b1..05fdfa077 100644
--- a/src/GF/Compile/Rename.hs
+++ b/src/GF/Compile/Rename.hs
@@ -204,7 +204,9 @@ renameTerm env vars = ren vars where
       | elem r vs -> return trm                           -- var proj first
       | otherwise -> case renid (Q r (label2ident l)) of  -- qualif   second
           Ok t -> return t
-          _ -> liftM (flip P l) $ renid t                 -- const proj last
+          _ -> case liftM (flip P l) $ renid t of
+            Ok t -> return t                              -- const proj last
+            _ -> prtBad "unknown qualified constant" trm
 
     _ -> composOp (ren vs) trm
 
diff --git a/src/GF/Grammar/Lookup.hs b/src/GF/Grammar/Lookup.hs
index 337329d44..f0032f09f 100644
--- a/src/GF/Grammar/Lookup.hs
+++ b/src/GF/Grammar/Lookup.hs
@@ -51,6 +51,8 @@ lookupResDef gr m c = look True m c where
 
           CncCat (Yes ty) _ _ -> lock c ty
           CncCat _ _ _        -> lock c defLinType
+          CncFun (Just (cat,_)) (Yes tr) _ -> unlock cat tr
+
           CncFun _ (Yes tr) _ -> unlock c tr
 
           AnyInd _ n        -> look False n c
@@ -73,7 +75,7 @@ lookupResType gr m c = do
 
         -- used in reused concrete
         CncCat _ _ _ -> return typeType
-        CncFun (Just (cat,(cont,val))) _ _ -> do
+        CncFun (Just (cat,(cont@(_:_),val))) _ _ -> do
           val' <- lock cat val 
           return $ mkProd (cont, val', [])
         CncFun _ _ _      -> lookFunType m m c
diff --git a/src/GF/UseGrammar/Parsing.hs b/src/GF/UseGrammar/Parsing.hs
index e979579c9..65ed26863 100644
--- a/src/GF/UseGrammar/Parsing.hs
+++ b/src/GF/UseGrammar/Parsing.hs
@@ -83,7 +83,8 @@ parseStringC opts0 sg cat s
                t:_ -> t
                _ -> [] ---- no support for undet. tok.
   ts <- checkErr $ New.parse algorithm strategy (pInfo sg) (absId sg) cat toks
-  ts' <- mapM (checkErr . annotate (stateGrammarST sg) . refreshMetas []) ts
+  ts' <- checkErr $ 
+           allChecks $ map (annotate (stateGrammarST sg) . refreshMetas []) ts
   return $ optIntOrAll opts flagNumber ts'
 
 
@@ -115,7 +116,8 @@ trees2trms opts sg cn as ts0 info = do
                      )
       (ts1,ss) <- checkErr $ mapErrN 1 postParse ts01
       if null ts1 then raise ss else return ()
-      ts2 <- mapM (checkErr . annotate gr . refreshMetas [] . trExp) ts1 ---- 
+      ts2 <- checkErr $ 
+               allChecks $ map (annotate gr . refreshMetas [] . trExp) ts1 ---- 
       if forgive then return ts2 else do
         let tsss = [(t, allLinsOfTree gr cn t) | t <- ts2]
             ps = [t | (t,ss) <- tsss, 
@@ -127,7 +129,6 @@ trees2trms opts sg cn as ts0 info = do
                           unlines (nub (map sstr (concatMap snd tsss)))
                      else ""
            else return ps
-
   if verb 
      then checkWarn $ " the token list" +++ show as ++++ unknownWords sg as +++++ info
      else return ()
@@ -140,6 +141,8 @@ trees2trms opts sg cn as ts0 info = do
    verb    = oElem beVerbose opts
    forgive = oElem forgiveParse opts
 
+---- Operatins.allChecks :: ErrorMonad m => [m a] -> m [a]
+
 unknownWords sg ts = case filter noMatch [t | t@(TS _) <- ts] of
      [] -> "where all words are known"
      us -> "with the unknown tokens" +++ show us --- needs to be fixed for literals
-- 
cgit v1.2.3