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

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
+   | CreateLin [Option] Fun (Maybe Term) Bool
-   | CreateLincat [Option] Cat Term
+   | CreateLincat [Option] Cat (Maybe Term)
    | DropFun [Option] Fun
    | DropCat [Option] Cat
    | DropConcrete [Option] ConcName

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
+               body <- option Nothing $ do
-               args <- sepBy pIdent skipSpaces
+                         skipSpaces
-               skipSpaces
+                         args <- sepBy pIdent skipSpaces
-               char '='
+                         skipSpaces
-               skipSpaces
+                         char '='
-               t  <- readS_to_P (\s -> case runPartial pTerm s of
+                         skipSpaces
-                                         Right (s,t) -> [(t,s)]
+                         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"))
+                                                   _ -> [])
+                         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
+               body <- option Nothing $ do
-               char '='
+                         skipSpaces
-               skipSpaces
+                         char '='
-               t  <- readS_to_P (\s -> case runPartial pTerm s of
+                         skipSpaces
-                                         Right (s,t) -> [(t,s)]
+                         t  <- readS_to_P (\s -> case runPartial pTerm s of
-                                         _ -> [])
+                                                   Right (s,t) -> [(t,s)]
-               return (CreateLincat opts f t)
+                                                   _ -> [])
+                         return (Just t)
+               return (CreateLincat opts f body)
           | take 1 cmd == "d" -> do
                 f <- pIdent
                 return (DropLincat opts f)

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
+    compileLinTerm sgr mo f mb_t ty = do
-      t  <- renameSourceTerm sgr mo (Typed t ty)
+      (t,ty) <- case mb_t of
-      (t,ty) <- inferLType sgr [] t
+                  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
+    compileLincatTerm sgr mo mb_t = do
-      t <- renameSourceTerm sgr mo t
+      t <- case mb_t of
-      (t,_) <- inferLType sgr [] t
+             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)