correctly distinguish between fun and data judgements

gf.cabal

@@ -123,7 +123,6 @@ executable gf
     GF.Compile.ConcreteToHaskell
     GF.Compile.GrammarToCanonical
     GF.Grammar.CanonicalJSON
-    GF.Compile.PGFtoJSON
     GF.Compile.ReadFiles
     GF.Compile.Rename
     GF.Compile.SubExOpt

src/compiler/GF/Command/Importing.hs

@@ -1,7 +1,6 @@
 module GF.Command.Importing (importGrammar, importSource) where
 
 import PGF2
-import PGF2.Internal(unionPGF)
 
 import GF.Compile
 import GF.Compile.Multi (readMulti)
@@ -50,6 +49,8 @@ ioUnionPGF (Just one) two =
     Nothing         -> putStrLn "Abstract changed, previous concretes discarded." >> return (Just two)
     Just pgf        -> return (Just pgf)
 
+unionPGF = error "TODO: unionPGF"
+
 importSource :: Options -> [FilePath] -> IO SourceGrammar
 importSource opts files = fmap (snd.snd) (batchCompile opts files)
 

src/compiler/GF/Compile/CFGtoPGF.hs

@@ -7,7 +7,6 @@ import GF.Infra.Option
 import GF.Compile.OptimizePGF
 
 import PGF2
-import PGF2.Internal
 
 import qualified Data.Set as Set
 import qualified Data.Map as Map

src/compiler/GF/Compile/Export.hs

@@ -4,7 +4,6 @@ import PGF2
 import GF.Compile.PGFtoHaskell
 --import GF.Compile.PGFtoAbstract
 import GF.Compile.PGFtoJava
-import GF.Compile.PGFtoJSON
 import GF.Infra.Option
 --import GF.Speech.CFG
 import GF.Speech.PGFToCFG
@@ -35,7 +34,6 @@ exportPGF opts fmt pgf =
       FmtPGFPretty    -> multi "txt" (showPGF)
       FmtCanonicalGF  -> [] -- canon "gf" (render80 . abstract2canonical)
       FmtCanonicalJson-> []
-      FmtJSON         -> multi "json"  pgf2json
       FmtHaskell      -> multi "hs"  (grammar2haskell opts name)
       FmtJava         -> multi "java" (grammar2java opts name)
       FmtBNF          -> single "bnf"   bnfPrinter

src/compiler/GF/Compile/GenerateBC.hs

@@ -5,7 +5,7 @@ import GF.Grammar
 import GF.Grammar.Lookup(lookupAbsDef,lookupFunType)
 import GF.Data.Operations
 import PGF2(Literal(..))
-import PGF2.Internal(CodeLabel,Instr(..),IVal(..),TailInfo(..))
+import PGF2.ByteCode
 import qualified Data.Map as Map
 import Data.List(nub,mapAccumL)
 import Data.Maybe(fromMaybe)
@@ -19,9 +19,7 @@ generateByteCode gr arity eqs =
       b = if arity == 0 || null eqs
             then instrs
             else CHECK_ARGS arity:instrs
-  in case bs of
+  in reverse bs
-       [[FAIL]] -> []         -- in the runtime this is a more efficient variant of [[FAIL]]
-       _        -> reverse bs
   where
     is = push_is (arity-1) arity []
 

src/compiler/GF/Compile/GrammarToPGF.hs

@@ -48,7 +48,7 @@ grammar2PGF opts gr am probs = do
   pgf <- modifyPGF pgf $ do
     sequence_ [setAbstractFlag name value | (name,value) <- optionsPGF aflags]
     sequence_ [createCategory c ctxt p | (c,ctxt,p) <- cats]
-    sequence_ [createFunction f ty arity p | (f,ty,arity,_,p) <- funs]
+    sequence_ [createFunction f ty arity bcode p | (f,ty,arity,bcode,p) <- funs]
     forM_ (allConcretes gr am) $ \cm ->
       createConcrete (mi2i cm) $ do
         let cflags = err (const noOptions) mflags (lookupModule gr cm)

src/compiler/GF/Compile/PGFtoHaskell.hs

