Modules.lhs 29.1 KB
Newer Older
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
% $Id: Modules.lhs,v 1.84 2004/02/10 17:46:07 wlux Exp $
%
% Copyright (c) 1999-2004, Wolfgang Lux
% See LICENSE for the full license.
%
% Modified by Martin Engelke (men@informatik.uni-kiel.de)
% March 2007, extensions by Sebastian Fischer (sebf@informatik.uni-kiel.de)
%
\nwfilename{Modules.lhs}
\section{Modules}
This module controls the compilation of modules.
\begin{verbatim}

> module Modules
>   ( compileModule, importPrelude, patchModuleId, loadInterfaces, transModule
>   , simpleCheckModule, checkModule
>   ) where

> import Control.Monad (foldM, liftM, unless, when)
> import Data.List (find, isPrefixOf, partition)
21
> import qualified Data.Map as Map (Map, empty, insert, insertWith, lookup, toList, member)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
22
23
24
25
26
27
28
29
30
31
32
> import Data.Maybe (fromMaybe)
> import Text.PrettyPrint.HughesPJ (Doc, ($$), text, vcat)

> import qualified Curry.AbstractCurry as AC
> import Curry.Base.MessageMonad
> import Curry.Base.Position
> import Curry.Base.Ident
> import Curry.ExtendedFlat.Type
> import qualified Curry.ExtendedFlat.Type as EF
> import Curry.Files.Filenames
> import Curry.Files.PathUtils
33
> import qualified IL as IL
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
34
35
> import Curry.Syntax

36
> import Base.Arity (ArityEnv, initAEnv, bindArities)
37
> import Base.Eval (evalEnv)
38
> import Base.Import (bindAlias, initIEnv, fromDeclList)
39
40
41
42
43
> import Base.Module (ModuleEnv)
> import Base.OpPrec (PEnv, initPEnv)
> import Base.TypeConstructors (TCEnv, TypeInfo (..), initTCEnv, qualLookupTC)
> import Base.Types (toType, fromQualType)
> import Base.Value (ValueEnv, ValueInfo (..), initDCEnv)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
> import Check.InterfaceCheck (interfaceCheck)
> import Check.KindCheck (kindCheck)
> import Check.SyntaxCheck (syntaxCheck)
> import Check.PrecCheck (precCheck)
> import Check.TypeCheck (typeCheck)
> import Check.WarnCheck (warnCheck)

> import Env.CurryEnv
> import Env.TopEnv

> import Gen.GenAbstractCurry (genTypedAbstract, genUntypedAbstract)
> import Gen.GenFlatCurry (genFlatCurry, genFlatInterface)

> import Transform.CaseCompletion
> import Transform.Desugar (desugar)
> import Transform.Lift (lift)
> import Transform.Qual (qual)
> import Transform.Simplify (simplify)

63
64
> import CompilerOpts (Options (..), TargetType (..), Extension (..)
>   , DumpLevel (..))
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
65
66
67
> import CurryToIL (ilTrans)
> import Exports (expandInterface, exportInterface)
> import Imports (importInterface, importInterfaceIntf, importUnifyData)
68
> import Messages (errorAt, internalError, putErrsLn)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
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
> import Types
> import TypeSubst

\end{verbatim}
The function \texttt{compileModule} is the main entry-point of this
module for compiling a Curry source module. Depending on the command
line options it will emit either C code or FlatCurry code (standard
or in XML
representation) or AbstractCurry code (typed, untyped or with type
signatures) for the module. Usually the first step is to
check the module. Then the code is translated into the intermediate
language. If necessary, this phase will also update the module's
interface file. The resulting code then is either written out (in
FlatCurry or XML format) or translated further into C code.
The untyped  AbstractCurry representation is written
out directly after parsing and simple checking the source file.
The typed AbstractCurry code is written out after checking the module.

The compiler automatically loads the prelude when compiling any
module, except for the prelude itself, by adding an appropriate import
declaration to the module.

Since this modified version of the Muenster Curry Compiler is used
as a frontend for PAKCS, all functions for evaluating goals and generating C
code are obsolete and commented out.
\begin{verbatim}

