Modules.hs 12.3 KB
Newer Older
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
{- |
    Module      :  $Header$
    Description :  Compilation of a single module
    Copyright   :  (c) 1999-2004, Wolfgang Lux
                       2005, Martin Engelke (men@informatik.uni-kiel.de)
                       2007, Sebastian Fischer (sebf@informatik.uni-kiel.de)
                       2011, Björn Peemöller (bjp@informatik.uni-kiel.de)
    License     :  OtherLicense

    Maintainer  :  bjp@informatik.uni-kiel.de
    Stability   :  experimental
    Portability :  portable

    This module controls the compilation of modules.
-}

module Modules
  ( compileModule, loadModule, checkModuleHeader, checkModule
  ) where

import Control.Monad (liftM, unless, when)
import Data.Maybe (fromMaybe)

import Curry.Base.MessageMonad
import Curry.Base.Position
import Curry.Base.Ident
import Curry.ExtendedFlat.InterfaceEquality (eqInterface)
import Curry.Files.Filenames
import Curry.Files.PathUtils

31
import Base.Messages (abortWith, errorMessages, putErrsLn)
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

import Env.Eval (evalEnv)

-- source representations
import qualified Curry.AbstractCurry as AC
import qualified Curry.ExtendedFlat.Type as EF
import qualified Curry.Syntax as CS
import qualified IL as IL

import Checks
import CompilerEnv
import CompilerOpts
import Exports
import Generators
import Imports
import Interfaces
import ModuleSummary
import Transformations

-- The function '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.
64
--
65
66
67
-- The compiler automatically loads the prelude when compiling any
-- module, except for the prelude itself, by adding an appropriate import
-- declaration to the module.
68
--
69
70
71
72
73
74
75
-- 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.

compileModule :: Options -> FilePath -> IO ()
compileModule opts fn = do
  loaded <- loadModule opts fn
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
  case uncurry (checkModule opts) loaded of
    CheckFailed errs -> errorMessages errs
    CheckSuccess (env, modul) -> do
      showWarnings opts $ uncurry warnCheck loaded
      writeParsed        opts fn     modul
      writeAbstractCurry opts fn env modul
      when withFlat $ do
        -- checkModule checks types, and then transModule introduces new
        -- functions (by lambda lifting in 'desugar'). Consequence: The
        -- types of the newly introduced functions are not inferred (hsi)
        let (env2, il, dumps) = transModule opts env modul
        -- dump intermediate results
        mapM_ (doDump opts) dumps
        -- generate target code
        let intf = exportInterface env2 modul
        let modSum = summarizeModule (tyConsEnv env2) intf modul
        writeFlat opts fn env2 modSum il
      where
        withFlat = any (`elem` optTargetTypes opts)
                      [FlatCurry, FlatXml, ExtendedFlatCurry]
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117

-- ---------------------------------------------------------------------------
-- Loading a module
-- ---------------------------------------------------------------------------

loadModule :: Options -> FilePath -> IO (CompilerEnv, CS.Module)
loadModule opts fn = do
  -- read and parse module
  parsed <- (ok . CS.parseModule (not extTarget) fn) `liftM` readModule fn
  -- check module header
  let (mdl, hdrErrs) = checkModuleHeader opts fn parsed
  unless (null hdrErrs) $ abortWith hdrErrs
  -- load the imported interfaces into an InterfaceEnv
  iEnv <- loadInterfaces (optImportPaths opts) mdl
  -- add information of imported modules
  let env = importModules opts mdl iEnv
  return (env, mdl)
  where extTarget = ExtendedFlatCurry `elem` optTargetTypes opts

checkModuleHeader :: Options -> FilePath -> CS.Module -> (CS.Module, [String])
checkModuleHeader opts fn = checkModuleId fn
                          . importPrelude opts
118
                          . CS.patchModuleId fn
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

