Add flag and stubs for compiling to LPGF format

gf.cabal

@@ -184,6 +184,7 @@ Library
     GF.Compile.Export
     GF.Compile.GenerateBC
     GF.Compile.GeneratePMCFG
+    GF.Compile.GrammarToLPGF
     GF.Compile.GrammarToPGF
     GF.Compile.Multi
     GF.Compile.Optimize

src/compiler/GF/Compile.hs

@@ -1,6 +1,7 @@
-module GF.Compile (compileToPGF, link, batchCompile, srcAbsName) where
+module GF.Compile (compileToPGF, link, linkl, batchCompile, srcAbsName) where
 
 import GF.Compile.GrammarToPGF(mkCanon2pgf)
+import GF.Compile.GrammarToLPGF(mkCanon2lpgf)
 import GF.Compile.ReadFiles(ModEnv,getOptionsFromFile,getAllFiles,
                             importsOfModule)
 import GF.CompileOne(compileOne)
@@ -42,6 +43,13 @@ link opts (cnc,gr) =
     return $ setProbabilities probs
            $ if flag optOptimizePGF opts then optimizePGF pgf else pgf
 
+linkl :: Options -> (ModuleName,Grammar) -> IOE PGF
+linkl opts (cnc,gr) =
+  putPointE Normal opts "linking ... " $ do
+    let abs = srcAbsName gr cnc
+    lpgf <- mkCanon2lpgf opts gr abs
+    return lpgf
+
 -- | Returns the name of the abstract syntax corresponding to the named concrete syntax
 srcAbsName gr cnc = err (const cnc) id $ abstractOfConcrete gr cnc
 

src/compiler/GF/Compile/GrammarToLPGF.hs