@@ -17,7 +17,6 @@
 module GF.Compile.PGFtoHaskell (grammar2haskell) where
 
 import PGF2
-import PGF2.Internal
 
 import GF.Data.Operations
 import GF.Infra.Option

src/compiler/GF/Compile/PGFtoJSON.hs

@@ -1,111 +0,0 @@
-module GF.Compile.PGFtoJSON (pgf2json) where
-
-import PGF2
-import PGF2.Internal
-import Text.JSON
-import qualified Data.Map as Map
-
-pgf2json :: PGF -> String
-pgf2json pgf = error "TODO: pgf2json"
-{-  encode $ makeObj
-    [ ("abstract", abstract2json pgf)
-    , ("concretes", makeObj $ map concrete2json
-                                (Map.toList (languages pgf)))
-    ]
-
-abstract2json :: PGF -> JSValue
-abstract2json pgf =
-  makeObj
-    [ ("name", showJSON (abstractName pgf))
-    , ("startcat", showJSON (showType [] (startCat pgf)))
-    , ("funs", makeObj $ map (absdef2json pgf) (functions pgf))
-    ]
-
-absdef2json :: PGF -> Fun -> (String,JSValue)
-absdef2json pgf f = (f,sig)
-  where
-    Just (hypos,cat,_) = fmap unType (functionType pgf f)
-    sig = makeObj
-      [ ("args", showJSON $ map (\(_,_,ty) -> showType [] ty) hypos)
-      , ("cat", showJSON cat)
-      ]
-
-lit2json :: Literal -> JSValue
-lit2json (LStr s) = showJSON s
-lit2json (LInt n) = showJSON n
-lit2json (LFlt d) = showJSON d
-
-concrete2json :: (ConcName,Concr) -> (String,JSValue)
-concrete2json (c,cnc) = (c,obj)
-  where
-    obj = makeObj
-      [ ("flags", makeObj [(k, lit2json v) | (k,v) <- concrFlags cnc])
-      , ("productions", makeObj [(show fid, showJSON (map frule2json (concrProductions cnc fid))) | (_,start,end,_) <- concrCategories cnc, fid <- [start..end]])
-      , ("functions", showJSON [ffun2json funid (concrFunction cnc funid) | funid <- [0..concrTotalFuns cnc-1]])
-      , ("sequences", showJSON [seq2json seqid (concrSequence cnc seqid) | seqid <- [0..concrTotalSeqs cnc-1]])
-      , ("categories", makeObj $ map cat2json (concrCategories cnc))
-      , ("totalfids", showJSON (concrTotalCats cnc))
-      ]
-
-cat2json :: (Cat,FId,FId,[String]) -> (String,JSValue)
-cat2json (cat,start,end,_) = (cat, ixs)
-  where
-    ixs = makeObj
-      [ ("start", showJSON start)
-      , ("end",   showJSON end)
-      ]
-
-frule2json :: Production -> JSValue
-frule2json (PApply fid args) =
-  makeObj
-    [ ("type", showJSON "Apply")
-    , ("fid",  showJSON fid)
-    , ("args", showJSON (map farg2json args))
-    ]
-frule2json (PCoerce arg) =
-  makeObj
-    [ ("type", showJSON "Coerce")
-    , ("arg",  showJSON arg)
-    ]
-
-farg2json :: PArg -> JSValue
-farg2json (PArg hypos fid) =
-  makeObj
-    [ ("type", showJSON "PArg")
-    , ("hypos", JSArray $ map (showJSON . snd) hypos)
-    , ("fid", showJSON fid)
-    ]
-
-ffun2json :: FunId -> (Fun,[SeqId]) -> JSValue
-ffun2json funid (fun,seqids) =
-  makeObj
-    [ ("name", showJSON fun)
-    , ("lins", showJSON seqids)
-    ]
-
-seq2json :: SeqId -> [Symbol] -> JSValue
-seq2json seqid seq = showJSON [sym2json sym | sym <- seq]
-
-sym2json :: Symbol -> JSValue
-sym2json (SymCat n l)    = new "SymCat" [showJSON n, showJSON l]
-sym2json (SymLit n l)    = new "SymLit" [showJSON n, showJSON l]
-sym2json (SymVar n l)    = new "SymVar" [showJSON n, showJSON l]
-sym2json (SymKS t)       = new "SymKS"  [showJSON t]
-sym2json (SymKP ts alts) = new "SymKP"  [JSArray (map sym2json ts), JSArray (map alt2json alts)]
-sym2json SymBIND         = new "SymKS"  [showJSON "&+"]
-sym2json SymSOFT_BIND    = new "SymKS"  [showJSON "&+"]
-sym2json SymSOFT_SPACE   = new "SymKS"  [showJSON "&+"]
-sym2json SymCAPIT        = new "SymKS"  [showJSON "&|"]
-sym2json SymALL_CAPIT    = new "SymKS"  [showJSON "&|"]
-sym2json SymNE           = new "SymNE"  []
-
-alt2json :: ([Symbol],[String]) -> JSValue
-alt2json (ps,ts) = new "Alt" [showJSON (map sym2json ps), showJSON ts]
-
-new :: String -> [JSValue] -> JSValue
-new f xs =
-  makeObj
-    [ ("type", showJSON f)
-    , ("args", showJSON xs)
-    ]
--}

