forked from GitHub/gf-core
172 lines
6.7 KiB
Haskell
172 lines
6.7 KiB
Haskell
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.CompileInParallel as P(parallelBatchCompile)
|
||
import GF.Compile.Export
|
||
import GF.Compile.ConcreteToHaskell(concretes2haskell)
|
||
import GF.Compile.CFGtoPGF
|
||
import GF.Compile.GetGrammar
|
||
import GF.Grammar.BNFC
|
||
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 GF.Text.Pretty(render)
|
||
|
||
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(when,unless,forM_)
|
||
|
||
-- | Compile the given GF grammar files. The result is a number of @.gfo@ files
|
||
-- and, depending on the options, a @.pgf@ file. (@gf -batch@, @gf -make@)
|
||
mainGFC :: Options -> [FilePath] -> IO ()
|
||
mainGFC opts fs = do
|
||
r <- tryIOE (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 output <- batchCompile opts fs
|
||
cncs2haskell output
|
||
unless (flag optStopAfterPhase opts == Compile) $
|
||
linkGrammars opts output
|
||
where
|
||
batchCompile = maybe batchCompile' parallelBatchCompile (flag optJobs opts)
|
||
batchCompile' opts fs = do (t,cnc_gr) <- S.batchCompile opts fs
|
||
return (t,[cnc_gr])
|
||
|
||
cncs2haskell output =
|
||
when (FmtHaskell `elem` flag optOutputFormats opts &&
|
||
haskellOption opts HaskellConcrete) $
|
||
mapM_ cnc2haskell (snd output)
|
||
|
||
cnc2haskell (cnc,gr) =
|
||
mapM_ writeHs $ concretes2haskell opts (srcAbsName gr cnc) gr
|
||
|
||
writeHs (path,s) = writing opts path $ writeUTF8File path s
|
||
|
||
|
||
-- | Create a @.pgf@ file (and possibly files in other formats, if specified
|
||
-- in the 'Options') from the output of 'parallelBatchCompile'.
|
||
-- 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 opts (t_src,~cnc_grs@(~(cnc,gr):_)) =
|
||
do let abs = render (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_grs
|
||
let pgf = foldl1 unionPGF pgfs
|
||
writePGF opts pgf
|
||
writeOutputs opts pgf
|
||
|
||
compileCFFiles :: Options -> [FilePath] -> IOE ()
|
||
compileCFFiles opts fs = do
|
||
bnfc_rules <- fmap concat $ mapM (getBNFCRules opts) fs
|
||
let rules = bnfc2cf bnfc_rules
|
||
startCat <- case rules of
|
||
(Rule cat _ _ : _) -> return cat
|
||
_ -> fail "empty CFG"
|
||
let pgf = cf2pgf (last fs) (mkCFG startCat Set.empty rules)
|
||
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
|
||
|
||
-- | Export the PGF to the 'OutputFormat's specified in the 'Options'.
|
||
-- Calls 'exportPGF'.
|
||
writeOutputs :: Options -> PGF -> IOE ()
|
||
writeOutputs opts pgf = do
|
||
sequence_ [writeOutput opts name str
|
||
| fmt <- flag optOutputFormats opts,
|
||
(name,str) <- exportPGF opts fmt pgf]
|
||
|
||
-- | Write the result of compiling a grammar (e.g. with 'compileToPGF' or
|
||
-- 'link') to a @.pgf@ file.
|
||
-- A split PGF file is output if the @-split-pgf@ option is used.
|
||
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)
|
||
|
||
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
|