diff --git a/src/compiler/api/GF/Command/Abstract.hs b/src/compiler/api/GF/Command/Abstract.hs index d828d4bef..e2c6c156c 100644 --- a/src/compiler/api/GF/Command/Abstract.hs +++ b/src/compiler/api/GF/Command/Abstract.hs @@ -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 diff --git a/src/compiler/api/GF/Command/Parse.hs b/src/compiler/api/GF/Command/Parse.hs index 4fcd71e2e..68cf07617 100644 --- a/src/compiler/api/GF/Command/Parse.hs +++ b/src/compiler/api/GF/Command/Parse.hs @@ -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) diff --git a/src/compiler/api/GF/Interactive.hs b/src/compiler/api/GF/Interactive.hs index 8c85ffbf7..72ed54bff 100644 --- a/src/compiler/api/GF/Interactive.hs +++ b/src/compiler/api/GF/Interactive.hs @@ -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)