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
|
{-# LANGUAGE CPP #-}
module GF.CompileOne(-- ** Compiling a single module
OneOutput,CompiledModule,
compileOne,reuseGFO,useTheSource
--, CompileSource, compileSourceModule
) where
-- The main compiler passes
import GF.Compile.GetGrammar(getSourceModule)
import GF.Compile.Rename(renameModule)
import GF.Compile.CheckGrammar(checkModule)
import GF.Compile.Optimize(optimizeModule)
import GF.Compile.SubExOpt(subexpModule,unsubexpModule)
#ifdef PRE_PMCFG
import GF.Compile.GeneratePmcfgPre(generatePMCFG)
#else
import GF.Compile.GeneratePMCFG(generatePMCFG)
#endif
import GF.Compile.Update(extendModule,rebuildModule)
import GF.Compile.Tags(writeTags,gf2gftags)
import GF.Grammar.Grammar
import GF.Grammar.Printer(ppModule,TermPrintQual(..))
import GF.Grammar.Binary(decodeModule,encodeModule)
import GF.Infra.Option
import GF.Infra.UseIO(FullPath,IOE,isGFO,gf2gfo,MonadIO(..),Output(..),putPointE)
import GF.Infra.CheckM(runCheck')
import GF.Data.Operations(ErrorMonad,liftErr,(+++))
import GF.System.Directory(doesFileExist,getCurrentDirectory,renameFile)
import System.FilePath(makeRelative)
import System.Random(randomIO)
import qualified Data.Map as Map
import GF.Text.Pretty(render,(<+>),($$)) --Doc,
import GF.System.Console(TermColors(..),getTermColors)
import Control.Monad((<=<))
import qualified Control.Monad.Fail as Fail
type OneOutput = (Maybe FullPath,CompiledModule)
type CompiledModule = Module
compileOne, reuseGFO, useTheSource ::
(Output m,ErrorMonad m,MonadIO m, Fail.MonadFail m) =>
Options -> Grammar -> FullPath -> m OneOutput
-- | Compile a given source file (or just load a .gfo file),
-- given a 'Grammar' containing everything it depends on.
-- Calls 'reuseGFO' or 'useTheSource'.
compileOne opts srcgr file =
if isGFO file
then reuseGFO opts srcgr file
else do b1 <- doesFileExist file
if b1 then useTheSource opts srcgr file
else reuseGFO opts srcgr (gf2gfo opts file)
-- | Read a compiled GF module.
-- Also undo common subexp optimization, to enable normal computations.
reuseGFO opts srcgr file =
do cwd <- getCurrentDirectory
let rfile = makeRelative cwd file
sm00 <- putPointE Verbose opts ("+ reading" +++ rfile) $
decodeModule file
let sm0 = (fst sm00,(snd sm00){mflags=mflags (snd sm00) `addOptions` opts})
idump opts Source sm0
let sm1 = unsubexpModule sm0
(sm,warnings) <- -- putPointE Normal opts "creating indirections" $
runCheck' opts $ extendModule cwd srcgr sm1
warnOut opts warnings
if flag optTagsOnly opts
then writeTags opts srcgr (gf2gftags opts file) sm1
else return ()
return (Just file,sm)
--useTheSource :: Options -> Grammar -> FullPath -> IOE OneOutput
-- | Compile GF module from source. It both returns the result and
-- stores it in a @.gfo@ file
-- (or a tags file, if running with the @-tags@ option)
useTheSource opts srcgr file =
do cwd <- getCurrentDirectory
let rfile = makeRelative cwd file
sm <- putpOpt ("- parsing" +++ rfile)
("- compiling" +++ rfile ++ "... ")
(getSourceModule opts file)
idump opts Source sm
compileSourceModule opts cwd (Just file) srcgr sm
where
putpOpt v m act
| verbAtLeast opts Verbose = putPointE Normal opts v act
| verbAtLeast opts Normal = putStrE m >> act
| otherwise = putPointE Verbose opts v act
type CompileSource = Grammar -> Module -> IOE OneOutput
--compileSourceModule :: Options -> InitPath -> Maybe FilePath -> CompileSource
compileSourceModule opts cwd mb_gfFile gr =
if flag optTagsOnly opts
then generateTags <=< ifComplete middle <=< frontend
else generateGFO <=< ifComplete (backend <=< middle) <=< frontend
where
-- Apply to all modules
frontend = runPass Extend "" . extendModule cwd gr
<=< runPass Rebuild "" . rebuildModule cwd gr
-- Apply to complete modules
middle = runPass TypeCheck "type checking" . checkModule opts cwd gr
<=< runPass Rename "renaming" . renameModule cwd gr
-- Apply to complete modules when not generating tags
backend mo3 =
do mo4 <- runPassE Optimize "optimizing" $ optimizeModule opts gr mo3
if isModCnc (snd mo4) && flag optPMCFG opts
then runPassI "generating PMCFG" $ generatePMCFG opts gr mb_gfFile mo4
else runPassI "" $ return mo4
ifComplete yes mo@(_,mi) =
if isCompleteModule mi then yes mo else return mo
generateGFO mo =
do let mb_gfo = fmap (gf2gfo opts) mb_gfFile
maybeM (flip (writeGFO opts cwd) mo) mb_gfo
return (mb_gfo,mo)
generateTags mo =
do maybeM (flip (writeTags opts gr) mo . gf2gftags opts) mb_gfFile
return (Nothing,mo)
putpp s = if null s then id else putPointE Verbose opts (" "++s++" ")
-- * Running a compiler pass, with impedance matching
runPass = runPass' fst fst snd (liftErr . runCheck' opts)
runPassE = runPass2e liftErr id
runPassI = runPass2e id id Canon
runPass2e lift dump = runPass' id dump (const "") lift
runPass' ret dump warn lift pass pp m =
do out <- putpp pp $ lift m
warnOut opts (warn out)
idump opts pass (dump out)
return (ret out)
maybeM f = maybe (return ()) f
--writeGFO :: Options -> InitPath -> FilePath -> SourceModule -> IOE ()
writeGFO opts cwd file mo =
putPointE Normal opts (" write file" +++ rfile) $
do n <- liftIO randomIO --avoid name clashes when compiling with 'make -j'
let tmp = file++".tmp" ++show (n::Int)
encodeModule tmp mo2
renameFile tmp file
where
rfile = makeRelative cwd file
mo2 = (m,mi{jments=Map.filter notAnyInd (jments mi)})
(m,mi) = subexpModule mo
notAnyInd x = case x of AnyInd{} -> False; _ -> True
-- to output an intermediate stage
--intermOut :: Options -> Dump -> Doc -> IOE ()
intermOut opts d doc
| dump opts d = ePutStrLn (render ("\n\n--#" <+> show d $$ doc))
| otherwise = return ()
idump opts pass = intermOut opts (Dump pass) . ppModule Internal
warnOut opts warnings
| null warnings = return ()
| otherwise = do t <- getTermColors
ePutStr (blueFg t);ePutStr ws;ePutStrLn (restore t)
where
ws = if flag optVerbosity opts == Normal
then '\n':warnings
else warnings
|
