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
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
|
{-# LANGUAGE CPP #-}
module AbstractCurry.Files where
import Data.Char ( isSpace )
import System.Directory ( doesFileExist, getModificationTime
, findFileWithSuffix, getFileWithSuffix )
import System.FilePath ( takeFileName, (</>), (<.>) )
import System.CurryPath ( getLoadPathForModule, inCurrySubdir
, lookupModuleSourceInLoadPath, stripCurrySuffix )
import System.FrontendExec
import ReadShowTerm ( readsUnqualifiedTerm, showTerm )
import AbstractCurry.Select ( imports )
import AbstractCurry.Types
readCurry :: String -> IO CurryProg
readCurry prog = readCurryWithParseOptions prog (setQuiet True defaultParams)
readCurryWithImports :: String -> IO [CurryProg]
readCurryWithImports modname = collect [] [modname]
where
collect _ [] = return []
collect imported (m:ms)
| m `elem` imported = collect imported ms
| otherwise = do
p <- readCurry m
ps <- collect (m:imported) (ms ++ imports p)
return (p:ps)
tryReadCurryWithImports :: String -> IO (Either [String] [CurryProg])
tryReadCurryWithImports modname = collect [] [modname]
where
collect _ [] = return (Right [])
collect imported (m:ms)
| m `elem` imported = collect imported ms
| otherwise = do
eProg <- tryReadCurryFile m
case eProg of
Left err -> return (Left [err])
Right prog@(CurryProg _ is _ _ _ _ _ _) -> do
results <- collect (m:imported) (ms ++ is)
return (either Left (Right . (prog :)) results)
tryReadCurryFile :: String -> IO (Either String CurryProg)
tryReadCurryFile m = do
mbSrc <- lookupModuleSourceInLoadPath m
case mbSrc of
Nothing -> cancel $ "Source module '" ++ m ++ "' not found"
Just (_,srcFile) -> do
callFrontendWithParams ACY (setQuiet True defaultParams) m
mbFn <- getLoadPathForModule m >>=
findFileWithSuffix (abstractCurryFileName m) [""]
case mbFn of
Nothing -> cancel $ "AbstractCurry module '" ++ m ++ "' not found"
Just fn -> do
ctime <- getModificationTime srcFile
ftime <- getModificationTime fn
if ctime > ftime
then cancel $ "Source file '" ++ srcFile
++ "' is newer than AbstractCurry file '" ++ fn ++ "'"
else do
mbProg <- tryParse fn
case mbProg of
Left err -> cancel err
Right p -> return (Right p)
where cancel str = return (Left str)
tryParse :: String -> IO (Either String CurryProg)
tryParse fn = do
exists <- doesFileExist fn
if not exists
then cancel $ "AbstractCurry file '" ++ fn ++ "' does not exist"
else do
src <- readFile fn
let (line1, lines) = break (=='\n') src
if line1 /= "{- "++version++" -}"
then cancel $ "Could not parse AbstractCurry file '" ++ fn
++ "': incompatible versions"
else
case readACYString lines of
Just p -> return (Right p)
Nothing -> cancel $ "Could not parse AbstractCurry file '" ++
fn ++ "': no parse"
where cancel str = return (Left str)
readUntypedCurry :: String -> IO CurryProg
readUntypedCurry prog =
readUntypedCurryWithParseOptions prog (setQuiet True defaultParams)
readCurryWithParseOptions :: String -> FrontendParams -> IO CurryProg
readCurryWithParseOptions progname options = do
let modname = takeFileName progname
mbsrc <- lookupModuleSourceInLoadPath progname
case mbsrc of
Nothing -> do
loadpath <- getLoadPathForModule progname
filename <- getFileWithSuffix (abstractCurryFileName modname) [""] loadpath
readAbstractCurryFile filename
Just (dir,_) -> do
callFrontendWithParams ACY options progname
readAbstractCurryFile (abstractCurryFileName (dir </> modname))
readUntypedCurryWithParseOptions :: String -> FrontendParams -> IO CurryProg
readUntypedCurryWithParseOptions progname options = do
let modname = takeFileName progname
mbsrc <- lookupModuleSourceInLoadPath progname
case mbsrc of
Nothing -> do
loadpath <- getLoadPathForModule progname
filename <- getFileWithSuffix (untypedAbstractCurryFileName modname) [""]
loadpath
readAbstractCurryFile filename
Just (dir,_) -> do
callFrontendWithParams UACY options progname
readAbstractCurryFile (untypedAbstractCurryFileName (dir </> modname))
abstractCurryFileName :: String -> String
abstractCurryFileName prog = inCurrySubdir (stripCurrySuffix prog) <.> "acy"
untypedAbstractCurryFileName :: String -> String
untypedAbstractCurryFileName prog =
inCurrySubdir (stripCurrySuffix prog) <.> "uacy"
readAbstractCurryFile :: String -> IO CurryProg
readAbstractCurryFile filename = do
exacy <- doesFileExist filename
if exacy
then readExistingACY filename
else do let subdirfilename = inCurrySubdir filename
exdiracy <- doesFileExist subdirfilename
if exdiracy
then readExistingACY subdirfilename
else error ("EXISTENCE ERROR: AbstractCurry file '"++filename++
"' does not exist")
where
readExistingACY fname = do
filecontents <- readFile fname
let (line1,lines) = break (=='\n') filecontents
if line1 == "{- "++version++" -}"
then case readACYString lines of
Just p -> return p
Nothing -> error $ "Could not parse AbstractCurry file '" ++
filename ++ "': no parse"
else error $ "AbstractCurry: incompatible file found: "++fname
tryReadACYFile :: String -> IO (Maybe CurryProg)
tryReadACYFile fn = do
exists <- doesFileExist fn
if exists
then tryRead fn
else do
let fn' = inCurrySubdir fn
exists' <- doesFileExist fn'
if exists'
then tryRead fn'
else return Nothing
where
tryRead file = do
src <- readFile file
let (line1,lines) = break (=='\n') src
if line1 /= "{- "++version++" -}"
then error $ "AbstractCurry: incompatible file found: "++fn
else return $ readACYString lines
readACYString :: String -> Maybe CurryProg
readACYString s =
case
readsUnqualifiedTerm ["AbstractCurry.Types","Prelude"] s
of [] -> Nothing
[(p,tl)] -> if all isSpace tl then Just p
else Nothing
_ -> Nothing
writeAbstractCurryFile :: String -> CurryProg -> IO ()
writeAbstractCurryFile file prog =
writeFile file (showTerm prog)
|