msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

check the resource and the compiled grammar for compatibility

Browse Source
This commit is contained in:
Krasimir Angelov
2021-12-29 12:28:50 +01:00
parent 859d6ad5a5
commit daebed0b7b
1 changed files with 15 additions and 7 deletions
Download Patch File Download Diff File Expand all files Collapse all files

22
src/compiler/GF/Interactive.hs
View File

@@ -14,7 +14,7 @@ import GF.Command.Abstract
import GF.Command.Parse(readCommandLine,pCommand,readTransactionCommand) import GF.Command.Parse(readCommandLine,pCommand,readTransactionCommand)
import GF.Compile.Rename(renameSourceTerm) import GF.Compile.Rename(renameSourceTerm)
import GF.Compile.TypeCheck.Concrete(inferLType) import GF.Compile.TypeCheck.Concrete(inferLType)
import GF.Compile.GeneratePMCFG(pmcfgForm) import GF.Compile.GeneratePMCFG(pmcfgForm,type2fields)
import GF.Data.Operations (Err(..)) import GF.Data.Operations (Err(..))
import GF.Data.Utilities(whenM,repeatM) import GF.Data.Utilities(whenM,repeatM)
import GF.Grammar hiding (Ident,isPrefixOf) import GF.Grammar hiding (Ident,isPrefixOf)
@@ -245,15 +245,22 @@ transactionCommand (CreateConcrete opts name) pgf = do
return () return ()
transactionCommand (CreateLin opts f t) pgf = do transactionCommand (CreateLin opts f t) pgf = do
sgr <- getGrammar sgr <- getGrammar
lang <- optLang pgf opts
mo <- maybe (fail "no source grammar in scope") return $ mo <- maybe (fail "no source grammar in scope") return $
greatestResource sgr greatestResource sgr
ty <- case functionType pgf f of (fields,ty) <-
Just ty -> return $ type2term mo ty case functionType pgf f of
Nothing -> fail ("Function "++f++" is not in the abstract syntax") Just ty -> let DTyp _ cat _ = ty
Just cnc = Map.lookup lang (languages pgf)
Just fields = categoryFields cnc cat
in return (fields,type2term mo ty)
Nothing -> fail ("Function "++f++" is not in the abstract syntax")
case runCheck (compileLinTerm sgr mo t ty) of case runCheck (compileLinTerm sgr mo t ty) of
Ok (prods,_) -> do lang <- optLang pgf opts Ok ((prods,fields'),_)
lift $ modifyPGF pgf (alterConcrete lang (createLin f prods)) | fields == fields' ->
do lift $ modifyPGF pgf (alterConcrete lang (createLin f prods))
return () return ()
| otherwise -> fail "The linearization categories in the resource and the compiled grammar does not match"
Bad msg -> fail msg Bad msg -> fail msg
where where
type2term mo (DTyp hypos cat _) = type2term mo (DTyp hypos cat _) =
@@ -265,7 +272,8 @@ transactionCommand (CreateLin opts f t) pgf = do
t <- renameSourceTerm sgr mo (Typed t ty) t <- renameSourceTerm sgr mo (Typed t ty)
(t,ty) <- inferLType sgr [] t (t,ty) <- inferLType sgr [] t
let (ctxt,res_ty) = typeFormCnc ty let (ctxt,res_ty) = typeFormCnc ty
pmcfgForm sgr t ctxt res_ty prods <- pmcfgForm sgr t ctxt res_ty
return (prods,type2fields sgr res_ty)
transactionCommand (CreateLincat opts c t) pgf = do transactionCommand (CreateLincat opts c t) pgf = do
lang <- optLang pgf opts lang <- optLang pgf opts