src/compiler/GF/Compiler.hs

@@ -1,7 +1,6 @@
 module GF.Compiler (mainGFC, linkGrammars, writeGrammar, writeOutputs) where
 
 import PGF2
-import PGF2.Internal(unionPGF,writeConcr)
 import GF.Compile as S(batchCompile,link,srcAbsName)
 import GF.CompileInParallel as P(parallelBatchCompile)
 import GF.Compile.Export
@@ -148,6 +147,8 @@ unionPGFFiles opts fs =
     readPGFVerbose f =
         putPointE Normal opts ("Reading " ++ f ++ "...") $ liftIO $ readPGF f
 
+unionPGF = error "TODO: unionPGF"
+
 -- | Export the PGF to the 'OutputFormat's specified in the 'Options'.
 -- Calls 'exportPGF'.
 writeOutputs :: Options -> PGF -> IOE ()
@@ -162,22 +163,9 @@ writeOutputs opts pgf = do
 writeGrammar :: Options -> PGF -> IOE ()
 writeGrammar opts pgf =
   if fst (flag optLinkTargets opts)
-    then if flag optSplitPGF opts
+    then do let outfile = outputPath opts (grammarName opts pgf <.> "pgf")
-           then writeSplitPGF
+            writing opts outfile (writePGF outfile pgf)
-           else writeNormalPGF
     else return ()
-  where
-    writeNormalPGF =
-       do let outfile = outputPath opts (grammarName opts pgf <.> "pgf")
-          writing opts outfile (writePGF outfile pgf)
-
-    writeSplitPGF =
-      do let outfile = outputPath opts (grammarName opts pgf <.> "pgf")
-         writing opts outfile $ writePGF outfile pgf
-         forM_ (Map.toList (languages pgf)) $ \(concrname,concr) -> do
-           let outfile = outputPath opts (concrname <.> "pgf_c")
-           writing opts outfile (writeConcr outfile concr)
-
 
 writeOutput :: Options -> FilePath-> String -> IOE ()
 writeOutput opts file str = writing opts path $ writeUTF8File path str
@@ -189,7 +177,7 @@ grammarName :: Options -> PGF -> String
 grammarName opts pgf = grammarName' opts (abstractName pgf)
 grammarName' opts abs = fromMaybe abs (flag optName opts)
 
-outputJustPGF opts = null (flag optOutputFormats opts) && not (flag optSplitPGF opts)
+outputJustPGF opts = null (flag optOutputFormats opts)
 
 outputPath opts file = maybe id (</>) (flag optOutputDir opts) file
 

src/compiler/GF/Infra/Option.hs

