.gfo files in binary format

src/GF/Compile.hs

@@ -20,6 +20,7 @@ import GF.Text.UTF8 ----
 import GF.Grammar.Grammar
 import GF.Grammar.Lookup
 import GF.Grammar.PrGrammar
+import GF.Grammar.Binary
 
 import GF.Infra.Ident
 import GF.Infra.Option
@@ -39,6 +40,7 @@ import qualified Data.Map as Map
 import qualified Data.Set as Set
 import Data.List(nub)
 import Data.Maybe (isNothing)
+import Data.Binary
 
 import PGF.Check
 import PGF.CId
@@ -147,8 +149,7 @@ compileOne opts env@(_,srcgr,_) file = do
     -- for compiled gf, read the file and update environment
     -- also undo common subexp optimization, to enable normal computations
     ".gfo" -> do
-       sm00 <- putPointE Normal opts ("+ reading" +++ file) $ getSourceModule opts file
+       sm0 <- putPointE Normal opts ("+ reading" +++ file) $ ioeIO (decodeFile file)
-       let sm0 = codeSourceModule decodeUTF8 sm00 -- always UTF8 in gfo
        let sm1 = unsubexpModule sm0
        sm <- {- putPointE Normal opts "creating indirections" $ -} ioeErr $ extendModule mos sm1
        
@@ -213,8 +214,10 @@ compileSourceModule opts env@(k,gr,_) mo@(i,mi) = do
 generateModuleCode :: Options -> FilePath -> SourceModule -> IOE SourceModule
 generateModuleCode opts file minfo = do
   let minfo1 = subexpModule minfo
-      out    = codeStringLiterals encodeUTF8 $ prGrammar (MGrammar [minfo1])
+      minfo2 = case minfo1 of
-  putPointE Normal opts ("  wrote file" +++ file) $ ioeIO $ writeFile file $ out
+                 (m,mi) -> (m,mi{jments=Map.filter (\x -> case x of {AnyInd _ _ -> False; _ -> True}) (jments mi)
+                                , positions=Map.empty})
+  putPointE Normal opts ("  wrote file" +++ file) $ ioeIO $ encodeFile file minfo2
   return minfo1
 
 -- auxiliaries
@@ -225,7 +228,7 @@ emptyCompileEnv :: CompileEnv
 emptyCompileEnv = (0,emptyMGrammar,Map.empty)
 
 extendCompileEnvInt (_,MGrammar ss,menv) k mfile sm = do
-  let (mod,imps) = importsOfModule (trModule sm)
+  let (mod,imps) = importsOfModule sm
   menv2 <- case mfile of
     Just file -> do
       t <- ioeIO $ getModificationTime file

src/GF/Compile/ReadFiles.hs

@@ -25,10 +25,15 @@ module GF.Compile.ReadFiles
 
 import GF.Infra.UseIO
 import GF.Infra.Option
+import GF.Infra.Ident
+import GF.Infra.Modules
 import GF.Data.Operations
-import GF.Source.AbsGF hiding (FileName)
+import qualified GF.Source.AbsGF as S
 import GF.Source.LexGF
 import GF.Source.ParGF
+import GF.Source.SourceToGrammar(transModDef)
+import GF.Grammar.Grammar
+import GF.Grammar.Binary
 
 import Control.Monad
 import Data.Char
@@ -100,32 +105,32 @@ getAllFiles opts ps env file = do
       let mb_envmod = Map.lookup name env
           (st,t) = selectFormat opts (fmap fst mb_envmod) gfTime gfoTime
 
-      imps <- if st == CSEnv
+      (mname,imps) <- case st of
-                then return (maybe [] snd mb_envmod)
+                        CSEnv  -> return (name, maybe [] snd mb_envmod)
-                else do s <- ioeIO $ BS.readFile file
+                        CSRead -> ioeIO $ fmap importsOfModule (decodeModHeader (replaceExtension file "gfo"))
-                        (mname,imps) <- ioeErr ((liftM (importsOfModule . modHeaderToModDef) . pModHeader . myLexer) s)
+                        CSComp -> do s <- ioeIO $ BS.readFile file
+                                     ioeErr ((liftM (importsOfModule . modHeaderToModDef) . pModHeader . myLexer) s)
       ioeErr $ testErr (mname == name)
                        ("module name" +++ mname +++ "differs from file name" +++ name)
-                        return imps
-
       return (name,st,t,imps,dropFileName file)
 
 -- FIXME: this is pretty ugly, it's just to get around the difference
 -- between ModHeader as returned when parsing just the module header 
 -- when looking for imports, and ModDef, which includes the whole module.
-modHeaderToModDef :: ModHeader -> ModDef
+modHeaderToModDef :: S.ModHeader -> SourceModule
-modHeaderToModDef (MModule2 x y z) = MModule x y (modHeaderBodyToModBody z)
+modHeaderToModDef (S.MModule2 x y z) = 
+  errVal (error "error in modHeaderToModDef") $ transModDef $ S.MModule x y (modHeaderBodyToModBody z)
   where
-    modHeaderBodyToModBody :: ModHeaderBody -> ModBody
+    modHeaderBodyToModBody :: S.ModHeaderBody -> S.ModBody
     modHeaderBodyToModBody b = case b of
