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

create lin/lincat can now fetch the definitions from the source grammar

Browse Source
This commit is contained in:
Krasimir Angelov
2024-02-08 15:14:05 +01:00
parent ab30f1f9e5
commit 3b4f12e621
3 changed files with 46 additions and 28 deletions
Download Patch File Download Diff File Expand all files Collapse all files

4
src/compiler/api/GF/Command/Abstract.hs
View File

@@ -17,8 +17,8 @@ data TransactionCommand
= CreateFun [Option] Fun Type
| CreateCat [Option] Cat [Hypo]
| CreateConcrete [Option] ConcName
| CreateLin [Option] Fun Term Bool
| CreateLincat [Option] Cat Term
| CreateLin [Option] Fun (Maybe Term) Bool
| CreateLincat [Option] Cat (Maybe Term)
| DropFun [Option] Fun
| DropCat [Option] Cat
| DropConcrete [Option] ConcName

36
src/compiler/api/GF/Command/Parse.hs
View File

@@ -84,28 +84,32 @@ pTransactionCommand = do
return (DropConcrete opts name)
"lin" | elem (take 1 cmd) ["c","a"] -> do
f <- pIdent
skipSpaces
args <- sepBy pIdent skipSpaces
skipSpaces
char '='
skipSpaces
t <- readS_to_P (\s -> case runPartial pTerm s of
Right (s,t) -> [(t,s)]
_ -> [])
return (CreateLin opts f (foldr (Abs Explicit . identS) t args) (take 1 cmd == "a"))
body <- option Nothing $ do
skipSpaces
args <- sepBy pIdent skipSpaces
skipSpaces
char '='
skipSpaces
t <- readS_to_P (\s -> case runPartial pTerm s of
Right (s,t) -> [(t,s)]
_ -> [])
return (Just (foldr (Abs Explicit . identS) t args))
return (CreateLin opts f body (take 1 cmd == "a"))
| take 1 cmd == "d" -> do
f <- pIdent
return (DropLin opts f)
"lincat"
| take 1 cmd == "c" -> do
f <- pIdent
skipSpaces
char '='
skipSpaces
t <- readS_to_P (\s -> case runPartial pTerm s of
Right (s,t) -> [(t,s)]
_ -> [])
return (CreateLincat opts f t)
body <- option Nothing $ do
skipSpaces
char '='
skipSpaces
t <- readS_to_P (\s -> case runPartial pTerm s of
Right (s,t) -> [(t,s)]
_ -> [])
return (Just t)
return (CreateLincat opts f body)
| take 1 cmd == "d" -> do
f <- pIdent
return (DropLincat opts f)

34
src/compiler/api/GF/Interactive.hs
View File

@@ -14,10 +14,12 @@ import GF.Command.Abstract
import GF.Command.Parse(readCommandLine,pCommand,readTransactionCommand)
import GF.Compile.Rename(renameSourceTerm)
import GF.Compile.TypeCheck.Concrete(inferLType)
import GF.Compile.Compute.Concrete(normalForm,stdPredef,Globals(..))
import GF.Compile.GeneratePMCFG(pmcfgForm,type2fields)
import GF.Data.Operations (Err(..))
import GF.Data.Utilities(whenM,repeatM)
import GF.Grammar hiding (Ident,isPrefixOf)
import GF.Grammar.Lookup(lookupResDef)
import GF.Infra.UseIO(ioErrorText,putStrLnE)
import GF.Infra.SIO
import GF.Infra.Option
@@ -282,7 +284,7 @@ transactionCommand (CreateCat opts c ctxt) pgf mb_txnid = do
transactionCommand (CreateConcrete opts name) pgf mb_txnid = do
lift $ updatePGF pgf mb_txnid (createConcrete name (return ()))
return ()
transactionCommand (CreateLin opts f t is_alter) pgf mb_txnid = do
transactionCommand (CreateLin opts f mb_t is_alter) pgf mb_txnid = do
sgr <- getGrammar
mo <- case greatestResource sgr of
Nothing -> fail "No source grammar in scope"
@@ -295,7 +297,7 @@ transactionCommand (CreateLin opts f t is_alter) pgf mb_txnid = do
alterConcrete lang $ do
mb_fields <- getCategoryFields cat
case mb_fields of
Just fields -> case runCheck (compileLinTerm sgr mo t (type2term mo ty)) of
Just fields -> case runCheck (compileLinTerm sgr mo f mb_t (type2term mo ty)) of
Ok ((prods,seqtbl,fields'),_)
| fields == fields' -> do
(if is_alter then alterLin else createLin) f prods seqtbl
@@ -310,29 +312,41 @@ transactionCommand (CreateLin opts f t is_alter) pgf mb_txnid = do
(Vr (identS cat))
hypos
compileLinTerm sgr mo t ty = do
t <- renameSourceTerm sgr mo (Typed t ty)
(t,ty) <- inferLType sgr [] t
compileLinTerm sgr mo f mb_t ty = do
(t,ty) <- case mb_t of
Just t -> do t <- renameSourceTerm sgr mo (Typed t ty)
(t,ty) <- inferLType sgr [] t
return (t,ty)
Nothing -> case lookupResDef sgr (mo,identS f) of
Ok t -> do ty <- renameSourceTerm sgr mo ty
ty <- normalForm (Gl sgr stdPredef) ty
return (t,ty)
Bad msg -> fail msg
let (ctxt,res_ty) = typeFormCnc ty
(prods,seqs) <- pmcfgForm sgr t ctxt res_ty Map.empty
return (prods,mapToSequence seqs,type2fields sgr res_ty)
where
mapToSequence m = Seq.fromList (map (Left . fst) (sortOn snd (Map.toList m)))
transactionCommand (CreateLincat opts c t) pgf mb_txnid = do
transactionCommand (CreateLincat opts c mb_t) pgf mb_txnid = do
sgr <- getGrammar
mo <- case greatestResource sgr of
Nothing -> fail "No source grammar in scope"
Just mo -> return mo
lang <- optLang pgf opts
case runCheck (compileLincatTerm sgr mo t) of
case runCheck (compileLincatTerm sgr mo mb_t) of
Ok (fields,_)-> do lift $ updatePGF pgf mb_txnid (alterConcrete lang (createLincat c fields [] [] Seq.empty >> return ()))
return ()
Bad msg -> fail msg
where
compileLincatTerm sgr mo t = do
t <- renameSourceTerm sgr mo t
(t,_) <- inferLType sgr [] t
compileLincatTerm sgr mo mb_t = do
t <- case mb_t of
Just t -> do t <- renameSourceTerm sgr mo t
(t,_) <- inferLType sgr [] t
return t
Nothing -> case lookupResDef sgr (mo,identS c) of
Ok t -> return t
Bad msg -> fail msg
return (type2fields sgr t)
transactionCommand (DropFun opts f) pgf mb_txnid = do
lift $ updatePGF pgf mb_txnid (dropFunction f)