@@ -170,7 +170,6 @@ data Flags = Flags {
       optPMCFG           :: Bool,
       optOptimizations   :: Set Optimization,
       optOptimizePGF     :: Bool,
-      optSplitPGF        :: Bool,
       optCFGTransforms   :: Set CFGTransform,
       optLibraryPath     :: [FilePath],
       optStartCat        :: Maybe String,
@@ -282,7 +281,6 @@ defaultFlags = Flags {
       optPMCFG           = True,
       optOptimizations   = Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize],
       optOptimizePGF     = False,
-      optSplitPGF        = False,
       optCFGTransforms   = Set.fromList [CFGRemoveCycles, CFGBottomUpFilter,
                                          CFGTopDownFilter, CFGMergeIdentical],
       optLibraryPath     = [],
@@ -378,8 +376,6 @@ optDescr =
                 "Select an optimization package. OPT = all | values | parametrize | none",
      Option [] ["optimize-pgf"] (NoArg (optimize_pgf True))
                 "Enable or disable global grammar optimization. This could significantly reduce the size of the final PGF file",
-     Option [] ["split-pgf"] (NoArg (splitPGF True))
-                "Split the PGF into one file per language. This allows the runtime to load only individual languages",
      Option [] ["cfg"] (ReqArg cfgTransform "TRANS") "Enable or disable specific CFG transformations. TRANS = merge, no-merge, bottomup, no-bottomup, ...",
      Option [] ["heuristic_search_factor"] (ReqArg (readDouble (\d o -> o { optHeuristicFactor = Just d })) "FACTOR") "Set the heuristic search factor for statistical parsing",
      Option [] ["case_sensitive"] (onOff (\v -> set $ \o -> o{optCaseSensitive=v}) True) "Set the parser in case-sensitive/insensitive mode [sensitive by default]",
@@ -451,7 +447,6 @@ optDescr =
                          Nothing -> fail $ "Unknown optimization package: " ++ x
 
        optimize_pgf x = set $ \o -> o { optOptimizePGF = x }
-       splitPGF x = set $ \o -> o { optSplitPGF = x }
 
        cfgTransform x = let (x', b) = case x of
                                         'n':'o':'-':rest -> (rest, False)

src/compiler/GF/Speech/PGFToCFG.hs

@@ -7,7 +7,6 @@
 module GF.Speech.PGFToCFG (bnfPrinter, pgfToCFG) where
 
 import PGF2
-import PGF2.Internal
 import GF.Grammar.CFG hiding (Symbol)
 
 import Data.Map (Map)

src/runtime/c/pgf/data.cxx

@@ -9,18 +9,8 @@ void PgfAbsFun::release(ref<PgfAbsFun> absfun)
 {
     pgf_type_free(absfun->type);
 
-    if (absfun->defns != 0) {
+    if (absfun->bytecode != 0) {
-        for (size_t i = 0; i < absfun->defns->len; i++) {
+        PgfDB::free(absfun->bytecode);
-            ref<PgfEquation> eq = *vector_elem(absfun->defns, i);
-            pgf_expr_free(eq->body);
-
-            for (size_t j = 0; j < eq->patts.len; j++) {
-                PgfPatt patt = *vector_elem(ref<Vector<PgfPatt>>::from_ptr(&eq->patts), j);
-                pgf_patt_free(patt);
-            }
-        }
-
-        PgfDB::free(absfun->defns);
     }
 }
 

src/runtime/c/pgf/data.h

@@ -84,7 +84,7 @@ struct PGF_INTERNAL_DECL PgfAbsFun {
 
     ref<PgfDTyp> type;
 	int arity;
-    ref<Vector<ref<PgfEquation>>> defns;
+    ref<char> bytecode;
     PgfExprProb ep;
     PgfText name;
 

src/runtime/c/pgf/pgf.cxx

@@ -533,7 +533,7 @@ int pgf_function_is_constructor(PgfDB *db, PgfRevision revision,
         if (absfun == 0)
             return false;
 
-        return (absfun->defns == 0);
+        return (absfun->bytecode == 0);
     } PGF_API_END
 
     return false;
@@ -753,7 +753,7 @@ PgfText *pgf_print_function_internal(object o)
     PgfInternalMarshaller m;
     PgfPrinter printer(NULL,0,&m);
 
-    printer.puts("fun ");
+    printer.puts(absfun->bytecode != 0 ? "fun " : "data ");
     printer.efun(&absfun->name);
     printer.puts(" : ");
     m.match_type(&printer, absfun->type.as_object());
@@ -955,7 +955,8 @@ PgfRevision pgf_checkout_revision(PgfDB *db, PgfText *name,
 PGF_API
 void pgf_create_function(PgfDB *db, PgfRevision revision,
                          PgfText *name,
-                         PgfType ty, size_t arity, prob_t prob,
+                         PgfType ty, size_t arity, char *bytecode,
+                         prob_t prob,
                          PgfMarshaller *m,
                          PgfExn *err)
 {
@@ -969,7 +970,7 @@ void pgf_create_function(PgfDB *db, PgfRevision revision,
         absfun->ref_count = 1;
         absfun->type  = m->match_type(&u, ty);
         absfun->arity = arity;
-        absfun->defns = 0;
+        absfun->bytecode = bytecode ? PgfDB::malloc<char>(0) : 0;
         absfun->ep.prob = prob;
         ref<PgfExprFun> efun =
             ref<PgfExprFun>::from_ptr((PgfExprFun*) &absfun->name);

src/runtime/c/pgf/pgf.h

@@ -419,7 +419,8 @@ PgfRevision pgf_checkout_revision(PgfDB *db, PgfText *name,
 PGF_API_DECL
 void pgf_create_function(PgfDB *db, PgfRevision revision,
                          PgfText *name,
-                         PgfType ty, size_t arity, prob_t prob,
+                         PgfType ty, size_t arity, char *bytecode,
+                         prob_t prob,
                          PgfMarshaller *m,
                          PgfExn *err);
 

src/runtime/c/pgf/reader.cxx

@@ -317,69 +317,6 @@ ref<PgfDTyp> PgfReader::read_type()
     return tp;
 }
 
-PgfPatt PgfReader::read_patt()
-{
-    PgfPatt patt = 0;
-
-	uint8_t tag = read_tag();
-	switch (tag) {
-	case PgfPattApp::tag: {
-		ref<PgfText> ctor = read_name();
-
-		ref<PgfPattApp> papp =
-            read_vector<PgfPattApp,PgfPatt>(&PgfPattApp::args,&PgfReader::read_patt2);
-		papp->ctor = ctor;
-        patt = ref<PgfPattApp>::tagged(papp);
-		break;
-	}
-	case PgfPattVar::tag: {
-		ref<PgfPattVar> pvar = read_name<PgfPattVar>(&PgfPattVar::name);
-        patt = ref<PgfPattVar>::tagged(pvar);
-		break;
-	}
-	case PgfPattAs::tag: {
-        ref<PgfPattAs> pas = read_name<PgfPattAs>(&PgfPattAs::name);
-		pas->patt = read_patt();
-        patt = ref<PgfPattAs>::tagged(pas);
-		break;
-	}
-	case PgfPattWild::tag: {
-		ref<PgfPattWild> pwild = PgfDB::malloc<PgfPattWild>();
-        patt = ref<PgfPattWild>::tagged(pwild);
-		break;
-	}
-	case PgfPattLit::tag: {
-        ref<PgfPattLit> plit = PgfDB::malloc<PgfPattLit>();
-		plit->lit = read_literal();
-        patt = ref<PgfPattLit>::tagged(plit);
-		break;
-	}
-	case PgfPattImplArg::tag: {
-        ref<PgfPattImplArg> pimpl = PgfDB::malloc<PgfPattImplArg>();
-		pimpl->patt = read_patt();
-        patt = ref<PgfPattImplArg>::tagged(pimpl);
-		break;
-	}
-	case PgfPattTilde::tag: {
-        ref<PgfPattTilde> ptilde = PgfDB::malloc<PgfPattTilde>();
-		ptilde->expr = read_expr();
-        patt = ref<PgfPattTilde>::tagged(ptilde);
-		break;
-	}
-	default:
-		throw pgf_error("Unknown pattern tag");
-	}
-
-	return patt;
-}
-
-void PgfReader::read_defn(ref<ref<PgfEquation>> defn)
-{
-    ref<PgfEquation> eq = read_vector(&PgfEquation::patts,&PgfReader::read_patt2);
-    eq->body = read_expr();
-    *defn = eq;
-}
-
 ref<PgfAbsFun> PgfReader::read_absfun()
 {
     ref<PgfAbsFun> absfun =
@@ -394,12 +331,13 @@ ref<PgfAbsFun> PgfReader::read_absfun()
     uint8_t tag = read_tag();
 	switch (tag) {
 	case 0:
-        absfun->defns = 0;
+        absfun->bytecode = 0;
         break;
-    case 1:
+    case 1: {
-        absfun->defns =
+        read_len();
-            read_vector<ref<PgfEquation>>(&PgfReader::read_defn);
+        absfun->bytecode = PgfDB::malloc<char>(0);
         break;
+    }
     default:
         throw pgf_error("Unknown tag, 0 or 1 expected");
     }

src/runtime/c/pgf/reader.h

@@ -59,9 +59,6 @@ public:
 
     ref<PgfFlag> read_flag();
 
-    PgfPatt read_patt();
-    void read_defn(ref<ref<PgfEquation>> defn);
-
     ref<PgfAbsFun> read_absfun();
     ref<PgfAbsCat> read_abscat();
     void read_abstract(ref<PgfAbstr> abstract);
@@ -84,7 +81,6 @@ private:
     object read_name_internal(size_t struct_size);
     object read_text_internal(size_t struct_size);
 
-    void read_patt2(ref<PgfPatt> r) { *r = read_patt(); };
     void read_text2(ref<ref<PgfText>> r) { *r = read_text(); };
     void read_lparam(ref<ref<PgfLParam>> r) { *r = read_lparam(); };
     void read_symbol2(ref<PgfSymbol> r) { *r = read_symbol(); };

src/runtime/c/pgf/writer.cxx

@@ -253,61 +253,6 @@ void PgfWriter::write_type(ref<PgfDTyp> ty)
     write_vector<PgfExpr>(ty->exprs, &PgfWriter::write_expr);
 }
 
-void PgfWriter::write_patt(PgfPatt patt)
-{
-    auto tag = ref<PgfPatt>::get_tag(patt);
-    write_tag(tag);
-
-	switch (tag) {
-	case PgfPattApp::tag: {
-		auto papp = ref<PgfPattApp>::untagged(patt);
-        write_name(papp->ctor);
-        write_vector(ref<Vector<PgfPatt>>::from_ptr(&papp->args), &PgfWriter::write_patt);
-		break;
-	}
-	case PgfPattVar::tag: {
-		auto pvar = ref<PgfPattVar>::untagged(patt);
-        write_name(&pvar->name);
-		break;
-	}
-	case PgfPattAs::tag: {
-        auto pas = ref<PgfPattAs>::untagged(patt);
-        write_name(&pas->name);
-        write_patt(pas->patt);
-		break;
-	}
-	case PgfPattWild::tag: {
-		auto pwild = ref<PgfPattWild>::untagged(patt);
-		break;
-	}
-	case PgfPattLit::tag: {
-        auto plit = ref<PgfPattLit>::untagged(patt);
-        write_literal(plit->lit);
-		break;
-	}
-	case PgfPattImplArg::tag: {
-        auto pimpl = ref<PgfPattImplArg>::untagged(patt);
-		write_patt(pimpl->patt);
-		break;
-	}
-	case PgfPattTilde::tag: {
-        auto ptilde = ref<PgfPattTilde>::untagged(patt);
-		write_expr(ptilde->expr);
-		break;
-	}
-	default:
-		throw pgf_error("Unknown pattern tag");
-	}
-}
-
-void PgfWriter::write_defn(ref<ref<PgfEquation>> r)
-{
-    ref<PgfEquation> equ = *r;
-
-    write_vector(ref<Vector<PgfPatt>>::from_ptr(&equ->patts), &PgfWriter::write_patt);
-    write_expr(equ->body);
-}
-
 void PgfWriter::write_flag(ref<PgfFlag> flag)
 {
     write_name(&flag->name);
@@ -319,11 +264,11 @@ void PgfWriter::write_absfun(ref<PgfAbsFun> absfun)
     write_name(&absfun->name);
     write_type(absfun->type);
     write_int(absfun->arity);
-    if (absfun->defns == 0)
+    if (absfun->bytecode == 0)
         write_tag(0);
     else {
         write_tag(1);
-        write_vector<ref<PgfEquation>>(absfun->defns, &PgfWriter::write_defn);
+        write_len(0);
     }
     write_double(exp(-absfun->ep.prob));
 }

src/runtime/c/pgf/writer.h

@@ -32,9 +32,6 @@ public:
     void write_hypo(ref<PgfHypo> hypo);
     void write_type(ref<PgfDTyp> ty);
 
-    void write_patt(PgfPatt patt);
-    void write_defn(ref<ref<PgfEquation>> r);
-
     void write_flag(ref<PgfFlag> flag);
 
     void write_absfun(ref<PgfAbsFun> absfun);

src/runtime/haskell/PGF2/ByteCode.hs

@@ -1,30 +1,9 @@
-{-# LANGUAGE ImplicitParams, RankNTypes #-}
+module PGF2.ByteCode(-- * Byte code
-
-module PGF2.Internal(-- * Access the internal structures
-                     FId,isPredefFId,
-                     fidString,fidInt,fidFloat,fidVar,fidStart,
-
-                     -- * Byte code
                      CodeLabel, Instr(..), IVal(..), TailInfo(..),
-
-                     unionPGF, writeConcr
                     ) where
 
-import PGF2.FFI
 import PGF2.Expr
 
-type FId = Int
-
-fidString, fidInt, fidFloat, fidVar, fidStart :: FId
-fidString = (-1)
-fidInt    = (-2)
-fidFloat  = (-3)
-fidVar    = (-4)
-fidStart  = (-5)
-
-isPredefFId :: FId -> Bool
-isPredefFId = (`elem` [fidString, fidInt, fidFloat, fidVar])
-
 type CodeLabel = Int
 
 data Instr
@@ -60,9 +39,3 @@ data TailInfo
   = RecCall
   | TailCall {-# UNPACK #-} !Int
   | UpdateCall
-
-unionPGF :: PGF -> PGF -> Maybe PGF
-unionPGF = error "TODO: unionPGF"
-
-writeConcr :: FilePath -> Concr -> IO ()
-writeConcr = error "TODO: writeConcr"

src/runtime/haskell/PGF2/FFI.hsc

@@ -151,7 +151,7 @@ foreign import ccall pgf_commit_revision :: Ptr PgfDB -> Ptr PGF -> Ptr PgfExn -
 
 foreign import ccall pgf_checkout_revision :: Ptr PgfDB -> Ptr PgfText -> Ptr PgfExn -> IO (Ptr PGF)
 
-foreign import ccall pgf_create_function :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> StablePtr Type -> CSize -> (#type prob_t) -> Ptr PgfMarshaller -> Ptr PgfExn -> IO ()
+foreign import ccall pgf_create_function :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> StablePtr Type -> CSize -> Ptr CChar -> (#type prob_t) -> Ptr PgfMarshaller -> Ptr PgfExn -> IO ()
 
 foreign import ccall pgf_drop_function :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr PgfExn -> IO ()
 

src/runtime/haskell/PGF2/Transactions.hsc

@@ -28,6 +28,7 @@ module PGF2.Transactions
 
 import PGF2.FFI
 import PGF2.Expr
+import PGF2.ByteCode
 
 import Foreign
 import Foreign.C
@@ -123,12 +124,13 @@ checkoutPGF p name =
               langs <- getConcretes (a_db p) fptr
               return (Just (PGF (a_db p) fptr langs))
 
-createFunction :: Fun -> Type -> Int -> Float -> Transaction PGF ()
+createFunction :: Fun -> Type -> Int -> [[Instr]] -> Float -> Transaction PGF ()
-createFunction name ty arity prob = Transaction $ \c_db _ c_revision c_exn ->
+createFunction name ty arity bytecode prob = Transaction $ \c_db _ c_revision c_exn ->
   withText name $ \c_name ->
   bracket (newStablePtr ty) freeStablePtr $ \c_ty ->
+  (if null bytecode then (\f -> f nullPtr) else (allocaBytes 0)) $ \c_bytecode ->
   withForeignPtr marshaller $ \m -> do
-    pgf_create_function c_db c_revision c_name c_ty (fromIntegral arity) prob m c_exn
+    pgf_create_function c_db c_revision c_name c_ty (fromIntegral arity) c_bytecode prob m c_exn
 
 dropFunction :: Fun -> Transaction PGF ()
 dropFunction name = Transaction $ \c_db _ c_revision c_exn ->

src/runtime/haskell/pgf2.cabal

@@ -23,7 +23,7 @@ library
   exposed-modules:
     PGF2,
     PGF2.Transactions,
-    PGF2.Internal,
+    PGF2.ByteCode,
     -- backwards compatibility API:
     PGF
   other-modules:

src/runtime/haskell/tests/basic_cnc.gf

@@ -0,0 +1,19 @@
+concrete basic_cnc of basic = open Prelude in {
+
+lincat N = {s : Str; is_zero : Bool} ;
+lincat S = Str ;
+
+lin z = {s="0"; is_zero=True} ;
+    s n = {
+      s = case n.is_zero of {
+            True  => "1" ;
+            False => n.s ++ "+" ++ "1"
+          } ;
+      is_zero = False
+    } ;
+
+lin c n = n.s ;
+
+lincat P = {};
+
+}

src/runtime/haskell/tests/transactions.hs

@@ -9,9 +9,9 @@ main = do
   gr1 <- readPGF "tests/basic.pgf"
   let Just ty = readType "(N -> N) -> P (s z)"
 
-  gr2 <- modifyPGF gr1              (createFunction "foo" ty 0 pi >>
+  gr2 <- modifyPGF gr1              (createFunction "foo" ty 0 [] pi >>
                                      createCategory "Q" [(Explicit,"x",ty)] pi)
-  gr3 <- branchPGF gr1 "bar_branch" (createFunction "bar" ty 0 pi >>
+  gr3 <- branchPGF gr1 "bar_branch" (createFunction "bar" ty 0 [] pi >>
                                      createCategory "R" [(Explicit,"x",ty)] pi)
 
   Just gr4 <- checkoutPGF gr1 "master"
@@ -44,8 +44,8 @@ main = do
       ,TestCase (assertEqual "new function prob" pi        (functionProbability gr2 "foo"))
       ,TestCase (assertEqual "old category prob" (-log 0)  (categoryProbability gr1 "Q"))
       ,TestCase (assertEqual "new category prob" pi        (categoryProbability gr2 "Q"))
-      ,TestCase (assertEqual "empty concretes" []          (Map.keys (languages gr1)))
+      ,TestCase (assertEqual "empty concretes" ["basic_cnc"] (Map.keys (languages gr1)))
-      ,TestCase (assertEqual "extended concretes" ["basic_eng"] (Map.keys (languages gr7)))
+      ,TestCase (assertEqual "extended concretes" ["basic_cnc","basic_eng"] (Map.keys (languages gr7)))
       ,TestCase (assertEqual "added concrete flag" (Just (LStr "test")) (concreteFlag cnc "test_flag"))
       ]
 

src/runtime/python/transactions.c

@@ -149,7 +149,7 @@ Transaction_createFunction(TransactionObject *self, PyObject *args)
     PgfText *funname = CString_AsPgfText(s, size);
 
     PgfExn err;
-    pgf_create_function(self->pgf->db, self->revision, funname, (PgfType) type, arity, prob, &marshaller, &err);
+    pgf_create_function(self->pgf->db, self->revision, funname, (PgfType) type, arity, NULL, prob, &marshaller, &err);
     FreePgfText(funname);
     if (handleError(err) != PGF_EXN_NONE) {
         return NULL;