-                                 MBody2 x y -> MBody x y []
+                                 S.MBody2 x y -> S.MBody x y []
-                                 MNoBody2 x -> MNoBody x
+                                 S.MNoBody2 x -> S.MNoBody x
-                                 MWith2 x y -> MWith x y
+                                 S.MWith2 x y -> S.MWith x y
-                                 MWithBody2 x y z -> MWithBody x y z []
+                                 S.MWithBody2 x y z -> S.MWithBody x y z []
-                                 MWithE2 x y z -> MWithE x y z
+                                 S.MWithE2 x y z -> S.MWithE x y z
-                                 MWithEBody2 x y z w -> MWithEBody x y z w []
+                                 S.MWithEBody2 x y z w -> S.MWithEBody x y z w []
-                                 MReuse2 x -> MReuse x
+                                 S.MReuse2 x -> S.MReuse x
-                                 MUnion2 x -> MUnion x
+                                 S.MUnion2 x -> S.MUnion x
 
 isGFO :: FilePath -> Bool
 isGFO = (== ".gfo") . takeExtensions
@@ -167,42 +172,35 @@ data CompStatus =
 
 type ModuleInfo = (ModName,CompStatus,Maybe ClockTime,[ModName],InitPath)
 
- 
+importsOfModule :: SourceModule -> (ModName,[ModName])
-importsOfModule :: ModDef -> (ModName,[ModName])
+importsOfModule (m,mi) = (modName m,depModInfo mi [])
-importsOfModule (MModule _ typ body) = modType typ (modBody body [])
   where
-    modType (MTAbstract  m)      xs = (modName m,xs)
+    depModInfo mi =
-    modType (MTResource m)       xs = (modName m,xs)
+      depModType (mtype mi)  .
-    modType (MTInterface m)      xs = (modName m,xs)
+      depExtends (extend mi) .
-    modType (MTConcrete m m2)    xs = (modName m,modName m2:xs)
+      depWith    (mwith mi)  .
-    modType (MTInstance m m2)    xs = (modName m,modName m2:xs)
+      depOpens   (opens mi)
-    modType (MTTransfer m o1 o2) xs = (modName m,open o1 (open o2 xs))
 
-    modBody (MBody e o _)            xs = extend e (opens o xs)
+    depModType (MTAbstract)       xs = xs
-    modBody (MNoBody is)             xs = foldr include xs is
+    depModType (MTResource)       xs = xs
-    modBody (MWith i os)             xs = include i (foldr open xs os)
+    depModType (MTInterface)      xs = xs
-    modBody (MWithBody i os o _)     xs = include i (foldr open (opens o xs) os)
+    depModType (MTConcrete m2)    xs = modName m2:xs
-    modBody (MWithE is i os)         xs = foldr include (include i (foldr open xs os)) is
+    depModType (MTInstance m2)    xs = modName m2:xs
-    modBody (MWithEBody is i os o _) xs = foldr include (include i (foldr open (opens o xs) os)) is
+    depModType (MTTransfer o1 o2) xs = depOpen o1 (depOpen o2 xs)
-    modBody (MReuse m)               xs = modName m:xs
-    modBody (MUnion is)              xs = foldr include xs is
 
-    include (IAll   m)   xs = modName m:xs
+    depExtends es xs = foldr depInclude xs es
-    include (ISome  m _) xs = modName m:xs
-    include (IMinus m _) xs = modName m:xs
 
-    open (OName n)     xs = modName n:xs
+    depWith (Just (m,_,os)) xs = modName m : depOpens os xs
-    open (OQualQO _ n) xs = modName n:xs
+    depWith Nothing         xs = xs
-    open (OQual _ _ n) xs = modName n:xs
 
-    extend NoExt    xs = xs
+    depOpens os xs = foldr depOpen xs os
-    extend (Ext is) xs = foldr include xs is
 
-    opens NoOpens     xs = xs
+    depInclude (m,_) xs = modName m:xs
-    opens (OpenIn os) xs = foldr open xs os
 
-    modName (PIdent (_,s)) = BS.unpack s
+    depOpen (OSimple n  ) xs = modName n:xs
+    depOpen (OQualif _ n) xs = modName n:xs
 
+    modName = prIdent
 
 -- | options can be passed to the compiler by comments in @--#@, in the main file
 getOptionsFromFile :: FilePath -> IOE Options

src/GF/Grammar/Binary.hs

@@ -10,6 +10,7 @@
 module GF.Grammar.Binary where
 
 import Data.Binary
+import qualified Data.Map as Map
 import qualified Data.ByteString.Char8 as BS
 
 import GF.Data.Operations
@@ -260,3 +261,8 @@ instance Binary Label where
 instance Binary MetaSymb where
   put (MetaSymb m) = put m
   get = fmap MetaSymb get
+
+decodeModHeader :: FilePath -> IO SourceModule
+decodeModHeader fpath = do
+  (m,mtype,mstatus,flags,extend,mwith,opens) <- decodeFile fpath
+  return (m,ModInfo mtype mstatus flags extend mwith opens Map.empty Map.empty)