Rename modules GFI, GFC & GFServer...

... to GF.Interactive, GF.Compiler & GF.Server, respectively.

1 files changed, 143 insertions, 0 deletions

diff --git a/src/compiler/GF/Compiler.hs b/src/compiler/GF/Compiler.hs
new file mode 100644
index 000000000..3be8c6e14
--- /dev/null
+++ b/src/compiler/GF/Compiler.hs
@@ -0,0 +1,143 @@
+module GF.Compiler (mainGFC, writePGF) where
+
+import PGF
+import PGF.Internal(concretes,optimizePGF,unionPGF)
+import PGF.Internal(putSplitAbs,encodeFile,runPut)
+import GF.Compile as S(batchCompile,link,srcAbsName)
+import qualified GF.CompileInParallel as P(batchCompile)
+import GF.Compile.Export
+import GF.Compile.CFGtoPGF
+import GF.Compile.GetGrammar
+import GF.Grammar.CFG
+
+import GF.Infra.Ident(showIdent)
+import GF.Infra.UseIO
+import GF.Infra.Option
+import GF.Data.ErrM
+import GF.System.Directory
+
+import Data.Maybe
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import qualified Data.ByteString.Lazy as BSL
+import System.FilePath
+import Control.Monad(unless,forM_)
+
+mainGFC :: Options -> [FilePath] -> IO ()
+mainGFC opts fs = do
+  r <- appIOE (case () of
+                 _ | null fs -> fail $ "No input files."
+                 _ | all (extensionIs ".cf")  fs -> compileCFFiles opts fs
+                 _ | all (\f -> extensionIs ".gf" f || extensionIs ".gfo" f)  fs -> compileSourceFiles opts fs
+                 _ | all (extensionIs ".pgf") fs -> unionPGFFiles opts fs
+                 _ -> fail $ "Don't know what to do with these input files: " ++ unwords fs)
+  case r of
+    Ok x    -> return x
+    Bad msg -> die $ if flag optVerbosity opts == Normal
+                       then ('\n':msg)
+                       else msg
+ where
+   extensionIs ext = (== ext) .  takeExtension
+
+compileSourceFiles :: Options -> [FilePath] -> IOE ()
+compileSourceFiles opts fs = 
+    do (t_src,~cnc_grs@(~(cnc,gr):_)) <- batchCompile opts fs
+       unless (flag optStopAfterPhase opts == Compile) $
+              do let abs = showIdent (srcAbsName gr cnc)
+                     pgfFile = outputPath opts (grammarName' opts abs<.>"pgf")
+                 t_pgf <- if outputJustPGF opts
+                          then maybeIO $ getModificationTime pgfFile
+                          else return Nothing
+                 if t_pgf >= Just t_src
+                   then putIfVerb opts $ pgfFile ++ " is up-to-date."
+                   else do pgfs <- mapM (link opts)
+                                        [(cnc,t_src,gr)|(cnc,gr)<-cnc_grs]
+                           let pgf = foldl1 unionPGF pgfs
+                           writePGF opts pgf
+                           writeOutputs opts pgf
+  where
+    batchCompile = maybe batchCompile' P.batchCompile (flag optJobs opts)
+    batchCompile' opts fs = do (cnc,t,gr) <- S.batchCompile opts fs
+                               return (t,[(cnc,gr)])
+
+compileCFFiles :: Options -> [FilePath] -> IOE ()
+compileCFFiles opts fs = do
+  rules <- fmap concat $ mapM (getCFRules opts) fs
+  startCat <- case rules of
+                (CFRule cat _ _ : _) -> return cat
+                _                    -> fail "empty CFG"
+  let pgf = cf2pgf (last fs) (uniqueFuns (mkCFG startCat Set.empty rules))
+  let cnc = justModuleName (last fs)
+  unless (flag optStopAfterPhase opts == Compile) $
+     do probs <- liftIO (maybe (return . defaultProbabilities) readProbabilitiesFromFile (flag optProbsFile opts) pgf)
+        let pgf' = setProbabilities probs $ if flag optOptimizePGF opts then optimizePGF pgf else pgf
+        writePGF opts pgf'
+        writeOutputs opts pgf'
+
+unionPGFFiles :: Options -> [FilePath] -> IOE ()
+unionPGFFiles opts fs =
+    if outputJustPGF opts
+    then maybe doIt checkFirst (flag optName opts)
+    else doIt
+  where
+    checkFirst name =
+      do let pgfFile = outputPath opts (name <.> "pgf")
+         sourceTime <- maximum `fmap` mapM getModificationTime fs
+         targetTime <- maybeIO $ getModificationTime pgfFile
+         if targetTime >= Just sourceTime
+           then putIfVerb opts $ pgfFile ++ " is up-to-date."
+           else doIt
+
+    doIt =
+      do pgfs <- mapM readPGFVerbose fs
+         let pgf0 = foldl1 unionPGF pgfs
+             pgf  = if flag optOptimizePGF opts then optimizePGF pgf0 else pgf0
+             pgfFile = outputPath opts (grammarName opts pgf <.> "pgf")
+         if pgfFile `elem` fs
+           then putStrLnE $ "Refusing to overwrite " ++ pgfFile
+           else writePGF opts pgf
+         writeOutputs opts pgf
+
+    readPGFVerbose f =
+        putPointE Normal opts ("Reading " ++ f ++ "...") $ liftIO $ readPGF f
+
+writeOutputs :: Options -> PGF -> IOE ()
+writeOutputs opts pgf = do
+  sequence_ [writeOutput opts name str 
+                 | fmt <- outputFormats opts,
+                   (name,str) <- exportPGF opts fmt pgf]
+
+writePGF :: Options -> PGF -> IOE ()
+writePGF opts pgf =
+    if flag optSplitPGF opts then writeSplitPGF else writeNormalPGF
+  where
+    writeNormalPGF =
+       do let outfile = outputPath opts (grammarName opts pgf <.> "pgf")
+          writing opts outfile $ encodeFile outfile pgf
+
+    writeSplitPGF =
+      do let outfile = outputPath opts (grammarName opts pgf <.> "pgf")
+         writing opts outfile $ BSL.writeFile outfile (runPut (putSplitAbs pgf))
+                                --encodeFile_ outfile (putSplitAbs pgf)
+         forM_ (Map.toList (concretes pgf)) $ \cnc -> do
+           let outfile = outputPath opts (showCId (fst cnc) <.> "pgf_c")
+           writing opts outfile $ encodeFile outfile cnc
+
+
+writeOutput :: Options -> FilePath-> String -> IOE ()
+writeOutput opts file str = writing opts path $ writeUTF8File path str
+  where path = outputPath opts file
+
+-- * Useful helper functions
+
+grammarName :: Options -> PGF -> String
+grammarName opts pgf = grammarName' opts (showCId (abstractName pgf))
+grammarName' opts abs = fromMaybe abs (flag optName opts)
+
+outputFormats opts = [fmt | fmt <- flag optOutputFormats opts, fmt/=FmtByteCode]
+outputJustPGF opts = null (flag optOutputFormats opts) && not (flag optSplitPGF opts)
+
+outputPath opts file = maybe id (</>) (flag optOutputDir opts) file
+
+writing opts path io =
+    putPointE Normal opts ("Writing " ++ path ++ "...") $ liftIO io