1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
|
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.ConcreteToCanonical--(concretes2canonical)
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,render80)
import Data.Maybe
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.ByteString.Lazy as BSL
import GF.Grammar.CanonicalJSON (encodeJSON, encodeYAML)
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
exportCanonical 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])
exportCanonical (_time, canonical) =
do when (FmtHaskell `elem` ofmts && haskellOption opts HaskellConcrete) $
mapM_ cnc2haskell canonical
when (FmtCanonicalGF `elem` ofmts) $
do createDirectoryIfMissing False "canonical"
mapM_ abs2canonical canonical
mapM_ cnc2canonical canonical
when (FmtCanonicalJson `elem` ofmts) $ mapM_ grammar2json canonical
when (FmtCanonicalYaml `elem` ofmts) $ mapM_ grammar2yaml canonical
where
ofmts = flag optOutputFormats opts
cnc2haskell (cnc,gr) =
do mapM_ writeExport $ concretes2haskell opts (srcAbsName gr cnc) gr
abs2canonical (cnc,gr) =
writeExport ("canonical/"++render absname++".gf",render80 canAbs)
where
absname = srcAbsName gr cnc
canAbs = abstract2canonical absname gr
cnc2canonical (cnc,gr) =
mapM_ (writeExport.fmap render80) $
concretes2canonical opts (srcAbsName gr cnc) gr
grammar2json (cnc,gr) = encodeJSON (render absname ++ ".json") gr_canon
where absname = srcAbsName gr cnc
gr_canon = grammar2canonical opts absname gr
grammar2yaml (cnc,gr) = encodeYAML (render absname ++ ".yaml") gr_canon
where absname = srcAbsName gr cnc
gr_canon = grammar2canonical opts absname gr
writeExport (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
|