96
> compileModule :: Options -> FilePath -> IO ()
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
97
> compileModule opts fn = do
Björn Peemöller 's avatar
Björn Peemöller committed
98
99
100
101
>   -- read and parse module
>   parsed <- (ok . parseModule likeFlat fn) `liftM` readModule fn
>   -- add Prelude import
>   let withPrelude = importPrelude opts fn parsed
Björn Peemöller 's avatar
Björn Peemöller committed
102
>   -- generate module identifier from file name if missing
Björn Peemöller 's avatar
Björn Peemöller committed
103
>   let m = patchModuleId fn withPrelude
Björn Peemöller 's avatar
Björn Peemöller committed
104
>   -- check whether module identifier and file name fit together
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
105
>   checkModuleId fn m
Björn Peemöller 's avatar
Björn Peemöller committed
106
>   -- load the imported interfaces into a 'ModuleEnv'
107
>   mEnv <- loadInterfaces (optImportPaths opts) m
Björn Peemöller 's avatar
Björn Peemöller committed
108
>   if not withFlat
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
109
110
>      then do
>        (tyEnv, tcEnv, _, m', _, _) <- simpleCheckModule opts mEnv m
111
112
>        -- generate AbstractCurry
>        genAbstract opts fn tyEnv tcEnv m'
Björn Peemöller 's avatar
Björn Peemöller committed
113
>        -- output the parsed source
114
>        genParsed   opts fn m'
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
115
116
117
>      else do
>        -- checkModule checks types, and then transModule introduces new
>        -- functions (by lambda lifting in 'desugar'). Consequence: The
Björn Peemöller 's avatar
Björn Peemöller committed
118
>        -- types of the newly introduced functions are not inferred (hsi)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
119
>        (tyEnv, tcEnv, aEnv, m', intf, _) <- checkModule opts mEnv m
Björn Peemöller 's avatar
Björn Peemöller committed
120
>        let (il, aEnv', dumps) = transModule fcy False False
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
121
>                                 mEnv tyEnv tcEnv aEnv m'
Björn Peemöller 's avatar
Björn Peemöller committed
122
>        -- dump intermediate results
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
123
>        mapM_ (doDump opts) dumps
Björn Peemöller 's avatar
Björn Peemöller committed
124
>        -- generate target code
125
126
127
>        genAbstract opts fn tyEnv tcEnv m'
>        genFlat     opts fn mEnv tyEnv tcEnv aEnv' intf m' il
>        genParsed   opts fn m'
Björn Peemöller 's avatar
Björn Peemöller committed
128
129
130
131
>   where
>     fcy      = FlatCurry            `elem` optTargetTypes opts
>     xml      = FlatXml              `elem` optTargetTypes opts
>     withFlat = or [fcy, xml]
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
>     likeFlat = ExtendedFlatCurry `notElem` optTargetTypes opts

\end{verbatim}
An implicit import of the prelude is added to the declarations of
every module, except for the prelude itself, or when the import is disabled
by a compiler option. If no explicit import for the prelude is present,
the prelude is imported unqualified, otherwise a qualified import is added.
\begin{verbatim}

> importPrelude :: Options -> FilePath -> Module -> Module
> importPrelude opts fn m@(Module mid es ds)
>     -- the Prelude itself
>   | mid == preludeMIdent          = m
>     -- disabled by compiler option
>   | noImpPrelude                  = m
>     -- already imported
>   | preludeMIdent `elem` imported = m
>     -- let's add it!
>   | otherwise                     = Module mid es (preludeImp : ds)
>   where
>     noImpPrelude = NoImplicitPrelude `elem` optExtensions opts
>     preludeImp   = ImportDecl (first fn) preludeMIdent
>                    False   -- qualified?
>                    Nothing -- no alias
>                    Nothing -- no selection of types, functions, etc.
>     imported     = [imp | (ImportDecl _ imp _ _ _) <- ds]
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
158

Björn Peemöller 's avatar
Björn Peemöller committed
159
160
161
162
163
164
165
166
167
168
169
170
\end{verbatim}
A module which doesn't contain a \texttt{module ... where} declaration
obtains its filename as module identifier (unlike the definition in
Haskell and original MCC where a module obtains \texttt{main}).
\begin{verbatim}

> patchModuleId :: FilePath -> Module -> Module
> patchModuleId fn m@(Module mid mexports decls)
>   | moduleName mid == "main"
>     = Module (mkMIdent [takeBaseName fn]) mexports decls
>   | otherwise
>     = m
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
171

Björn Peemöller 's avatar
Björn Peemöller committed
172
> -- |Check whether the 'ModuleIdent' and the 'FilePath' fit together
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
173
174
> checkModuleId :: Monad m => FilePath -> Module -> m ()
> checkModuleId fn (Module mid _ _)
Björn Peemöller 's avatar
Björn Peemöller committed
175
176
177
178
179
180
181
182
>   | last (moduleQualifiers mid) == takeBaseName fn
>     = return ()
>   | otherwise
>     = error $ "module \"" ++ moduleName mid
>               ++ "\" must be in a file \"" ++ moduleName mid
>               ++ ".curry\""

\end{verbatim}
183
184
185
186
187
188
189
If an import declaration for a module is found, the compiler first
checks whether an import for the module is already pending. In this
case the module imports are cyclic which is not allowed in Curry. The
compilation will therefore be aborted. Next, the compiler checks
whether the module has been imported already. If so, nothing needs to
be done, otherwise the interface will be searched for in the import paths
and compiled.
Björn Peemöller 's avatar
Björn Peemöller committed
190
191
\begin{verbatim}

192
193
194
195
196
> -- |Load the interface files into the 'ModuleEnv'
> loadInterfaces :: [FilePath] -> Module -> IO ModuleEnv
> loadInterfaces paths (Module m _ ds) =
>   foldM (loadInterface paths [m]) Map.empty
>         [(p, m') | ImportDecl p m' _ _ _ <- ds]
Björn Peemöller 's avatar
Björn Peemöller committed
197

198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
> loadInterface :: [FilePath] -> [ModuleIdent] -> ModuleEnv ->
>     (Position, ModuleIdent) -> IO ModuleEnv
> loadInterface paths ctxt mEnv (p, m)
>   | m `elem` ctxt       = errorAt p (cyclicImport m (takeWhile (/= m) ctxt))
>   | m `Map.member` mEnv = return mEnv
>   | otherwise           = lookupInterface paths m >>=
>       maybe (errorAt p (interfaceNotFound m))
>             (compileInterface paths ctxt mEnv m)

\end{verbatim}
After reading an interface, all imported interfaces are recursively
loaded and entered into the interface's environment. There is no need
to check FlatCurry-Interfaces, since these files contain automatically
generated FlatCurry terms (type \texttt{Prog}).
\begin{verbatim}

> compileInterface :: [FilePath] -> [ModuleIdent] -> ModuleEnv -> ModuleIdent
>                  -> FilePath -> IO ModuleEnv
> compileInterface paths ctxt mEnv m fn = do
>   mintf <- readFlatInterface fn
>   let intf = fromMaybe (errorAt (first fn) (interfaceNotFound m)) mintf
>       (Prog modul _ _ _ _) = intf
220
>       m' = fromModuleName modul
221
222
223
224
225
226
227
>   unless (m' == m) (errorAt (first fn) (wrongInterface m m'))
>   mEnv' <- loadFlatInterfaces paths ctxt mEnv intf
>   return $ bindFlatInterface intf mEnv'

> loadFlatInterfaces :: [FilePath] -> [ModuleIdent] -> ModuleEnv -> Prog
>                    -> IO ModuleEnv
> loadFlatInterfaces paths ctxt mEnv (Prog m is _ _ _) =
228
>   foldM (loadInterface paths (fromModuleName m:ctxt))
229
>         mEnv
230
>         (map (\i -> (p, fromModuleName i)) is)
231
232
233
234
>  where p = first m

Interface files are updated by the Curry builder when necessary.
(see module \texttt{CurryBuilder}).
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
235

Björn Peemöller 's avatar
Björn Peemöller committed
236
> -- |
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
237
> simpleCheckModule :: Options -> ModuleEnv -> Module
238
>   -> IO (ValueEnv, TCEnv, ArityEnv, Module, Interface, [Message])
Björn Peemöller 's avatar
Björn Peemöller committed
239
> simpleCheckModule opts mEnv (Module m es ds) = do
240
241
>   showWarnings opts warnMsgs
>   return (tyEnv'', tcEnv, aEnv'', modul, intf, warnMsgs)
Björn Peemöller 's avatar
Björn Peemöller committed
242
>   where
243
>     -- split import/other declarations
Björn Peemöller 's avatar
Björn Peemöller committed
244
245
246
>     (impDs, topDs) = partition isImportDecl ds
>     -- build import environment
>     importEnv = fromDeclList impDs
247
>     -- add information of imported modules
Björn Peemöller 's avatar
Björn Peemöller committed
248
249
250
251
252
253
254
255
256
257
>     (pEnv, tcEnv, tyEnv, aEnv) = importModules mEnv impDs
>     -- check for warnings
>     warnMsgs = warnCheck m tyEnv impDs topDs
>     -- check kinds, syntax, precedence
>     (pEnv', topDs') = precCheck m pEnv
>                     $ syntaxCheck withExt m importEnv aEnv tyEnv tcEnv
>                     $ kindCheck m tcEnv topDs
>     withExt = BerndExtension `elem` optExtensions opts
>     ds' = impDs ++ qual m tyEnv topDs'
>     modul = (Module m es ds') --expandInterface (Module m es ds') tcEnv tyEnv
258
>     (_, tcEnv'', tyEnv'', aEnv'') = qualifyEnv mEnv pEnv' tcEnv tyEnv aEnv
Björn Peemöller 's avatar
Björn Peemöller committed
259
>     intf = exportInterface modul pEnv' tcEnv'' tyEnv''
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
260
261

> checkModule :: Options -> ModuleEnv -> Module
262
>   -> IO (ValueEnv, TCEnv, ArityEnv, Module, Interface, [Message])
Björn Peemöller 's avatar
Björn Peemöller committed
263
> checkModule opts mEnv (Module m es ds) = do
264
>   showWarnings opts warnMsgs
265
>   when (m == mkMIdent ["field114..."]) (error (show es)) -- TODO hack?
266
>   return (tyEnv''', tcEnv', aEnv'', modul, intf, warnMsgs)
Björn Peemöller 's avatar
Björn Peemöller committed
267
268
269
270
271
272
273
274
275
276
277
278
279
280
>   where
>     (impDs, topDs) = partition isImportDecl ds
>     iEnv = foldr bindAlias initIEnv impDs
>     (pEnv, tcEnvI, tyEnvI, aEnv) = importModules mEnv impDs
>     tcEnv = if withExt
>               then fmap (expandRecordTC tcEnvI) tcEnvI
>               else tcEnvI
>     lEnv = importLabels mEnv impDs
>     tyEnvL = addImportedLabels m lEnv tyEnvI
>     tyEnv = if withExt
>               then fmap (expandRecordTypes tcEnv) tyEnvL
>               else tyEnvI
>     warnMsgs = warnCheck m tyEnv impDs topDs
>     withExt = BerndExtension `elem` optExtensions opts
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
281
282
283
284
285
286
>         -- fre: replaced the argument aEnv by aEnv'' in the
>         --      expression below. This fixed a bug that occured
>         --      when one imported a module qualified that
>         --      exported a function from another module.
>         --      However, there is now a cyclic dependecy
>         --      but tests didn't show any problems.
287
288
>         -- bjp: Removed the fix of fre because it introduced
>         --      missing arities
Björn Peemöller 's avatar
Björn Peemöller committed
289
>     (pEnv', topDs') = precCheck m pEnv
290
>                     $ syntaxCheck withExt m iEnv aEnv tyEnv tcEnv
Björn Peemöller 's avatar
Björn Peemöller committed
291
292
293
294
295
296
297
298
299
300
301
302
>                     $ kindCheck m tcEnv topDs
>     (tcEnv', tyEnv') = typeCheck m tcEnv tyEnv topDs'
>     ds' = impDs ++ qual m tyEnv' topDs'
>     modul = expandInterface (Module m es ds') tcEnv' tyEnv'
>     (pEnv'', tcEnv'', tyEnv'', aEnv'')
>        = qualifyEnv mEnv pEnv' tcEnv' tyEnv' aEnv
>     tyEnvL' = addImportedLabels m lEnv tyEnv''
>     tyEnv''' = if withExt
>                 then fmap (expandRecordTypes tcEnv'') tyEnvL'
>                 else tyEnv''
>     --tyEnv''' = addImportedLabels m lEnv tyEnv''
>     intf = exportInterface modul pEnv'' tcEnv'' tyEnv'''
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
303

Björn Peemöller 's avatar
Björn Peemöller committed
304
> -- |Translate FlatCurry into the intermediate language 'IL'
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
305
> transModule :: Bool -> Bool -> Bool -> ModuleEnv -> ValueEnv -> TCEnv
Björn Peemöller 's avatar
Björn Peemöller committed
306
>      -> ArityEnv -> Module -> (IL.Module, ArityEnv, [(DumpLevel, Doc)])
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
307
> transModule flat' _debug _trusted mEnv tyEnv tcEnv aEnv (Module m es ds) =
Björn Peemöller 's avatar
Björn Peemöller committed
308
>   (il', aEnv', dumps)
Björn Peemöller 's avatar
Björn Peemöller committed
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
>   where
>     topDs = filter (not . isImportDecl) ds
>     evEnv = evalEnv topDs
>     (desugared, tyEnv') = desugar tyEnv tcEnv (Module m es topDs)
>     (simplified, tyEnv'') = simplify flat' tyEnv' evEnv desugared
>     (lifted, tyEnv''', evEnv') = lift tyEnv'' evEnv simplified
>     aEnv' = bindArities aEnv lifted
>     il = ilTrans flat' tyEnv''' tcEnv evEnv' lifted
>     il' = completeCase mEnv il
>     dumps = [ (DumpRenamed   , ppModule (Module m es ds)      )
>             , (DumpTypes     , ppTypes m (localBindings tyEnv))
>             , (DumpDesugared , ppModule desugared             )
>             , (DumpSimplified, ppModule simplified            )
>             , (DumpLifted    , ppModule lifted                )
>             , (DumpIL        , IL.ppModule il                 )
>             , (DumpCase      , IL.ppModule il'                )
>             ]
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
326
327
328
329

> qualifyEnv :: ModuleEnv -> PEnv -> TCEnv -> ValueEnv -> ArityEnv
>     -> (PEnv,TCEnv,ValueEnv,ArityEnv)
> qualifyEnv mEnv pEnv tcEnv tyEnv aEnv =
Björn Peemöller 's avatar
Björn Peemöller committed
330
331
332
333
334
335
336
337
338
339
340
341
342
343
>   ( foldr bindQual   pEnv'  (localBindings pEnv )
>   , foldr bindQual   tcEnv' (localBindings tcEnv)
>   , foldr bindGlobal tyEnv' (localBindings tyEnv)
>   , foldr bindQual   aEnv'  (localBindings aEnv )
>   )
>   where
>     (pEnv', tcEnv', tyEnv', aEnv') =
>       foldl importInterface' initEnvs (Map.toList mEnv)
>     importInterface' (pEnv1,tcEnv1,tyEnv1,aEnv1) (m,ds) =
>       importInterfaceIntf (Interface m ds) pEnv1 tcEnv1 tyEnv1 aEnv1
>     bindQual (_, y) = qualBindTopEnv "Modules.qualifyEnv" (origName y) y
>     bindGlobal (x, y)
>       | uniqueId x == 0 = bindQual (x, y)
>       | otherwise = bindTopEnv "Modules.qualifyEnv" x y
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
344
345
346
347
348
349
350

\end{verbatim}

The function \texttt{importModules} brings the declarations of all
imported modules into scope for the current module.
\begin{verbatim}

351
> importModules :: ModuleEnv -> [Decl] -> (PEnv, TCEnv, ValueEnv, ArityEnv)
Björn Peemöller 's avatar
Björn Peemöller committed
352
353
354
> importModules mEnv ds = (pEnv, importUnifyData tcEnv, tyEnv, aEnv)
>   where
>     (pEnv,tcEnv,tyEnv,aEnv) = foldl importModule initEnvs ds
355
>     importModule (pEnv', tcEnv', tyEnv', aEnv') (ImportDecl _ m q asM is) =
Björn Peemöller 's avatar
Björn Peemöller committed
356
>       case Map.lookup m mEnv of
357
>         Just ds1 -> importInterface (fromMaybe m asM) q is
Björn Peemöller 's avatar
Björn Peemöller committed
358
>                       (Interface m ds1) pEnv' tcEnv' tyEnv' aEnv'
359
>         Nothing  -> internalError $ "importModule: Map.lookup " ++ show m ++ " " ++ show mEnv
Björn Peemöller 's avatar
Björn Peemöller committed
360
361
362
363
>     importModule t _ = t

> initEnvs :: (PEnv, TCEnv, ValueEnv, ArityEnv)
> initEnvs = (initPEnv, initTCEnv, initDCEnv, initAEnv)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378

\end{verbatim}
Unlike unsual identifiers like in functions, types etc. identifiers
of labels are always represented unqualified within the whole context
of compilation. Since the common type environment (type \texttt{ValueEnv})
has some problems with handling imported unqualified identifiers, it is
necessary to add the type information for labels seperately. For this reason
the function \texttt{importLabels} generates an environment containing
all imported labels and the function \texttt{addImportedLabels} adds this
content to a type environment.
\begin{verbatim}

> importLabels :: ModuleEnv -> [Decl] -> LabelEnv
> importLabels mEnv ds = foldl importLabelTypes Map.empty ds
>   where
Björn Peemöller 's avatar
Björn Peemöller committed
379
380
381
382
383
>     importLabelTypes lEnv (ImportDecl p m _ asM is) =
>       case Map.lookup m mEnv of
>         Just ds' -> foldl (importLabelType p (fromMaybe m asM) is) lEnv ds'
>         Nothing  -> internalError "importLabels"
>     importLabelTypes lEnv _ = lEnv
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
384
>
Björn Peemöller 's avatar
Björn Peemöller committed
385
386
387
388
>     importLabelType p m is lEnv (ITypeDecl _ r _ (RecordType fs _)) =
>      foldl (insertLabelType p m r' (getImportSpec r' is)) lEnv fs
>      where r' = qualifyWith m (fromRecordExtId (unqualify r))
>     importLabelType _ _ _  lEnv _ = lEnv
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
389
>
390
391
392
393
394
395
>     insertLabelType _ _ r (Just (ImportTypeAll _)) lEnv ([l],ty) =
>       bindLabelType l r (toType [] ty) lEnv
>     insertLabelType _ _ r (Just (ImportTypeWith _ ls)) lEnv ([l],ty)
>       | l `elem` ls = bindLabelType l r (toType [] ty) lEnv
>       | otherwise   = lEnv
>     insertLabelType _ _ _ _ lEnv _ = lEnv
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
396
>
397
398
399
400
>     getImportSpec r (Just (Importing _ is')) =
>       find (isImported (unqualify r)) is'
>     getImportSpec r Nothing = Just (ImportTypeAll (unqualify r))
>     getImportSpec _ _ = Nothing
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
401
>
402
403
404
>     isImported r (Import r') = r == r'
>     isImported r (ImportTypeWith r' _) = r == r'
>     isImported r (ImportTypeAll r') = r == r'
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461

> addImportedLabels :: ModuleIdent -> LabelEnv -> ValueEnv -> ValueEnv
> addImportedLabels m lEnv tyEnv =
>   foldr addLabelType tyEnv (concatMap snd (Map.toList lEnv))
>   where
>   addLabelType (LabelType l r ty) tyEnv' =
>     let m' = fromMaybe m (qualidMod r)
>     in  importTopEnv m' l
>                      (Label (qualify l) (qualQualify m' r) (polyType ty))
>	               tyEnv'

\end{verbatim}
Fully expand all (imported) record types within the type constructor
environment and the type environment.
Note: the record types for the current module are expanded within the
type check.
\begin{verbatim}

> expandRecordTC :: TCEnv -> TypeInfo -> TypeInfo
> expandRecordTC tcEnv (DataType qid n args) =
>   DataType qid n (map (maybe Nothing (Just . (expandData tcEnv))) args)
> expandRecordTC tcEnv (RenamingType qid n (Data ident m ty)) =
>   RenamingType qid n (Data ident m (expandRecords tcEnv ty))
> expandRecordTC tcEnv (AliasType qid n ty) =
>   AliasType qid n (expandRecords tcEnv ty)

> expandData :: TCEnv -> Data [Type] -> Data [Type]
> expandData tcEnv (Data ident n tys) =
>   Data ident n (map (expandRecords tcEnv) tys)

> expandRecordTypes :: TCEnv -> ValueInfo -> ValueInfo
> expandRecordTypes tcEnv (DataConstructor qid (ForAllExist n m ty)) =
>   DataConstructor qid (ForAllExist n m (expandRecords tcEnv ty))
> expandRecordTypes tcEnv (NewtypeConstructor qid (ForAllExist n m ty)) =
>   NewtypeConstructor qid (ForAllExist n m (expandRecords tcEnv ty))
> expandRecordTypes tcEnv (Value qid (ForAll n ty)) =
>   Value qid (ForAll n (expandRecords tcEnv ty))
> expandRecordTypes tcEnv (Label qid r (ForAll n ty)) =
>   Label qid r (ForAll n (expandRecords tcEnv ty))

> expandRecords :: TCEnv -> Type -> Type
> expandRecords tcEnv (TypeConstructor qid tys) =
>   case (qualLookupTC qid tcEnv) of
>     [AliasType _ _ rty@(TypeRecord _ _)]
>       -> expandRecords tcEnv
>            (expandAliasType (map (expandRecords tcEnv) tys) rty)
>     _ -> TypeConstructor qid (map (expandRecords tcEnv) tys)
> expandRecords tcEnv (TypeConstrained tys v) =
>   TypeConstrained (map (expandRecords tcEnv) tys) v
> expandRecords tcEnv (TypeArrow ty1 ty2) =
>   TypeArrow (expandRecords tcEnv ty1) (expandRecords tcEnv ty2)
> expandRecords tcEnv (TypeRecord fs rv) =
>   TypeRecord (map (\ (l,ty) -> (l,expandRecords tcEnv ty)) fs) rv
> expandRecords _ ty = ty



Björn Peemöller 's avatar
Björn Peemöller committed
462
463
464
465
-- ---------------------------------------------------------------------------
-- File Output
-- ---------------------------------------------------------------------------

Björn Peemöller 's avatar
Björn Peemöller committed
466
> -- |Export an 'IL.Module' into an XML file
Björn Peemöller 's avatar
Björn Peemöller committed
467
468
469
470
471
> writeXML :: Bool -> Maybe FilePath -> FilePath -> CurryEnv -> IL.Module -> IO ()
> writeXML sub tfn sfn cEnv il = writeModule sub ofn (showln code)
>   where ofn  = fromMaybe (xmlName sfn) tfn
>         code = (IL.xmlModule cEnv il)

Björn Peemöller 's avatar
Björn Peemöller committed
472
> -- |Export an 'IL.Module' into a FlatCurry file
Björn Peemöller 's avatar
Björn Peemöller committed
473
474
475
476
477
478
> writeFlat :: Options -> Maybe FilePath -> FilePath -> CurryEnv -> ModuleEnv
>              -> ValueEnv -> TCEnv -> ArityEnv -> IL.Module -> IO Prog
> writeFlat opts tfn sfn cEnv mEnv tyEnv tcEnv aEnv il
>   = writeFlatFile opts (genFlatCurry opts cEnv mEnv tyEnv tcEnv aEnv il)
>                        (fromMaybe (flatName sfn) tfn)

479
> writeFlatFile :: Options -> (Prog, [Message]) -> String -> IO Prog
Björn Peemöller 's avatar
Björn Peemöller committed
480
> writeFlatFile opts (res, msgs) fname = do
481
>   showWarnings opts msgs
Björn Peemöller 's avatar
Björn Peemöller committed
482
483
>   when extended $ writeExtendedFlat sub fname res
>   when flat     $ writeFlatCurry    sub fname res
Björn Peemöller 's avatar
Björn Peemöller committed
484
>   return res
Björn Peemöller 's avatar
Björn Peemöller committed
485
486
487
488
>   where
>     sub      = optUseSubdir opts
>     extended = ExtendedFlatCurry `elem` optTargetTypes opts
>     flat     = FlatCurry         `elem` optTargetTypes opts
Björn Peemöller 's avatar
Björn Peemöller committed
489
490
491
492
493
494
495
496
497
498
499
500
501
502

> writeTypedAbs :: Bool -> Maybe FilePath -> FilePath -> ValueEnv -> TCEnv -> Module -> IO ()
> writeTypedAbs sub tfn sfn tyEnv tcEnv modul
>   = AC.writeCurry sub fname (genTypedAbstract tyEnv tcEnv modul)
>   where fname = fromMaybe (acyName sfn) tfn

> writeUntypedAbs :: Bool -> Maybe FilePath -> FilePath -> ValueEnv -> TCEnv -> Module -> IO ()
> writeUntypedAbs sub tfn sfn tyEnv tcEnv modul
>   = AC.writeCurry sub fname (genUntypedAbstract tyEnv tcEnv modul)
>   where fname = fromMaybe (uacyName sfn) tfn

> showln :: Show a => a -> String
> showln x = shows x "\n"

Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
503
504
505
506
507
\end{verbatim}
The \texttt{doDump} function writes the selected information to the
standard output.
\begin{verbatim}

508
509
510
511
> doDump :: Options -> (DumpLevel, Doc) -> IO ()
> doDump opts (dl, x) = when (dl `elem` optDumps opts) $ print
>   (text hd $$ text (replicate (length hd) '=') $$ x)
>   where hd = dumpHeader dl
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
512

513
514
515
516
> dumpHeader :: DumpLevel -> String
> dumpHeader DumpRenamed    = "Module after renaming"
> dumpHeader DumpTypes      = "Types"
> dumpHeader DumpDesugared  = "Source code after desugaring"
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
517
> dumpHeader DumpSimplified = "Source code after simplification"
518
519
520
> dumpHeader DumpLifted     = "Source code after lifting"
> dumpHeader DumpIL         = "Intermediate code"
> dumpHeader DumpCase       = "Intermediate code after case simplification"
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
521
522
523
524
525
526
527
528
529
530
531

\end{verbatim}
The functions \texttt{genFlat} and \texttt{genAbstract} generate
flat and abstract curry representations depending on the specified option.
If the interface of a modified Curry module did not change, the corresponding
file name will be returned within the result of \texttt{genFlat} (depending
on the compiler flag "force") and other modules importing this module won't
be dependent on it any longer.
\begin{verbatim}

> genFlat :: Options -> FilePath -> ModuleEnv -> ValueEnv -> TCEnv -> ArityEnv
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
>            -> Interface -> Module -> IL.Module -> IO ()
> genFlat opts fname mEnv tyEnv tcEnv aEnv intf modul il = do
>   when fcy $ do
>     _ <- writeFlat opts Nothing fname cEnv mEnv tyEnv tcEnv aEnv il
>     let (flatInterface,intMsgs) = genFlatInterface opts cEnv mEnv tyEnv tcEnv aEnv il
>     if optForce opts
>       then writeInterface flatInterface intMsgs
>       else do
>         mfint <- readFlatInterface fintName
>         let flatIntf = fromMaybe emptyIntf mfint
>         when (mfint == mfint  -- necessary to close the file 'fintName'
>               && not (interfaceCheck flatIntf flatInterface)) $
>            writeInterface flatInterface intMsgs
>   when xml $ writeXML (optUseSubdir opts) (optOutput opts) fname cEnv il
>   where
>     fcy = FlatCurry `elem` optTargetTypes opts
>     xml = FlatXml `elem` optTargetTypes opts
>     fintName = flatIntName fname
>     cEnv = curryEnv mEnv tcEnv intf modul
>     emptyIntf = Prog "" [] [] [] []
>     writeInterface intf' msgs = do
>       showWarnings opts msgs
>       writeFlatCurry (optUseSubdir opts) fintName intf'


> genAbstract :: Options -> FilePath  -> ValueEnv -> TCEnv -> Module -> IO ()
> genAbstract opts fname tyEnv tcEnv modul = do
>   when  acy $ writeTypedAbs subdir Nothing fname tyEnv tcEnv modul
>   when uacy $ writeUntypedAbs subdir Nothing fname tyEnv tcEnv modul
>   where
>     subdir = optUseSubdir opts
>     acy    = AbstractCurry `elem` optTargetTypes opts
>     uacy   = UntypedAbstractCurry `elem` optTargetTypes opts

Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
566

Björn Peemöller 's avatar
Björn Peemöller committed
567
> genParsed :: Options -> FilePath -> Module -> IO ()
568
> genParsed opts fn modul = when src $ writeModule subdir outputFile modString
Björn Peemöller 's avatar
Björn Peemöller committed
569
>   where
570
571
>     src        = Parsed `elem` optTargetTypes opts
>     subdir     = optUseSubdir opts
Björn Peemöller 's avatar
Björn Peemöller committed
572
573
574
>     outputFile = fromMaybe (sourceRepName fn) (optOutput opts)
>     modString  = showModule modul

575
> showWarnings :: Options -> [Message] -> IO ()
Björn Peemöller 's avatar
Björn Peemöller committed
576
577
> showWarnings opts msgs = when (optWarn opts)
>                        $ putErrsLn $ map showWarning msgs
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613

\end{verbatim}
The function \texttt{ppTypes} is used for pretty-printing the types
from the type environment.
\begin{verbatim}

> ppTypes :: ModuleIdent -> [(Ident,ValueInfo)] -> Doc
> ppTypes m = vcat . map (ppIDecl . mkDecl) . filter (isValue . snd)
>   where mkDecl (v,Value _ (ForAll _ ty)) =
>           IFunctionDecl undefined (qualify v) (arrowArity ty)
>		      (fromQualType m ty)
>         mkDecl _ = error "Modules.ppTypes.mkDecl: no pattern match"
>         isValue (DataConstructor _ _) = False
>         isValue (NewtypeConstructor _ _) = False
>         isValue (Value _ _) = True
>         isValue (Label _ _ _) = False

\end{verbatim}
Error functions.
\begin{verbatim}

> interfaceNotFound :: ModuleIdent -> String
> interfaceNotFound m = "Interface for module " ++ moduleName m ++ " not found"

> cyclicImport :: ModuleIdent -> [ModuleIdent] -> String
> cyclicImport m [] = "Recursive import for module " ++ moduleName m
> cyclicImport m ms =
>   "Cyclic import dependency between modules " ++ moduleName m ++
>     modules "" ms
>   where modules comm [m1] = comm ++ " and " ++ moduleName m1
>         modules _ (m1:ms1) = ", " ++ moduleName m1 ++ modules "," ms1
>         modules _ [] = error "Modules.cyclicImport.modules: empty list"

> wrongInterface :: ModuleIdent -> ModuleIdent -> String
> wrongInterface m m' =
>   "Expected interface for " ++ show m ++ " but found " ++ show m'
614
>   ++ show (moduleQualifiers m, moduleQualifiers m')
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
615
616
617
618
619

\end{verbatim}

> bindFlatInterface :: Prog -> ModuleEnv -> ModuleEnv
> bindFlatInterface (Prog m imps ts fs os)
620
>    = Map.insert (fromModuleName m)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
621
622
623
624
625
626
>      ((map genIImportDecl imps)
>       ++ (map genITypeDecl ts')
>       ++ (map genIFuncDecl fs)
>       ++ (map genIOpDecl os))
>  where
>  genIImportDecl :: String -> IDecl
627
>  genIImportDecl = IImportDecl pos . fromModuleName
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
>
>  genITypeDecl :: TypeDecl -> IDecl
>  genITypeDecl (Type qn _ is cs)
>     | recordExt `isPrefixOf` localName qn
>       = ITypeDecl pos
>                   (genQualIdent qn)
>	            (map (genVarIndexIdent "a") is)
>	            (RecordType (map genLabeledType cs) Nothing)
>     | otherwise
>       = IDataDecl pos
>                   (genQualIdent qn)
>                   (map (genVarIndexIdent "a") is)
>                   (map (Just . genConstrDecl) cs)
>  genITypeDecl (TypeSyn qn _ is t)
>     = ITypeDecl pos
>                 (genQualIdent qn)
>                 (map (genVarIndexIdent "a") is)
>                 (genTypeExpr t)
>
>  genIFuncDecl :: FuncDecl -> IDecl
>  genIFuncDecl (Func qn a _ t _)
>     = IFunctionDecl pos (genQualIdent qn) a (genTypeExpr t)
>
>  genIOpDecl :: OpDecl -> IDecl
>  genIOpDecl (Op qn f p) = IInfixDecl pos (genInfix f) p  (genQualIdent qn)
>
>  genConstrDecl :: ConsDecl -> ConstrDecl
>  genConstrDecl (Cons qn _ _ ts1)
>     = ConstrDecl pos [] (mkIdent (localName qn)) (map genTypeExpr ts1)
>
>  genLabeledType :: EF.ConsDecl -> ([Ident],Curry.Syntax.TypeExpr)
>  genLabeledType (Cons qn _ _ [t])
>     = ([renameLabel (fromLabelExtId (mkIdent $ localName qn))], genTypeExpr t)
>  genLabeledType _ = error "Modules.bindFlatInterface.genLabeledType: no pattern match"
>
>  genTypeExpr :: EF.TypeExpr -> Curry.Syntax.TypeExpr
>  genTypeExpr (TVar i)
>     = VariableType (genVarIndexIdent "a" i)
>  genTypeExpr (FuncType t1 t2)
>     = ArrowType (genTypeExpr t1) (genTypeExpr t2)
>  genTypeExpr (TCons qn ts1)
>     = ConstructorType (genQualIdent qn) (map genTypeExpr ts1)
>
>  genInfix :: EF.Fixity -> Infix
>  genInfix EF.InfixOp  = Infix
>  genInfix EF.InfixlOp = InfixL
>  genInfix EF.InfixrOp = InfixR
>
>  genQualIdent :: EF.QName -> QualIdent
>  genQualIdent EF.QName { modName = modul, localName = lname } =
678
>    qualifyWith (fromModuleName modul) (mkIdent lname)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
>
>  genVarIndexIdent :: String -> Int -> Ident
>  genVarIndexIdent v i = mkIdent (v ++ show i)
>
>  isSpecialPreludeType :: TypeDecl -> Bool
>  isSpecialPreludeType (Type EF.QName { modName = modul, localName = lname} _ _ _)
>     = (lname == "[]" || lname == "()") && modul == "Prelude"
>  isSpecialPreludeType _ = False
>
>  pos = first m
>  ts' = filter (not . isSpecialPreludeType) ts

\end{verbatim}
The label environment is used to store information of labels.
Unlike unsual identifiers like in functions, types etc. identifiers
of labels are always represented unqualified. Since the common type
environment (type \texttt{ValueEnv}) has some problems with handling
imported unqualified identifiers, it is necessary to process the type
information for labels seperately.
\begin{verbatim}

> data LabelInfo = LabelType Ident QualIdent Type deriving Show

> type LabelEnv = Map.Map Ident [LabelInfo]

> bindLabelType :: Ident -> QualIdent -> Type -> LabelEnv -> LabelEnv
> bindLabelType l r ty = Map.insertWith (++) l [LabelType l r ty]