GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-05-21 09:02:50 -06:00
Code Issues Packages Projects Releases Wiki Activity

gf -s/-q now silences "no linearization of" warnings

Browse Source
This commit is contained in:
hallgren
2013-04-10 23:00:01 +00:00
parent b8ce5ef5b3
commit 5bce1d7a16
1 changed files with 32 additions and 30 deletions
Download Patch File Download Diff File Expand all files Collapse all files

12
src/compiler/GF/Compile/CheckGrammar.hs
View File

@@ -51,7 +51,7 @@ checkModule opts sgr mo@(m,mi) = do
mo <- case mtype mi of mo <- case mtype mi of
MTConcrete a -> do let gr = prependModule sgr mo MTConcrete a -> do let gr = prependModule sgr mo
abs <- checkErr $ lookupModule gr a abs <- checkErr $ lookupModule gr a
checkCompleteGrammar gr (a,abs) mo checkCompleteGrammar opts gr (a,abs) mo
_ -> return mo _ -> return mo
infoss <- checkErr $ topoSortJments2 mo infoss <- checkErr $ topoSortJments2 mo
foldM updateCheckInfos mo infoss foldM updateCheckInfos mo infoss
@@ -82,8 +82,8 @@ checkRestrictedInheritance sgr (name,mo) = checkIn (ppLocation (msrc mo) NoLoc <
nest 2 (vcat [ppIdent f <+> text "on" <+> fsep (map ppIdent is) | (f,is) <- cs])) nest 2 (vcat [ppIdent f <+> text "on" <+> fsep (map ppIdent is) | (f,is) <- cs]))
allDeps = concatMap (allDependencies (const True) . jments . snd) mos allDeps = concatMap (allDependencies (const True) . jments . snd) mos
checkCompleteGrammar :: SourceGrammar -> SourceModule -> SourceModule -> Check SourceModule checkCompleteGrammar :: Options -> SourceGrammar -> SourceModule -> SourceModule -> Check SourceModule
checkCompleteGrammar gr (am,abs) (cm,cnc) = checkIn (ppLocation (msrc cnc) NoLoc <> colon) $ do checkCompleteGrammar opts gr (am,abs) (cm,cnc) = checkIn (ppLocation (msrc cnc) NoLoc <> colon) $ do
let jsa = jments abs let jsa = jments abs
let jsc = jments cnc let jsc = jments cnc
@@ -116,15 +116,17 @@ checkCompleteGrammar gr (am,abs) (cm,cnc) = checkIn (ppLocation (msrc cnc) NoLoc
Ok (CncFun ty Nothing mn mf) -> Ok (CncFun ty Nothing mn mf) ->
case mb_def of case mb_def of
Ok def -> return $ updateTree (c,CncFun ty (Just (L NoLoc def)) mn mf) js Ok def -> return $ updateTree (c,CncFun ty (Just (L NoLoc def)) mn mf) js
Bad _ -> do checkWarn (text "no linearization of" <+> ppIdent c) Bad _ -> do noLinOf c
return js return js
_ -> do _ -> do
case mb_def of case mb_def of
Ok def -> do (cont,val) <- linTypeOfType gr cm ty Ok def -> do (cont,val) <- linTypeOfType gr cm ty
let linty = (snd (valCat ty),cont,val) let linty = (snd (valCat ty),cont,val)
return $ updateTree (c,CncFun (Just linty) (Just (L NoLoc def)) Nothing Nothing) js return $ updateTree (c,CncFun (Just linty) (Just (L NoLoc def)) Nothing Nothing) js
Bad _ -> do checkWarn (text "no linearization of" <+> ppIdent c) Bad _ -> do noLinOf c
return js return js
where noLinOf c = when (verbAtLeast opts Normal) $
checkWarn (text "no linearization of" <+> ppIdent c)
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