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
|
module GF.CompileOne(OneOutput,CompiledModule,
compileOne --, 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,gf2gfo,liftIO,ePutStrLn,putPointE,putStrE)
import GF.Infra.CheckM(runCheck)
import GF.Data.Operations(liftErr,(+++))
import GF.System.Directory(doesFileExist,getCurrentDirectory)
import System.FilePath(dropFileName,dropExtension,takeExtensions)
import qualified Data.Map as Map
import GF.Text.Pretty(Doc,render,(<+>),($$))
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 = do
let putpOpt v m act
| verbAtLeast opts Verbose = putPointE Normal opts v act
| verbAtLeast opts Normal = putStrE m >> act
| otherwise = putPointE Verbose opts v act
let path = dropFileName file
let name = dropExtension file
case takeExtensions file of
".gfo" -> reuseGFO opts srcgr file
_ -> do
-- for gf source, do full compilation and generate code
b1 <- liftIO $ doesFileExist file
if not b1
then compileOne opts srcgr $ (gf2gfo opts file)
else do
sm <- putpOpt ("- parsing" +++ file) ("- compiling" +++ file ++ "... ")
$ getSourceModule opts file
intermOut opts (Dump Source) (ppModule Internal sm)
compileSourceModule opts srcgr (Just file) sm
-- | 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})
intermOut opts (Dump Source) (ppModule Internal sm0)
let sm1 = unsubexpModule sm0
cwd <- liftIO getCurrentDirectory
(sm,warnings) <- -- putPointE Normal opts "creating indirections" $
runCheck $ 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)
compileSourceModule :: Options -> SourceGrammar -> Maybe FilePath -> SourceModule -> IOE OneOutput
compileSourceModule opts gr mb_gfFile mo0 = do
cwd <- liftIO getCurrentDirectory
mo1 <- runPass Extend "" . extendModule cwd gr
=<< runPass Rebuild "" (rebuildModule cwd gr mo0)
case mo1 of
(_,n) | not (isCompleteModule n) -> generateTagsOr generateGFO mo1
_ -> do
mo2 <- runPass Rename "renaming" $ renameModule cwd gr mo1
mo3 <- runPass TypeCheck "type checking" $ checkModule opts cwd gr mo2
generateTagsOr compileCompleteModule mo3
where
compileCompleteModule mo3 = do
mo4 <- runPass2 id Optimize "optimizing" $ optimizeModule opts gr mo3
mo5 <- if isModCnc (snd mo4) && flag optPMCFG opts
then runPass2' "generating PMCFG" $ generatePMCFG opts gr mb_gfFile mo4
else runPass2' "" $ return mo4
generateGFO mo5
------------------------------
generateTagsOr compile =
if flag optTagsOnly opts then generateTags else compile
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++" ")
idump pass = intermOut opts (Dump pass) . ppModule Internal
-- * Impedance matching
runPass = runPass' fst fst snd (liftErr . runCheck)
runPass2 = runPass2e liftErr
runPass2' = 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 pass (dump out)
return (ret out)
maybeM f = maybe (return ()) f
writeGFO :: Options -> FilePath -> SourceModule -> IOE ()
writeGFO opts file mo = do
let mo1 = subexpModule mo
mo2 = case mo1 of
(m,mi) -> (m,mi{jments=Map.filter (\x -> case x of {AnyInd _ _ -> False; _ -> True}) (jments mi)})
putPointE Normal opts (" write file" +++ file) $ liftIO $ encodeModule file mo2
-- 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 ()
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
|
