summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authoraarne <aarne@cs.chalmers.se>2006-06-20 15:05:22 +0000
committeraarne <aarne@cs.chalmers.se>2006-06-20 15:05:22 +0000
commita75c3b1907a814e63cdff9cc045bdcaabe055b8f (patch)
tree1b8d587c49fb67a41c68e3c4b8ff80e12c327df6 /src
parent402a113b567a96eef61946552b68df6ac6eb6712 (diff)
resource.txt updates ; lock field and lookup book fixes
Diffstat (limited to 'src')
-rw-r--r--src/GF/Canon/CanonToGrammar.hs4
-rw-r--r--src/GF/Compile/MkConcrete.hs2
-rw-r--r--src/GF/Compile/Rename.hs4
-rw-r--r--src/GF/Grammar/Lookup.hs4
-rw-r--r--src/GF/UseGrammar/Parsing.hs9
5 files changed, 16 insertions, 7 deletions
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