GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-05-18 07:32:51 -06:00
Code Issues Packages Projects Releases Wiki Activity

make it possible to merge PGF files in the compiler

Browse Source
This commit is contained in:
krangelov
2021-12-22 10:47:22 +01:00
parent c4bd898dc0
commit 12b4958b99
10 changed files with 165 additions and 75 deletions
Download Patch File Download Diff File Expand all files Collapse all files

54
src/compiler/GF/Command/Importing.hs
View File

@@ -1,6 +1,7 @@
module GF.Command.Importing (importGrammar, importSource) where
import PGF2
import PGF2.Transactions
import GF.Compile
import GF.Compile.Multi (readMulti)
@@ -21,35 +22,32 @@ import Control.Monad(foldM)
-- import a grammar in an environment where it extends an existing grammar
importGrammar :: Maybe PGF -> Options -> [FilePath] -> IO (Maybe PGF)
importGrammar pgf0 _ [] = return pgf0
importGrammar pgf0 opts files =
case takeExtensions (last files) of
".cf" -> fmap Just $ importCF opts files getBNFCRules bnfc2cf
".ebnf" -> fmap Just $ importCF opts files getEBNFRules ebnf2cf
".gfm" -> do
ascss <- mapM readMulti files
let cs = concatMap snd ascss
importGrammar pgf0 opts cs
s | elem s [".gf",".gfo"] -> do
res <- tryIOE $ compileToPGF opts files
case res of
Ok pgf2 -> ioUnionPGF pgf0 pgf2
Bad msg -> do putStrLn ('\n':'\n':msg)
return pgf0
".pgf" -> do
mapM readPGF files >>= foldM ioUnionPGF pgf0
".ngf" -> do
mapM readNGF files >>= foldM ioUnionPGF pgf0
ext -> die $ "Unknown filename extension: " ++ show ext
importGrammar pgf0 _ [] = return pgf0
importGrammar pgf0 opts fs
| all (extensionIs ".cf") fs = fmap Just $ importCF opts fs getBNFCRules bnfc2cf
| all (extensionIs ".ebnf") fs = fmap Just $ importCF opts fs getEBNFRules ebnf2cf
| all (extensionIs ".gfm") fs = do
ascss <- mapM readMulti fs
let cs = concatMap snd ascss
importGrammar pgf0 opts cs
| all (\f -> extensionIs ".gf" f || extensionIs ".gfo" f) fs = do
res <- tryIOE $ compileToPGF opts pgf0 fs
case res of
Ok pgf -> return (Just pgf)
Bad msg -> do putStrLn ('\n':'\n':msg)
return pgf0
| all (extensionIs ".pgf") fs = foldM importPGF pgf0 fs
| all (extensionIs ".ngf") fs = do
case fs of
[f] -> fmap Just $ readNGF f
_ -> die $ "Only one .ngf file could be loaded at a time"
| otherwise = die $ "Don't know what to do with these input files: " ++ unwords fs
where
extensionIs ext = (== ext) . takeExtension
ioUnionPGF :: Maybe PGF -> PGF -> IO (Maybe PGF)
ioUnionPGF Nothing two = return (Just two)
ioUnionPGF (Just one) two =
case unionPGF one two of
Nothing -> putStrLn "Abstract changed, previous concretes discarded." >> return (Just two)
Just pgf -> return (Just pgf)
unionPGF = error "TODO: unionPGF"
importPGF :: Maybe PGF -> FilePath -> IO (Maybe PGF)
importPGF Nothing f = fmap Just (readPGF f)
importPGF (Just pgf) f = fmap Just (modifyPGF pgf (mergePGF f))
importSource :: Options -> [FilePath] -> IO SourceGrammar
importSource opts files = fmap (snd.snd) (batchCompile opts files)

21
src/compiler/GF/Compile.hs
View File

