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
|
module GF.CompileOne(OneOutput,CompiledModule,
compileOne --, CompileSource, compileSourceModule
) where
import Prelude hiding (catch)
import GF.System.Catch
-- 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)
import GF.Compile.GeneratePMCFG(generatePMCFG)
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,liftIO,ePutStrLn,putPointE,putStrE)
import GF.Infra.CheckM(runCheck')
import GF.Data.Operations(liftErr,(+++))
import GF.System.Directory(doesFileExist,getCurrentDirectory)
import qualified Data.Map as Map
import GF.Text.Pretty(Doc,render,(<+>),($$))
import Control.Monad((<=<))
type OneOutput = (Maybe FullPath,CompiledModule)
type CompiledModule = SourceModule
-- | Compile a given source file (or just load a .gfo file),
-- given a 'SourceGrammar' containing everything it depends on.
compileOne :: Options -> SourceGrammar -> FullPath -> IOE OneOutput
compileOne opts srcgr file =
if isGFO file
then reuseGFO opts srcgr file
else do b1 <- doesFileExist file
if b1 then useTheSource
else reuseGFO opts srcgr (gf2gfo opts file)
where
-- | For gf source, do full compilation and generate code
useTheSource =
do sm <- putpOpt ("- parsing" +++ file)
("- compiling" +++ file ++ "... ")
(getSourceModule opts file)
idump opts Source sm
cwd <- getCurrentDirectory
compileSourceModule opts cwd (Just file) srcgr sm
putpOpt v m act
| verbAtLeast opts Verbose = putPointE Normal opts v act
| verbAtLeast opts Normal = putStrE m >> act
| otherwise = putPointE Verbose opts v act
-- | For compiled gf, read the file and update environment
-- also undo common subexp optimization, to enable normal computations
reuseGFO opts srcgr file =
do sm00 <- putPointE Verbose opts ("+ reading" +++ file) $
liftIO (decodeModule file)
let sm0 = (fst sm00,(snd sm00){mflags=mflags (snd sm00) `addOptions` opts})
idump opts Source sm0
let sm1 = unsubexpModule sm0
cwd <- getCurrentDirectory
(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)
type CompileSource = SourceGrammar -> SourceModule -> IOE OneOutput
compileSourceModule :: Options -> FilePath -> 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 id 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) 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
runPassI = runPass2e id id Canon
runPass2e lift f = runPass' id f (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 -> FilePath -> SourceModule -> IOE ()
writeGFO opts file mo =
putPointE Normal opts (" write file" +++ file) $
liftIO $ encodeModule file mo2
where
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 = liftIO $ ePutStrLn ws `catch` oops
where
oops _ = ePutStrLn "" -- prevent crash on character encoding problem
ws = if flag optVerbosity opts == Normal
then '\n':warnings
else warnings
|
