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
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
|
module Compile where
import Grammar
import Ident
import Option
import PrGrammar
import Update
import Lookup
import Modules
import ReadFiles
import ShellState
import MkResource
-- the main compiler passes
import GetGrammar
import Extend
import Rebuild
import Rename
import Refresh
import CheckGrammar
import Optimize
import GrammarToCanon
import Share
import qualified CanonToGrammar as CG
import qualified GFC
import qualified MkGFC
import GetGFC
import Operations
import UseIO
import Arch
import Monad
-- in batch mode: write code in a file
batchCompile f = liftM fst $ compileModule defOpts emptyShellState f
where
defOpts = options [beVerbose, emitCode]
batchCompileOpt f = liftM fst $ compileModule defOpts emptyShellState f
where
defOpts = options [beVerbose, emitCode, optimizeCanon]
batchCompileOld f = compileOld defOpts f
where
defOpts = options [beVerbose, emitCode]
-- 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 -> ShellState -> FilePath ->
IOE (GFC.CanonGrammar, (SourceGrammar,[(FilePath,ModTime)]))
compileModule opts1 st0 file = do
opts0 <- ioeIO $ getOptionsFromFile file
let useFileOpt = maybe False (const True) $ getOptVal opts0 pathList
let opts = addOptions opts1 opts0
let ps0 = pathListOpts opts
let fpath = justInitPath file
let ps = if useFileOpt
then (map (prefixPathName fpath) ps0)
else ps0
ioeIO $ print ps ----
let putp = putPointE opts
let st = st0 --- if useFileOpt then emptyShellState else st0
let rfs = readFiles st
let file' = if useFileOpt then justFileName file else file -- to find file itself
files <- getAllFiles ps rfs file'
ioeIO $ print files ----
let names = map (fileBody . justFileName) files
ioeIO $ print names ----
let env0 = compileEnvShSt st names
(_,sgr,cgr) <- foldM (compileOne opts) env0 files
t <- ioeIO getNowTime
return $ (reverseModules cgr, -- to preserve dependency order
(reverseModules sgr, --- keepResModules opts sgr, --- keep all so far
[(f,t) | f <- files])) -- pass on the time of creation
compileEnvShSt :: ShellState -> [ModName] -> CompileEnv
compileEnvShSt st fs = (0,sgr,cgr) where
cgr = MGrammar [m | m@(i,_) <- modules (canModules st), notInc i]
sgr = MGrammar [m | m@(i,_) <- modules (srcModules st), notIns i]
notInc i = notElem (prt i) $ map fileBody fs
notIns i = notElem (prt i) $ map fileBody fs
pathListOpts :: Options -> [InitPath]
pathListOpts opts = maybe [""] pFilePaths $ getOptVal opts pathList
reverseModules (MGrammar ms) = MGrammar $ reverse ms
keepResModules :: Options -> SourceGrammar -> SourceGrammar
keepResModules opts gr =
if oElem retainOpers opts
then MGrammar $ reverse [(i,mi) | (i,mi@(ModMod m)) <- modules gr, isModRes m]
else emptyMGrammar
-- the environment
type CompileEnv = (Int,SourceGrammar, GFC.CanonGrammar)
emptyCompileEnv :: CompileEnv
emptyCompileEnv = (0,emptyMGrammar,emptyMGrammar)
extendCompileEnvInt (_,MGrammar ss, MGrammar cs) (k,sm,cm) =
return (k,MGrammar (sm:ss), MGrammar (cm:cs)) --- reverse later
extendCompileEnv (k,s,c) (sm,cm) = extendCompileEnvInt (k,s,c) (k,sm,cm)
compileOne :: Options -> CompileEnv -> FullPath -> IOE CompileEnv
compileOne opts env file = do
let putp = putPointE opts
let gf = fileSuffix file
let path = justInitPath file
let name = fileBody file
case gf of
-- for canonical gf, just read the file and update environment
"gfc" -> do
cm <- putp ("+ reading" +++ file) $ getCanonModule file
sm <- ioeErr $ CG.canon2sourceModule cm
extendCompileEnv env (sm, cm)
-- for compiled resource, parse and organize, then update environment
"gfr" -> do
sm0 <- putp ("| parsing" +++ file) $ getSourceModule file
let mos = case env of (_,gr,_) -> modules gr
sm <- {- putp "creating indirections" $ -} ioeErr $ extendModule mos sm0
let gfc = gfcFile name
cm <- putp ("+ reading" +++ gfc) $ getCanonModule gfc
extendCompileEnv env (sm,cm)
-- for gf source, do full compilation
_ -> do
sm0 <- putp ("- parsing" +++ file) $ getSourceModule file
(k',sm) <- makeSourceModule opts env sm0
cm <- putp " generating code... " $ generateModuleCode opts path sm
extendCompileEnvInt env (k',sm,cm)
-- dispatch reused resource at early stage
makeSourceModule :: Options -> CompileEnv -> SourceModule -> IOE (Int,SourceModule)
makeSourceModule opts env@(k,gr,can) mo@(i,mi) = case mi of
ModMod m -> case mtype m of
MTReuse c -> do
sm <- ioeErr $ makeReuse gr i (extends m) c
let mo2 = (i, ModMod sm)
mos = modules gr
putp " type checking reused" $ ioeErr $ showCheckModule mos mo2
return $ (k,mo2)
_ -> compileSourceModule opts env mo
_ -> compileSourceModule opts env mo
where
putp = putPointE opts
compileSourceModule :: Options -> CompileEnv ->
SourceModule -> IOE (Int,SourceModule)
compileSourceModule opts env@(k,gr,can) mo@(i,mi) = do
let putp = putPointE opts
mos = modules gr
mo1 <- ioeErr $ rebuildModule mos mo
mo1b <- ioeErr $ extendModule mos mo1
---- prDebug mo1b
case mo1b of
(_,ModMod n) | not (isCompleteModule n) -> do
return (k,mo1b) -- refresh would fail, since not renamed
_ -> do
mo2:_ <- putp " renaming " $ ioeErr $ renameModule mos mo1b
(mo3:_,warnings) <- putp " type checking" $ ioeErr $ showCheckModule mos mo2
putStrE warnings
(k',mo3r:_) <- ioeErr $ refreshModule (k,mos) mo3
mo4:_ <- putp " optimizing " $ ioeErr $ evalModule mos mo3r
return (k',mo4)
where
prDebug mo = ioeIO $ putStrLn $ prGrammar $ MGrammar [mo] ---- debug
generateModuleCode :: Options -> InitPath -> SourceModule -> IOE GFC.CanonModule
generateModuleCode opts path minfo@(name,info) = do
let pname = prefixPathName path (prt name)
minfo0 <- ioeErr $ redModInfo minfo
minfo' <- return $ if optim
then shareModule fullOpt minfo0 -- parametrization and sharing
else shareModule basicOpt minfo0 -- sharing only
-- for resource, also emit gfr
case info of
ModMod m | isModRes m && isCompilable info && emit && nomulti -> do
let (file,out) = (gfrFile pname, prGrammar (MGrammar [minfo]))
ioeIO $ writeFile file out >> putStr (" wrote file" +++ file)
_ -> return ()
(file,out) <- do
code <- return $ MkGFC.prCanonModInfo minfo'
return (gfcFile pname, code)
if isCompilable info && emit && nomulti
then ioeIO $ writeFile file out >> putStr (" wrote file" +++ file)
else ioeIO $ putStrFlush "no need to save for this module "
return minfo'
where
isCompilable _ = True ---- isCompilableModule ---- emit code for interfaces
nomulti = not $ oElem makeMulti opts
emit = oElem emitCode opts
optim = oElem optimizeCanon opts
-- for old GF: sort into modules, write files, compile as usual
compileOld :: Options -> FilePath -> IOE GFC.CanonGrammar
compileOld opts file = do
let putp = putPointE opts
grammar1 <- putp ("- parsing old gf" +++ file) $ getOldGrammar file
files <- mapM writeNewGF $ modules grammar1
(_,_,grammar) <- foldM (compileOne opts) emptyCompileEnv files
return grammar
writeNewGF :: SourceModule -> IOE FilePath
writeNewGF m@(i,_) = do
let file = gfFile $ prt i
ioeIO $ writeFile file $ prGrammar (MGrammar [m])
ioeIO $ putStrLn $ "wrote file" +++ file
return file
|