@@ -0,0 +1,308 @@
+{-# LANGUAGE BangPatterns, FlexibleContexts #-}
+module GF.Compile.GrammarToLPGF (mkCanon2lpgf) where
+
+--import GF.Compile.Export
+import GF.Compile.GeneratePMCFG
+import GF.Compile.GenerateBC
+
+import PGF(CId,mkCId,utf8CId)
+import PGF.Internal(fidInt,fidFloat,fidString,fidVar)
+import PGF.Internal(updateProductionIndices)
+import qualified PGF.Internal as C
+import qualified PGF.Internal as D
+import GF.Grammar.Predef
+import GF.Grammar.Grammar
+import qualified GF.Grammar.Lookup as Look
+import qualified GF.Grammar as A
+import qualified GF.Grammar.Macros as GM
+
+import GF.Infra.Ident
+import GF.Infra.Option
+import GF.Infra.UseIO (IOE)
+import GF.Data.Operations
+
+import Data.List
+import qualified Data.Set as Set
+import qualified Data.Map as Map
+import qualified Data.IntMap as IntMap
+import Data.Array.IArray
+
+
+mkCanon2lpgf :: Options -> SourceGrammar -> ModuleName -> IOE D.PGF
+mkCanon2lpgf opts gr am = do
+  (an,abs) <- mkAbstr am
+  cncs     <- mapM mkConcr (allConcretes gr am)
+  return $ updateProductionIndices (D.PGF Map.empty an abs (Map.fromList cncs))
+  where
+    cenv = resourceValues opts gr
+
+    mkAbstr am = return (mi2i am, D.Abstr flags funs cats)
+      where
+        aflags = err (const noOptions) mflags (lookupModule gr am)
+
+        adefs =
+            [((cPredefAbs,c), AbsCat (Just (L NoLoc []))) | c <- [cFloat,cInt,cString]] ++
+            Look.allOrigInfos gr am
+
+        flags = Map.fromList [(mkCId f,x) | (f,x) <- optionsPGF aflags]
+
+        funs = Map.fromList [(i2i f, (mkType [] ty, arity, mkDef gr arity mdef, 0)) |
+                                   ((m,f),AbsFun (Just (L _ ty)) ma mdef _) <- adefs,
+                                   let arity = mkArity ma mdef ty]
+
+        cats = Map.fromList [(i2i c, (snd (mkContext [] cont),catfuns c, 0)) |
+                                   ((m,c),AbsCat (Just (L _ cont))) <- adefs]
+
+        catfuns cat =
+              [(0,i2i f) | ((m,f),AbsFun (Just (L _ ty)) _ _ (Just True)) <- adefs, snd (GM.valCat ty) == cat]
+
+    mkConcr cm = do
+      let cflags = err (const noOptions) mflags (lookupModule gr cm)
+          ciCmp | flag optCaseSensitive cflags = compare
+                | otherwise                    = C.compareCaseInsensitve
+
+      (ex_seqs,cdefs) <- addMissingPMCFGs
+                            Map.empty
+                            ([((cPredefAbs,c), CncCat (Just (L NoLoc GM.defLinType)) Nothing Nothing Nothing Nothing) | c <- [cInt,cFloat,cString]] ++
+                             Look.allOrigInfos gr cm)
+
+      let flags = Map.fromList [(mkCId f,x) | (f,x) <- optionsPGF cflags]
+
+          seqs = (mkArray . C.sortNubBy ciCmp . concat) $
+                     (Map.keys ex_seqs : [maybe [] elems (mseqs mi) | (m,mi) <- allExtends gr cm])
+
+          ex_seqs_arr = mkMapArray ex_seqs :: Array SeqId Sequence
+
+          !(!fid_cnt1,!cnccats) = genCncCats gr am cm cdefs
+          !(!fid_cnt2,!productions,!lindefs,!linrefs,!cncfuns)
+                                = genCncFuns gr am cm ex_seqs_arr ciCmp seqs cdefs fid_cnt1 cnccats
+
+          printnames = genPrintNames cdefs
+      return (mi2i cm, D.Concr flags
+                              printnames
+                              cncfuns
+                              lindefs
+                              linrefs
+                              seqs
+                              productions
+                              IntMap.empty
+                              Map.empty
+                              cnccats
+                              IntMap.empty
+                              fid_cnt2)
+      where
+        -- if some module was compiled with -no-pmcfg, then
+        -- we have to create the PMCFG code just before linking
+        addMissingPMCFGs seqs []                  = return (seqs,[])
+        addMissingPMCFGs seqs (((m,id), info):is) = do
+          (seqs,info) <- addPMCFG opts gr cenv Nothing am cm seqs id info
+          (seqs,is  ) <- addMissingPMCFGs seqs is
+          return (seqs, ((m,id), info) : is)
+
+i2i :: Ident -> CId
+i2i = utf8CId . ident2utf8
+
+mi2i :: ModuleName -> CId
+mi2i (MN i) = i2i i
+
+mkType :: [Ident] -> A.Type -> C.Type
+mkType scope t =
+  case GM.typeForm t of
+    (hyps,(_,cat),args) -> let (scope',hyps') = mkContext scope hyps
+                           in C.DTyp hyps' (i2i cat) (map (mkExp scope') args)
+
+mkExp :: [Ident] -> A.Term -> C.Expr
+mkExp scope t =
+  case t of
+    Q (_,c)  -> C.EFun (i2i c)
+    QC (_,c) -> C.EFun (i2i c)
+    Vr x     -> case lookup x (zip scope [0..]) of
+                  Just i  -> C.EVar  i
+                  Nothing -> C.EMeta 0
+    Abs b x t-> C.EAbs b (i2i x) (mkExp (x:scope) t)
+    App t1 t2-> C.EApp (mkExp scope t1) (mkExp scope t2)
+    EInt i   -> C.ELit (C.LInt (fromIntegral i))
+    EFloat f -> C.ELit (C.LFlt f)
+    K s      -> C.ELit (C.LStr s)
+    Meta i   -> C.EMeta i
+    _        -> C.EMeta 0
+
+mkPatt scope p =
+  case p of
+    A.PP (_,c) ps->let (scope',ps') = mapAccumL mkPatt scope ps
+                   in (scope',C.PApp (i2i c) ps')
+    A.PV x      -> (x:scope,C.PVar (i2i x))
+    A.PAs x p   -> let (scope',p') = mkPatt scope p
+                   in (x:scope',C.PAs (i2i x) p')
+    A.PW        -> (  scope,C.PWild)
+    A.PInt i    -> (  scope,C.PLit (C.LInt (fromIntegral i)))
+    A.PFloat f  -> (  scope,C.PLit (C.LFlt f))
+    A.PString s -> (  scope,C.PLit (C.LStr s))
+    A.PImplArg p-> let (scope',p') = mkPatt scope p
+                   in (scope',C.PImplArg p')
+    A.PTilde t  -> (  scope,C.PTilde (mkExp scope t))
+
+mkContext :: [Ident] -> A.Context -> ([Ident],[C.Hypo])
+mkContext scope hyps = mapAccumL (\scope (bt,x,ty) -> let ty' = mkType scope ty
+                                                      in if x == identW
+                                                           then (  scope,(bt,i2i x,ty'))
+                                                           else (x:scope,(bt,i2i x,ty'))) scope hyps
+
+mkDef gr arity (Just eqs) = Just ([C.Equ ps' (mkExp scope' e) | L _ (ps,e) <- eqs, let (scope',ps') = mapAccumL mkPatt [] ps]
+                                 ,generateByteCode gr arity eqs
+                                 )
+mkDef gr arity Nothing    = Nothing
+
+mkArity (Just a) _        ty = a   -- known arity, i.e. defined function
+mkArity Nothing  (Just _) ty = 0   -- defined function with no arity - must be an axiom
+mkArity Nothing  _        ty = let (ctxt, _, _) = GM.typeForm ty  -- constructor
+                               in length ctxt
+
+genCncCats gr am cm cdefs =
+  let (index,cats) = mkCncCats 0 cdefs
+  in (index, Map.fromList cats)
+  where
+    mkCncCats index []                                                = (index,[])
+    mkCncCats index (((m,id),CncCat (Just (L _ lincat)) _ _ _ _):cdefs)
+      | id == cInt    =
+            let cc            = pgfCncCat gr lincat fidInt
+                (index',cats) = mkCncCats index cdefs
+            in (index', (i2i id,cc) : cats)
+      | id == cFloat  =
+            let cc            = pgfCncCat gr lincat fidFloat
+                (index',cats) = mkCncCats index cdefs
+            in (index', (i2i id,cc) : cats)
+      | id == cString =
+            let cc            = pgfCncCat gr lincat fidString
+                (index',cats) = mkCncCats index cdefs
+            in (index', (i2i id,cc) : cats)
+      | otherwise     =
+            let cc@(C.CncCat _s e _) = pgfCncCat gr lincat index
+                (index',cats)        = mkCncCats (e+1) cdefs
+            in (index', (i2i id,cc) : cats)
+    mkCncCats index (_                      :cdefs) = mkCncCats index cdefs
+
+genCncFuns :: Grammar
+           -> ModuleName
+           -> ModuleName
+           -> Array SeqId Sequence
+           -> (Sequence -> Sequence -> Ordering)
+           -> Array SeqId Sequence
+           -> [(QIdent, Info)]
+           -> FId
+           -> Map.Map CId D.CncCat
+           -> (FId,
+               IntMap.IntMap (Set.Set D.Production),
+               IntMap.IntMap [FunId],
+               IntMap.IntMap [FunId],
+               Array FunId D.CncFun)
+genCncFuns gr am cm ex_seqs ciCmp seqs cdefs fid_cnt cnccats =
+  let (fid_cnt1,funs_cnt1,funs1,lindefs,linrefs) = mkCncCats cdefs fid_cnt  0 [] IntMap.empty IntMap.empty
+      (fid_cnt2,funs_cnt2,funs2,prods)           = mkCncFuns cdefs fid_cnt1 funs_cnt1 funs1 lindefs Map.empty IntMap.empty
+  in (fid_cnt2,prods,lindefs,linrefs,array (0,funs_cnt2-1) funs2)
+  where
+    mkCncCats []                                                        fid_cnt funs_cnt funs lindefs linrefs =
+      (fid_cnt,funs_cnt,funs,lindefs,linrefs)
+    mkCncCats (((m,id),CncCat _ _ _ _ (Just (PMCFG prods0 funs0))):cdefs) fid_cnt funs_cnt funs lindefs linrefs =
+      let !funs_cnt' = let (s_funid, e_funid) = bounds funs0
+                       in funs_cnt+(e_funid-s_funid+1)
+          lindefs'   = foldl' (toLinDef (am,id) funs_cnt) lindefs prods0
+          linrefs'   = foldl' (toLinRef (am,id) funs_cnt) linrefs prods0
+          funs'      = foldl' (toCncFun funs_cnt (m,mkLinDefId id)) funs (assocs funs0)
+      in mkCncCats cdefs fid_cnt funs_cnt' funs' lindefs' linrefs'
+    mkCncCats (_                                                :cdefs) fid_cnt funs_cnt funs lindefs linrefs =
+      mkCncCats cdefs fid_cnt funs_cnt funs lindefs linrefs
+
+    mkCncFuns []                                                        fid_cnt funs_cnt funs lindefs crc prods =
+      (fid_cnt,funs_cnt,funs,prods)
+    mkCncFuns (((m,id),CncFun _ _ _ (Just (PMCFG prods0 funs0))):cdefs) fid_cnt funs_cnt funs lindefs crc prods =
+      let ---Ok ty_C        = fmap GM.typeForm (Look.lookupFunType gr am id)
+          ty_C           = err error (\x -> x) $ fmap GM.typeForm (Look.lookupFunType gr am id)
+          !funs_cnt'     = let (s_funid, e_funid) = bounds funs0
+                           in funs_cnt+(e_funid-s_funid+1)
+          !(fid_cnt',crc',prods')
+                         = foldl' (toProd lindefs ty_C funs_cnt)
+                                  (fid_cnt,crc,prods) prods0
+          funs'          = foldl' (toCncFun funs_cnt (m,id)) funs (assocs funs0)
+      in mkCncFuns cdefs fid_cnt' funs_cnt' funs' lindefs crc' prods'
+    mkCncFuns (_                                                :cdefs) fid_cnt funs_cnt funs lindefs crc prods =
+      mkCncFuns cdefs fid_cnt funs_cnt funs lindefs crc prods
+
+    toProd lindefs (ctxt_C,res_C,_) offs st (Production fid0 funid0 args0) =
+      let !((fid_cnt,crc,prods),args) = mapAccumL mkArg st (zip ctxt_C args0)
+          set0    = Set.fromList (map (C.PApply (offs+funid0)) (sequence args))
+          fid     = mkFId res_C fid0
+          !prods' = case IntMap.lookup fid prods of
+                     Just set -> IntMap.insert fid (Set.union set0 set) prods
+                     Nothing  -> IntMap.insert fid set0 prods
+      in (fid_cnt,crc,prods')
+      where
+        mkArg st@(fid_cnt,crc,prods) ((_,_,ty),fid0s ) =
+          case fid0s of
+            [fid0] -> (st,map (flip C.PArg (mkFId arg_C fid0)) ctxt)
+            fid0s  -> case Map.lookup fids crc of
+                        Just fid -> (st,map (flip C.PArg fid) ctxt)
+                        Nothing  -> let !crc'   = Map.insert fids fid_cnt crc
+                                        !prods' = IntMap.insert fid_cnt (Set.fromList (map C.PCoerce fids)) prods
+                                    in ((fid_cnt+1,crc',prods'),map (flip C.PArg fid_cnt) ctxt)
+          where
+            (hargs_C,arg_C) = GM.catSkeleton ty
+            ctxt = mapM (mkCtxt lindefs) hargs_C
+            fids = map (mkFId arg_C) fid0s
+
+    mkLinDefId id = prefixIdent "lindef " id
+
+    toLinDef res offs lindefs (Production fid0 funid0 args) =
+      if args == [[fidVar]]
+        then IntMap.insertWith (++) fid [offs+funid0] lindefs
+        else lindefs
+      where
+        fid = mkFId res fid0
+
+    toLinRef res offs linrefs (Production fid0 funid0 [fargs]) =
+      if fid0 == fidVar
+        then foldr (\fid -> IntMap.insertWith (++) fid [offs+funid0]) linrefs fids
+        else linrefs
+      where
+        fids = map (mkFId res) fargs
+
+    mkFId (_,cat) fid0 =
+      case Map.lookup (i2i cat) cnccats of
+        Just (C.CncCat s e _) -> s+fid0
+        Nothing               -> error ("GrammarToPGF.mkFId: missing category "++showIdent cat)
+
+    mkCtxt lindefs (_,cat) =
+      case Map.lookup (i2i cat) cnccats of
+        Just (C.CncCat s e _) -> [(C.fidVar,fid) | fid <- [s..e], Just _ <- [IntMap.lookup fid lindefs]]
+        Nothing               -> error "GrammarToPGF.mkCtxt failed"
+
+    toCncFun offs (m,id) funs (funid0,lins0) =
+      let mseqs = case lookupModule gr m of
+                    Ok (ModInfo{mseqs=Just mseqs}) -> mseqs
+                    _                              -> ex_seqs
+      in (offs+funid0,C.CncFun (i2i id) (amap (newIndex mseqs) lins0)):funs
+      where
+        newIndex mseqs i = binSearch (mseqs ! i) seqs (bounds seqs)
+
+        binSearch v arr (i,j)
+          | i <= j    = case ciCmp v (arr ! k) of
+                          LT -> binSearch v arr (i,k-1)
+                          EQ -> k
+                          GT -> binSearch v arr (k+1,j)
+          | otherwise = error "binSearch"
+          where
+            k = (i+j) `div` 2
+
+genPrintNames cdefs =
+  Map.fromAscList [(i2i id, name) | ((m,id),info) <- cdefs, name <- prn info]
+  where
+    prn (CncFun _ _   (Just (L _ tr)) _) = [flatten tr]
+    prn (CncCat _ _ _ (Just (L _ tr)) _) = [flatten tr]
+    prn _                                = []
+
+    flatten (K s)      = s
+    flatten (Alts x _) = flatten x
+    flatten (C x y)    = flatten x +++ flatten y
+
+mkArray    lst = listArray (0,length lst-1) lst
+mkMapArray map = array (0,Map.size map-1) [(v,k) | (k,v) <- Map.toList map]

src/compiler/GF/Compiler.hs

@@ -3,7 +3,7 @@ module GF.Compiler (mainGFC, linkGrammars, writePGF, writeOutputs) where
 import PGF
 import PGF.Internal(concretes,optimizePGF,unionPGF)
 import PGF.Internal(putSplitAbs,encodeFile,runPut)
-import GF.Compile as S(batchCompile,link,srcAbsName)
+import GF.Compile as S(batchCompile,link,linkl,srcAbsName)
 import GF.CompileInParallel as P(parallelBatchCompile)
 import GF.Compile.Export
 import GF.Compile.ConcreteToHaskell(concretes2haskell)
@@ -11,7 +11,8 @@ import GF.Compile.GrammarToCanonical--(concretes2canonical)
 import GF.Compile.CFGtoPGF
 import GF.Compile.GetGrammar
 import GF.Grammar.BNFC
-import GF.Grammar.CFG
+import GF.Grammar.CFG hiding (Grammar)
+import GF.Grammar.Grammar (Grammar, ModuleName)
 
 --import GF.Infra.Ident(showIdent)
 import GF.Infra.UseIO
@@ -23,6 +24,7 @@ import GF.Text.Pretty(render,render80)
 import Data.Maybe
 import qualified Data.Map as Map
 import qualified Data.Set as Set
+import Data.Time(UTCTime)
 import qualified Data.ByteString.Lazy as BSL
 import GF.Grammar.CanonicalJSON (encodeJSON)
 import System.FilePath
@@ -93,6 +95,12 @@ compileSourceFiles opts fs =
 -- If a @.pgf@ file by the same name already exists and it is newer than the
 -- source grammar files (as indicated by the 'UTCTime' argument), it is not
 -- recreated. Calls 'writePGF' and 'writeOutputs'.
+linkGrammars :: Options -> (UTCTime,[(ModuleName, Grammar)]) -> IOE ()
+linkGrammars opts (_,cnc_grs) | FmtLPGF `elem` flag optOutputFormats opts = do
+  pgfs <- mapM (linkl opts) cnc_grs
+  let pgf0 = foldl1 unionPGF pgfs
+  writePGF opts pgf0
+  putStrLn "LPGF"
 linkGrammars opts (t_src,~cnc_grs@(~(cnc,gr):_)) =
     do let abs = render (srcAbsName gr cnc)
            pgfFile = outputPath opts (grammarName' opts abs<.>"pgf")

src/compiler/GF/Infra/Option.hs

@@ -87,7 +87,8 @@ data Verbosity = Quiet | Normal | Verbose | Debug
 data Phase = Preproc | Convert | Compile | Link
   deriving (Show,Eq,Ord)
 
-data OutputFormat = FmtPGFPretty
+data OutputFormat = FmtLPGF
+                  | FmtPGFPretty
                   | FmtCanonicalGF
                   | FmtCanonicalJson
                   | FmtJavaScript
@@ -330,7 +331,7 @@ optDescr =
      Option ['f'] ["output-format"] (ReqArg outFmt "FMT")
         (unlines ["Output format. FMT can be one of:",
                   "Canonical GF grammar: canonical_gf, canonical_json, (and haskell with option --haskell=concrete)",
-                  "Multiple concrete: pgf (default), json, js, pgf_pretty, prolog, python, ...", -- gar,
+                  "Multiple concrete: pgf (default), lpgf, json, js, pgf_pretty, prolog, python, ...", -- gar,
                   "Single concrete only: bnf, ebnf, fa, gsl, jsgf, regexp, slf, srgs_xml, srgs_abnf, vxml, ....", -- cf, lbnf,
                   "Abstract only: haskell, ..."]), -- prolog_abs,
      Option [] ["sisr"] (ReqArg sisrFmt "FMT")
@@ -472,7 +473,8 @@ outputFormats = map fst outputFormatsExpl
 
 outputFormatsExpl :: [((String,OutputFormat),String)]
 outputFormatsExpl =
-    [(("pgf_pretty",   FmtPGFPretty),"human-readable pgf"),
+    [(("lpgf",         FmtLPGF),"Linearisation-only PGF"),
+     (("pgf_pretty",   FmtPGFPretty),"Human-readable PGF"),
      (("canonical_gf", FmtCanonicalGF),"Canonical GF source files"),
      (("canonical_json", FmtCanonicalJson),"Canonical JSON source files"),
      (("js",           FmtJavaScript),"JavaScript (whole grammar)"),