-- |Check whether the 'ModuleIdent' and the 'FilePath' fit together
checkModuleId :: FilePath -> CS.Module -> (CS.Module, [String])
checkModuleId fn m@(CS.Module mid _ _ _)
  | last (moduleQualifiers mid) == takeBaseName fn
  = (m, [])
  | otherwise
  = (m, [errModuleFileMismatch mid])

-- 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.

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

-- ---------------------------------------------------------------------------
-- Checking a module
-- ---------------------------------------------------------------------------

155
156
157
158
159
160
161
162
-- TODO: The order of the checks should be improved!
checkModule :: Options -> CompilerEnv -> CS.Module
            -> CheckResult (CompilerEnv, CS.Module)
checkModule opts env mdl = kindCheck env mdl -- should be only syntax checking ?
                       >>= uncurry (syntaxCheck opts)
                       >>= uncurry precCheck
                       >>= (if withTypeCheck then uncurry typeCheck else return)
                       >>= uncurry exportCheck
163
                       >>= return . (uncurry (qual opts))
164
  where
165
166
  withTypeCheck  = any (`elem` optTargetTypes opts)
                       [FlatCurry, ExtendedFlatCurry, FlatXml, AbstractCurry]
167
168
169
170
171
172
173

-- ---------------------------------------------------------------------------
-- Translating a module
-- ---------------------------------------------------------------------------

-- |Translate FlatCurry into the intermediate language 'IL'
transModule :: Options -> CompilerEnv -> CS.Module
174
            -> (CompilerEnv, IL.Module, [(DumpLevel, CompilerEnv, String)])
175
176
177
178
179
180
181
182
183
transModule opts env mdl = (env5, ilCaseComp, dumps)
  where
    flat' = FlatCurry `elem` optTargetTypes opts
    env0 = env { evalAnnotEnv = evalEnv mdl }
    (desugared , env1) = desugar        mdl        env0
    (simplified, env2) = simplify flat' desugared  env1
    (lifted    , env3) = lift           simplified env2
    (il        , env4) = ilTrans flat'  lifted     env3
    (ilCaseComp, env5) = completeCase   il         env4
184
185
186
187
188
189
    dumps = [ (DumpRenamed   , env , show $ CS.ppModule mdl       )
            , (DumpDesugared , env1, show $ CS.ppModule desugared )
            , (DumpSimplified, env2, show $ CS.ppModule simplified)
            , (DumpLifted    , env3, show $ CS.ppModule lifted    )
            , (DumpIL        , env4, show $ IL.ppModule il        )
            , (DumpCase      , env5, show $ IL.ppModule ilCaseComp)
190
191
192
193
194
195
196
197
198
199
            ]

-- ---------------------------------------------------------------------------
-- Writing output
-- ---------------------------------------------------------------------------

-- 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 'genFlat'
200
-- (depending on the compiler flag "force") and other modules importing this
201
202
203
204
205
206
207
208
209
210
211
212
-- module won't be dependent on it any longer.

-- |Output the parsed 'Module' on request
writeParsed :: Options -> FilePath -> CS.Module -> IO ()
writeParsed opts fn modul = when srcTarget $
  writeModule useSubDir targetFile source
  where
    srcTarget  = Parsed `elem` optTargetTypes opts
    useSubDir  = optUseSubdir opts
    targetFile = fromMaybe (sourceRepName fn) (optOutput opts)
    source     = CS.showModule modul

213
writeFlat :: Options -> FilePath -> CompilerEnv -> ModuleSummary -> IL.Module
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
254
255
256
257
258
          -> IO ()
writeFlat opts fn env modSum il = do
  writeFlatCurry opts fn env modSum il
  writeInterface opts fn env modSum il
  writeXML       opts fn     modSum il

-- |Export an 'IL.Module' into a FlatCurry file
writeFlatCurry :: Options -> FilePath -> CompilerEnv -> ModuleSummary
               -> IL.Module -> IO ()
