GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-05-10 03:32:51 -06:00
Code Issues Packages Projects Releases Wiki Activity

the check for lincat C = <> is made more robust

Browse Source
This commit is contained in:
krasimir
2009-05-15 11:27:26 +00:00
parent 0dad868f34
commit 110d436e85
1 changed files with 16 additions and 16 deletions
Download Patch File Download Diff File Expand all files Collapse all files

32
src/GF/Compile/CheckGrammar.hs
View File

@@ -194,28 +194,28 @@ checkCompleteGrammar gr abs cnc = do
CncCat _ _ _ -> True CncCat _ _ _ -> True
_ -> False _ -> False
checkOne js i@(c,info) = case info of checkOne js i@(c,info) = case info of
AbsFun (Just ty) _ -> do mb_def <- checkErr $ do AbsFun (Just ty) _ -> do let mb_def = do
(cxt,(_,i),_) <- typeForm ty (cxt,(_,i),_) <- typeForm ty
info <- lookupIdent i js info <- lookupIdent i js
info <- case info of info <- case info of
(AnyInd _ m) -> do (m,info) <- lookupOrigInfo gr m i (AnyInd _ m) -> do (m,info) <- lookupOrigInfo gr m i
return info return info
_ -> return info _ -> return info
case info of case info of
CncCat (Just (RecType [])) _ _ -> return (Just (foldr (\_ -> Abs identW) (R []) cxt)) CncCat (Just (RecType [])) _ _ -> return (foldr (\_ -> Abs identW) (R []) cxt)
_ -> return Nothing _ -> Bad "no def lin"
case lookupIdent c js of case lookupIdent c js of
Ok (CncFun _ (Just _) _ ) -> return js Ok (CncFun _ (Just _) _ ) -> return js
Ok (CncFun cty Nothing pn) -> Ok (CncFun cty Nothing pn) ->
case mb_def of case mb_def of
Just def -> return $ updateTree (c,CncFun cty (Just def) pn) js Ok def -> return $ updateTree (c,CncFun cty (Just def) pn) js
Nothing -> do checkWarn $ "WARNING: no linearization of" +++ prt c Bad _ -> do checkWarn $ "WARNING: no linearization of" +++ prt c
return js return js
_ -> do _ -> do
case mb_def of case mb_def of
Just def -> return $ updateTree (c,CncFun Nothing (Just def) Nothing) js Ok def -> return $ updateTree (c,CncFun Nothing (Just def) Nothing) js
Nothing -> do checkWarn $ "WARNING: no linearization of" +++ prt c Bad _ -> do checkWarn $ "WARNING: no linearization of" +++ prt c
return js return js
AbsCat (Just _) _ -> case lookupIdent c js of AbsCat (Just _) _ -> case lookupIdent c js of
Ok (AnyInd _ _) -> return js Ok (AnyInd _ _) -> return js
Ok (CncCat (Just _) _ _) -> return js Ok (CncCat (Just _) _ _) -> return js