@@ -28,13 +28,13 @@ import PGF2(PGF,readProbabilitiesFromFile)
-- | Compiles a number of source files and builds a 'PGF' structure for them.
-- This is a composition of 'link' and 'batchCompile'.
compileToPGF :: Options -> [FilePath] -> IOE PGF
compileToPGF opts fs = link opts . snd =<< batchCompile opts fs
compileToPGF :: Options -> Maybe PGF -> [FilePath] -> IOE PGF
compileToPGF opts mb_pgf fs = link opts mb_pgf . snd =<< batchCompile opts fs
-- | Link a grammar into a 'PGF' that can be used to 'PGF.linearize' and
-- 'PGF.parse' with the "PGF" run-time system.
link :: Options -> (ModuleName,Grammar) -> IOE PGF
link opts (cnc,gr) =
link :: Options -> Maybe PGF -> (ModuleName,Grammar) -> IOE PGF
link opts mb_pgf (cnc,gr) =
putPointE Normal opts "linking ... " $ do
let abs = srcAbsName gr cnc
@@ -44,7 +44,7 @@ link opts (cnc,gr) =
warnOut opts warnings
probs <- liftIO (maybe (return Map.empty) readProbabilitiesFromFile (flag optProbsFile opts))
pgf <- grammar2PGF opts gr' abs probs
pgf <- grammar2PGF opts mb_pgf gr' abs probs
when (verbAtLeast opts Normal) $ putStrE "OK"
return pgf
@@ -62,22 +62,11 @@ batchCompile opts files = do
let cnc = moduleNameS (justModuleName (last files))
t = maximum . map fst $ Map.elems menv
return (t,(cnc,gr))
{-
-- to compile a set of modules, e.g. an old GF or a .cf file
compileSourceGrammar :: Options -> Grammar -> IOE Grammar
compileSourceGrammar opts gr = do
cwd <- getCurrentDirectory
(_,gr',_) <- foldM (\env -> compileSourceModule opts cwd env Nothing)
emptyCompileEnv
(modules gr)
return gr'
-}
-- | compile with one module as starting point
-- command-line options override options (marked by --#) in the file
-- As for path: if it is read from file, the file path is prepended to each name.
-- If from command line, it is used as it is.
compileModule :: Options -- ^ Options from program command line and shell command.
-> CompileEnv -> FilePath -> IOE CompileEnv
compileModule opts1 env@(_,rfs) file =

33
src/compiler/GF/Compile/GrammarToPGF.hs
View File

@@ -29,22 +29,23 @@ import Data.Maybe(fromMaybe)
import System.FilePath
import System.Directory
grammar2PGF :: Options -> SourceGrammar -> ModuleName -> Map.Map PGF2.Fun Double -> IO PGF
grammar2PGF opts gr am probs = do
let abs_name = mi2i am
mb_ngf_path <-
if snd (flag optLinkTargets opts)
then do let fname = maybe id (</>)
(flag optOutputDir opts)
(fromMaybe abs_name (flag optName opts)<.>"ngf")
exists <- doesFileExist fname
if exists
then removeFile fname
else return ()
putStr ("(Boot image "++fname++") ")
return (Just fname)
else do return Nothing
pgf <- newNGF abs_name mb_ngf_path
grammar2PGF :: Options -> Maybe PGF -> SourceGrammar -> ModuleName -> Map.Map PGF2.Fun Double -> IO PGF
grammar2PGF opts mb_pgf gr am probs = do
pgf <- case mb_pgf of
Nothing -> let abs_name = mi2i am
in if snd (flag optLinkTargets opts)
then do let fname = maybe id (</>)
(flag optOutputDir opts)
(fromMaybe abs_name (flag optName opts)<.>"ngf")
exists <- doesFileExist fname
if exists
then removeFile fname
else return ()
putStr ("(Boot image "++fname++") ")
newNGF abs_name (Just fname)
else newNGF abs_name Nothing
Just pgf -> return pgf
pgf <- modifyPGF pgf $ do
sequence_ [setAbstractFlag name value | (name,value) <- optionsPGF aflags]
sequence_ [createCategory c ctxt p | (c,ctxt,p) <- cats]

43
src/compiler/GF/Compiler.hs
View File

@@ -1,6 +1,7 @@
module GF.Compiler (mainGFC, linkGrammars, writeGrammar, writeOutputs) where
module GF.Compiler (mainGFC, writeGrammar, writeOutputs) where
import PGF2
import PGF2.Transactions
import GF.Compile as S(batchCompile,link,srcAbsName)
import GF.CompileInParallel as P(parallelBatchCompile)
import GF.Compile.Export
@@ -25,7 +26,7 @@ import qualified Data.Set as Set
import qualified Data.ByteString.Lazy as BSL
import GF.Grammar.CanonicalJSON (encodeJSON)
import System.FilePath
import Control.Monad(when,unless,forM_)
import Control.Monad(when,unless,forM_,foldM)
-- | 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@)
@@ -95,7 +96,8 @@ 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 'writeGrammar' and 'writeOutputs'.
linkGrammars opts (t_src,~cnc_grs@(~(cnc,gr):_)) =
linkGrammars opts (t_src,[]) = return ()
linkGrammars opts (t_src,cnc_gr@(cnc,gr):cnc_grs) =
do let abs = render (srcAbsName gr cnc)
pgfFile = outputPath opts (grammarName' opts abs<.>"pgf")
t_pgf <- if outputJustPGF opts
@@ -103,8 +105,8 @@ linkGrammars opts (t_src,~cnc_grs@(~(cnc,gr):_)) =
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 (\one two -> fromMaybe two (unionPGF one two)) pgfs
else do pgf <- link opts Nothing cnc_gr
pgf <- foldM (link opts . Just) pgf cnc_grs
writeGrammar opts pgf
writeOutputs opts pgf
@@ -136,18 +138,29 @@ unionPGFFiles opts fs =
else doIt
doIt =
do pgfs <- mapM readPGFVerbose fs
let pgf = foldl1 (\one two -> fromMaybe two (unionPGF one two)) pgfs
let pgfFile = outputPath opts (grammarName opts pgf <.> "pgf")
if pgfFile `elem` fs
then putStrLnE $ "Refusing to overwrite " ++ pgfFile
else writeGrammar opts pgf
writeOutputs opts pgf
case fs of
[] -> return ()
(f:fs) -> do pgf <- if snd (flag optLinkTargets opts)
then case flag optName opts of
Just name -> do let fname = maybe id (</>) (flag optOutputDir opts) (name<.>"ngf")
putStrLnE ("(Boot image "++fname++")")
exists <- doesFileExist fname
if exists
then removeFile fname
else return ()
echo (\f -> bootNGF f fname) f
Nothing -> do putStrLnE $ "To boot from a list of .pgf files add option -name"
echo readPGF f
else echo readPGF f
pgf <- foldM (\pgf -> echo (modifyPGF pgf . mergePGF)) pgf fs
let pgfFile = outputPath opts (grammarName opts pgf <.> "pgf")
if pgfFile `elem` fs
then putStrLnE $ "Refusing to overwrite " ++ pgfFile
else writeGrammar opts pgf
writeOutputs opts pgf
readPGFVerbose f =
putPointE Normal opts ("Reading " ++ f ++ "...") $ liftIO $ readPGF f
echo read f = putPointE Normal opts ("Reading " ++ f ++ "...") (liftIO (read f))
unionPGF = error "TODO: unionPGF"
-- | Export the PGF to the 'OutputFormat's specified in the 'Options'.
-- Calls 'exportPGF'.