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
|
----------------------------------------------------------------------
-- |
-- Module : ReadFiles
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/11/11 23:24:34 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.26 $
--
-- Decide what files to read as function of dependencies and time stamps.
--
-- make analysis for GF grammar modules. AR 11\/6\/2003--24\/2\/2004
--
-- to find all files that have to be read, put them in dependency order, and
-- decide which files need recompilation. Name @file.gf@ is returned for them,
-- and @file.gfo@ otherwise.
-----------------------------------------------------------------------------
module GF.Compile.ReadFiles
( getAllFiles,ModName,ModEnv,importsOfModule,
gfoFile,gfFile,isGFO,
getOptionsFromFile) where
import GF.Infra.UseIO
import GF.Infra.Option
import GF.Data.Operations
import GF.Source.AbsGF hiding (FileName)
import GF.Source.LexGF
import GF.Source.ParGF
import Control.Monad
import Data.Char
import Data.List
import qualified Data.ByteString.Char8 as BS
import qualified Data.Map as Map
import System.Time
import System.Directory
import System.FilePath
import Text.PrettyPrint
type ModName = String
type ModEnv = Map.Map ModName (ClockTime,[ModName])
-- | Returns a list of all files to be compiled in topological order i.e.
-- the low level (leaf) modules are first.
getAllFiles :: Options -> [InitPath] -> ModEnv -> FileName -> IOE [FullPath]
getAllFiles opts ps env file = do
-- read module headers from all files recursively
ds <- liftM reverse $ get [] [] (justModuleName file)
ioeIO $ putIfVerb opts $ "all modules:" +++ show [name | (name,_,_,_,_) <- ds]
return $ paths ds
where
-- construct list of paths to read
paths cs = [mk (p </> f) | (f,st,_,_,p) <- cs, mk <- mkFile st]
where
mkFile CSComp = [gfFile ]
mkFile CSRead = [gfoFile]
mkFile _ = []
-- | traverses the dependency graph and returns a topologicaly sorted
-- list of ModuleInfo. An error is raised if there is circular dependency
get :: [ModName] -- ^ keeps the current path in the dependency graph to avoid cycles
-> [ModuleInfo] -- ^ a list of already traversed modules
-> ModName -- ^ the current module
-> IOE [ModuleInfo] -- ^ the final
get trc ds name
| name `elem` trc = ioeErr $ Bad $ "circular modules" +++ unwords trc
| (not . null) [n | (n,_,_,_,_) <- ds, name == n] --- file already read
= return ds
| otherwise = do
(name,st0,t0,imps,p) <- findModule name
ds <- foldM (get (name:trc)) ds imps
let (st,t) | (not . null) [f | (f,CSComp,_,_,_) <- ds, elem f imps]
= (CSComp,Nothing)
| otherwise = (st0,t0)
return ((name,st,t,imps,p):ds)
-- searches for module in the search path and if it is found
-- returns 'ModuleInfo'. It fails if there is no such module
findModule :: ModName -> IOE ModuleInfo
findModule name = do
(file,gfTime,gfoTime) <- do
mb_gfFile <- ioeIO $ getFilePathMsg "" ps (gfFile name)
case mb_gfFile of
Just gfFile -> do gfTime <- ioeIO $ getModificationTime gfFile
mb_gfoTime <- ioeIO $ catch (liftM Just $ getModificationTime (replaceExtension gfFile "gfo"))
(\_->return Nothing)
return (gfFile, Just gfTime, mb_gfoTime)
Nothing -> do mb_gfoFile <- ioeIO $ getFilePathMsg "" ps (gfoFile name)
case mb_gfoFile of
Just gfoFile -> do gfoTime <- ioeIO $ getModificationTime gfoFile
return (gfoFile, Nothing, Just gfoTime)
Nothing -> ioeErr $ Bad (render (text "File" <+> text (gfFile name) <+> text "does not exist." $$
text "searched in:" <+> vcat (map text ps)))
let mb_envmod = Map.lookup name env
(st,t) = selectFormat opts (fmap fst mb_envmod) gfTime gfoTime
imps <- if st == CSEnv
then return (maybe [] snd mb_envmod)
else do s <- ioeIO $ BS.readFile file
(mname,imps) <- ioeErr ((liftM (importsOfModule . modHeaderToModDef) . pModHeader . myLexer) s)
ioeErr $ testErr (mname == name)
("module name" +++ mname +++ "differs from file name" +++ name)
return imps
return (name,st,t,imps,dropFileName file)
-- FIXME: this is pretty ugly, it's just to get around the difference
-- between ModHeader as returned when parsing just the module header
-- when looking for imports, and ModDef, which includes the whole module.
modHeaderToModDef :: ModHeader -> ModDef
modHeaderToModDef (MModule2 x y z) = MModule x y (modHeaderBodyToModBody z)
where
modHeaderBodyToModBody :: ModHeaderBody -> ModBody
modHeaderBodyToModBody b = case b of
MBody2 x y -> MBody x y []
MNoBody2 x -> MNoBody x
MWith2 x y -> MWith x y
MWithBody2 x y z -> MWithBody x y z []
MWithE2 x y z -> MWithE x y z
MWithEBody2 x y z w -> MWithEBody x y z w []
MReuse2 x -> MReuse x
MUnion2 x -> MUnion x
isGFO :: FilePath -> Bool
isGFO = (== ".gfo") . takeExtensions
gfoFile :: FilePath -> FilePath
gfoFile f = addExtension f "gfo"
gfFile :: FilePath -> FilePath
gfFile f = addExtension f "gf"
-- From the given Options and the time stamps computes
-- whether the module have to be computed, read from .gfo or
-- the environment version have to be used
selectFormat :: Options -> Maybe ClockTime -> Maybe ClockTime -> Maybe ClockTime -> (CompStatus,Maybe ClockTime)
selectFormat opts mtenv mtgf mtgfo =
case (mtenv,mtgfo,mtgf) of
(_,_,Just tgf) | fromSrc -> (CSComp,Nothing)
(Just tenv,_,_) | fromComp -> (CSEnv, Just tenv)
(_,Just tgfo,_) | fromComp -> (CSRead,Just tgfo)
(Just tenv,_,Just tgf) | tenv > tgf -> (CSEnv, Just tenv)
(_,Just tgfo,Just tgf) | tgfo > tgf -> (CSRead,Just tgfo)
(Just tenv,_,Nothing) -> (CSEnv,Just tenv) -- source does not exist
(_,_, Nothing) -> (CSRead,Nothing) -- source does not exist
_ -> (CSComp,Nothing)
where
fromComp = flag optRecomp opts == NeverRecomp
fromSrc = flag optRecomp opts == AlwaysRecomp
-- internal module dep information
data CompStatus =
CSComp -- compile: read gf
| CSRead -- read gfo
| CSEnv -- gfo is in env
deriving Eq
type ModuleInfo = (ModName,CompStatus,Maybe ClockTime,[ModName],InitPath)
importsOfModule :: ModDef -> (ModName,[ModName])
importsOfModule (MModule _ typ body) = modType typ (modBody body [])
where
modType (MTAbstract m) xs = (modName m,xs)
modType (MTResource m) xs = (modName m,xs)
modType (MTInterface m) xs = (modName m,xs)
modType (MTConcrete m m2) xs = (modName m,modName m2:xs)
modType (MTInstance m m2) xs = (modName m,modName m2:xs)
modType (MTTransfer m o1 o2) xs = (modName m,open o1 (open o2 xs))
modBody (MBody e o _) xs = extend e (opens o xs)
modBody (MNoBody is) xs = foldr include xs is
modBody (MWith i os) xs = include i (foldr open xs os)
modBody (MWithBody i os o _) xs = include i (foldr open (opens o xs) os)
modBody (MWithE is i os) xs = foldr include (include i (foldr open xs os)) is
modBody (MWithEBody is i os o _) xs = foldr include (include i (foldr open (opens o xs) os)) is
modBody (MReuse m) xs = modName m:xs
modBody (MUnion is) xs = foldr include xs is
include (IAll m) xs = modName m:xs
include (ISome m _) xs = modName m:xs
include (IMinus m _) xs = modName m:xs
open (OName n) xs = modName n:xs
open (OQualQO _ n) xs = modName n:xs
open (OQual _ _ n) xs = modName n:xs
extend NoExt xs = xs
extend (Ext is) xs = foldr include xs is
opens NoOpens xs = xs
opens (OpenIn os) xs = foldr open xs os
modName (PIdent (_,s)) = BS.unpack s
-- | options can be passed to the compiler by comments in @--#@, in the main file
getOptionsFromFile :: FilePath -> IOE Options
getOptionsFromFile file = do
s <- ioeIO $ readFileIfStrict file
let ls = filter (BS.isPrefixOf (BS.pack "--#")) $ BS.lines s
fs = map (BS.unpack . BS.unwords . BS.words . BS.drop 3) ls
ioeErr $ parseModuleOptions fs
|