writeFlatCurry opts fn env modSum il = do
  when (extTarget || fcyTarget) $ showWarnings opts msgs
  when extTarget $ EF.writeExtendedFlat useSubDir (extFlatName fn) prog
  when fcyTarget $ EF.writeFlatCurry    useSubDir (flatName fn)    prog
  where
    extTarget    = ExtendedFlatCurry `elem` optTargetTypes opts
    fcyTarget    = FlatCurry         `elem` optTargetTypes opts
    useSubDir    = optUseSubdir opts
    (prog, msgs) = genFlatCurry opts modSum env il

writeInterface :: Options -> FilePath -> CompilerEnv -> ModuleSummary
               -> IL.Module -> IO ()
writeInterface opts fn env modSum il
  | not (optInterface opts) = return ()
  | optForce opts           = outputInterface
  | otherwise               = do
      mfint <- EF.readFlatInterface targetFile
      let oldInterface = fromMaybe emptyIntf mfint
      when (mfint == mfint) $ return () -- necessary to close file -- TODO
      unless (oldInterface `eqInterface` newInterface) $ outputInterface
  where
    targetFile = flatIntName fn
    emptyIntf = EF.Prog "" [] [] [] []
    (newInterface, intMsgs) = genFlatInterface opts modSum env il
    outputInterface = do
      showWarnings opts intMsgs
      EF.writeFlatCurry (optUseSubdir opts) targetFile newInterface

-- |Export an 'IL.Module' into an XML file
writeXML :: Options -> FilePath -> ModuleSummary -> IL.Module -> IO ()
writeXML opts fn modSum il = when xmlTarget $
  writeModule useSubDir targetFile curryXml
  where
    xmlTarget  = FlatXml `elem` optTargetTypes opts
    useSubDir  = optUseSubdir opts
    targetFile = fromMaybe (xmlName fn) (optOutput opts)
Björn Peemöller 's avatar
Björn Peemöller committed
259
    curryXml   = shows (IL.xmlModule (interface modSum) (infixDecls modSum) il) "\n"
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277

writeAbstractCurry :: Options -> FilePath -> CompilerEnv -> CS.Module -> IO ()
writeAbstractCurry opts fname env modul = do
  when  acyTarget $ AC.writeCurry useSubDir (acyName fname)
                  $ genTypedAbstractCurry env modul
  when uacyTarget $ AC.writeCurry useSubDir (uacyName fname)
                  $ genUntypedAbstractCurry env modul
  where
    acyTarget  = AbstractCurry        `elem` optTargetTypes opts
    uacyTarget = UntypedAbstractCurry `elem` optTargetTypes opts
    useSubDir  = optUseSubdir opts

showWarnings :: Options -> [Message] -> IO ()
showWarnings opts msgs = when (optWarn opts)
                       $ putErrsLn $ map showWarning msgs

-- |The 'doDump' function writes the selected information to the
-- standard output.
278
279
280
doDump :: Options -> (DumpLevel, CompilerEnv, String) -> IO ()
doDump opts (level, env, dump) = when (level `elem` optDumps opts) $
  putStrLn $ unlines [showCompilerEnv env, header, replicate (length header) '=', dump]
281
282
283
284
285
286
287
288
289
290
291
292
293
  where header = dumpHeader level

dumpHeader :: DumpLevel -> String
dumpHeader DumpRenamed    = "Module after renaming"
dumpHeader DumpDesugared  = "Source code after desugaring"
dumpHeader DumpSimplified = "Source code after simplification"
dumpHeader DumpLifted     = "Source code after lifting"
dumpHeader DumpIL         = "Intermediate code"
dumpHeader DumpCase       = "Intermediate code after case completion"

errModuleFileMismatch :: ModuleIdent -> String
errModuleFileMismatch mid = "module \"" ++ moduleName mid
  ++ "\" must be in a file \"" ++ moduleName mid ++ ".(l)curry\""