Modules.hs 13 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
{- |
    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
18
  ( compileModule, loadModule, checkModuleHeader, checkModule, writeOutput
19
20
  ) where

21
import Control.Monad (unless, when)
22
import Data.Maybe (fromMaybe)
23
import Text.PrettyPrint
24
25

import Curry.Base.Ident
Björn Peemöller 's avatar
Björn Peemöller committed
26
27
import Curry.Base.Message (runMsg)
import Curry.Base.Position
28
29
30
31
import Curry.ExtendedFlat.InterfaceEquality (eqInterface)
import Curry.Files.Filenames
import Curry.Files.PathUtils

Björn Peemöller 's avatar
Björn Peemöller committed
32
33
import Base.Messages
  (Message, message, posMessage, warn, abortWithMessages)
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

-- 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
  case checkModule opts loaded of
77
    CheckFailed errs -> abortWithMessages errs
78
    CheckSuccess (env, mdl, dumps) -> do
Björn Peemöller 's avatar
Björn Peemöller committed
79
      warn opts $ warnCheck env mdl
80
81
      mapM_ (doDump opts) dumps
      writeOutput opts fn (env, mdl)
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100

writeOutput :: Options -> FilePath -> (CompilerEnv, CS.Module) -> IO ()
writeOutput opts fn (env, modul) = do
  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]
101
102
103
104
105
106
107

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

loadModule :: Options -> FilePath -> IO (CompilerEnv, CS.Module)
loadModule opts fn = do
108
109
110
  -- read module
  mbSrc <- readModule fn
  case mbSrc of
Björn Peemöller 's avatar
Björn Peemöller committed
111
    Nothing  -> abortWithMessages [message $ text $ "Missing file: " ++ fn] -- TODO
112
113
    Just src -> do
      -- parse module
114
      case runMsg $ CS.parseModule fn src of
Björn Peemöller 's avatar
Björn Peemöller committed
115
116
117
118
119
120
121
122
123
124
125
126
        Left err -> abortWithMessages [err]
        Right (parsed, _) -> do
          -- check module header
          let (mdl, hdrErrs) = checkModuleHeader opts fn parsed
          unless (null hdrErrs) $ abortWithMessages hdrErrs -- TODO
          -- load the imported interfaces into an InterfaceEnv
          (iEnv, intfErrs) <- loadInterfaces (optImportPaths opts) mdl
          unless (null intfErrs) $ abortWithMessages intfErrs -- TODO
          -- add information of imported modules
          let (env, impErrs) = importModules opts mdl iEnv
          unless (null impErrs) $ abortWithMessages impErrs -- TODO
          return (env, mdl)
127

128
checkModuleHeader :: Options -> FilePath -> CS.Module -> (CS.Module, [Message])
129
checkModuleHeader opts fn = checkModuleId fn
130
                          . importPrelude opts fn
131
                          . CS.patchModuleId fn
132
133

-- |Check whether the 'ModuleIdent' and the 'FilePath' fit together
134
checkModuleId :: FilePath -> CS.Module -> (CS.Module, [Message])
135
checkModuleId fn m@(CS.Module mid _ _ _)
136
  | last (midQualifiers mid) == takeBaseName fn
137
138
139
140
141
142
143
144
145
  = (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.

146
147
importPrelude :: Options -> FilePath -> CS.Module -> CS.Module
importPrelude opts fn m@(CS.Module mid es is ds)
148
149
150
151
152
153
154
155
156
    -- 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
157
  noImpPrelude = NoImplicitPrelude `elem` optExtensions opts
158
  preludeImp   = CS.ImportDecl (first fn) preludeMIdent
159
160
161
162
                  False   -- qualified?
                  Nothing -- no alias
                  Nothing -- no selection of types, functions, etc.
  imported     = [imp | (CS.ImportDecl _ imp _ _ _) <- is]
163
164
165
166
167

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

168
-- TODO: The order of the checks should be improved!
169
170
171
-- TODO (2012-01-05, bjp): The export specification check for untyped
--   AbstractCurry is deactivated as it requires the value information
--   collected by the type checker.
172
checkModule :: Options -> (CompilerEnv, CS.Module)
173
174
175
176
177
178
179
180
181
182
183
184
185
186
            -> CheckResult (CompilerEnv, CS.Module, [Dump])
checkModule opts (env, mdl) = do
  (env1, kc) <- kindCheck env mdl -- should be only syntax checking ?
  (env2, sc) <- syntaxCheck opts env1 kc
  (env3, pc) <- precCheck        env2 sc
  (env4, tc) <- if withTypeCheck
                   then typeCheck env3 pc >>= uncurry exportCheck
                   else return (env3, pc)
  (env5, ql) <- return $ qual opts env4 tc
  let dumps = [ (DumpParsed       , env , CS.showModule mdl)
              , (DumpKindChecked  , env1, CS.showModule kc)
              , (DumpSyntaxChecked, env2, CS.showModule sc)
              , (DumpPrecChecked  , env3, CS.showModule pc)
              , (DumpTypeChecked  , env4, CS.showModule tc)
Björn Peemöller 's avatar
Björn Peemöller committed
187
              , (DumpQualified    , env5, CS.showModule ql)
188
189
              ]
  return (env5, ql, dumps)
190
  where
191
192
  withTypeCheck = any (`elem` optTargetTypes opts)
                      [FlatCurry, ExtendedFlatCurry, FlatXml, AbstractCurry]
193
194
195
196
197

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

198
199
type Dump = (DumpLevel, CompilerEnv, String)

200
201
-- |Translate FlatCurry into the intermediate language 'IL'
transModule :: Options -> CompilerEnv -> CS.Module
202
            -> (CompilerEnv, IL.Module, [Dump])
203
204
transModule opts env mdl = (env5, ilCaseComp, dumps)
  where
205
  flat' = FlatCurry `elem` optTargetTypes opts
206
  (desugared , env1) = desugar        mdl        env
207
208
  (simplified, env2) = simplify flat' desugared  env1
  (lifted    , env3) = lift           simplified env2
Björn Peemöller 's avatar
Björn Peemöller committed
209
  (il        , env4) = ilTrans  flat' lifted     env3
210
  (ilCaseComp, env5) = completeCase   il         env4
211
212
213
214
215
  dumps = [ (DumpDesugared    , env1, show $ CS.ppModule desugared )
          , (DumpSimplified   , env2, show $ CS.ppModule simplified)
          , (DumpLifted       , env3, show $ CS.ppModule lifted    )
          , (DumpTranslated   , env4, show $ IL.ppModule il        )
          , (DumpCaseCompleted, env5, show $ IL.ppModule ilCaseComp)
216
          ]
217
218
219
220
221
222
223
224
225

-- ---------------------------------------------------------------------------
-- 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'
226
-- (depending on the compiler flag "force") and other modules importing this
227
228
229
230
231
232
233
-- 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
234
235
236
237
  srcTarget  = Parsed `elem` optTargetTypes opts
  useSubDir  = optUseSubdir opts
  targetFile = fromMaybe (sourceRepName fn) (optOutput opts)
  source     = CS.showModule modul
238

239
writeFlat :: Options -> FilePath -> CompilerEnv -> ModuleSummary -> IL.Module
240
241
          -> IO ()
writeFlat opts fn env modSum il = do
242
243
244
245
246
247
248
249
  when (extTarget || fcyTarget) $ do
    writeFlatCurry opts fn env modSum il
    writeInterface opts fn env modSum il
  when (xmlTarget) $ writeXML opts fn modSum il
  where
  extTarget    = ExtendedFlatCurry `elem` optTargetTypes opts
  fcyTarget    = FlatCurry         `elem` optTargetTypes opts
  xmlTarget    = FlatXml           `elem` optTargetTypes opts
250
251
252
253
254

-- |Export an 'IL.Module' into a FlatCurry file
writeFlatCurry :: Options -> FilePath -> CompilerEnv -> ModuleSummary
               -> IL.Module -> IO ()
writeFlatCurry opts fn env modSum il = do
Björn Peemöller 's avatar
Björn Peemöller committed
255
  warn opts msgs
256
  when extTarget $ EF.writeExtendedFlat useSubDir (extFlatName fn) prog
257
  when fcyTarget $ EF.writeFlatCurry    useSubDir (flatName    fn) prog
258
  where
259
260
261
262
  extTarget    = ExtendedFlatCurry `elem` optTargetTypes opts
  fcyTarget    = FlatCurry         `elem` optTargetTypes opts
  useSubDir    = optUseSubdir opts
  (prog, msgs) = genFlatCurry opts modSum env il
263

264
265
266
267
268
269
270
-- |Export an 'IL.Module' into an XML file
writeXML :: Options -> FilePath -> ModuleSummary -> IL.Module -> IO ()
writeXML opts fn modSum il = writeModule useSubDir (xmlName fn) curryXml
  where
  useSubDir = optUseSubdir opts
  curryXml  = shows (IL.xmlModule (interface modSum) (infixDecls modSum) il) "\n"

271
272
273
274
275
276
277
278
279
280
281
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
282
283
284
285
  targetFile = flatIntName fn
  emptyIntf = EF.Prog "" [] [] [] []
  (newInterface, intMsgs) = genFlatInterface opts modSum env il
  outputInterface = do
Björn Peemöller 's avatar
Björn Peemöller committed
286
    warn opts intMsgs
287
    EF.writeFlatCurry (optUseSubdir opts) targetFile newInterface
288
289
290
291
292
293
294
295

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
296
297
298
  acyTarget  = AbstractCurry        `elem` optTargetTypes opts
  uacyTarget = UntypedAbstractCurry `elem` optTargetTypes opts
  useSubDir  = optUseSubdir opts
299

300
-- |The 'dump' function writes the selected information to standard output.
Björn Peemöller 's avatar
Björn Peemöller committed
301
302
doDump :: Options -> Dump -> IO ()
doDump opts (level, env, dump) = when (level `elem` optDumps opts) $ do
303
304
  when (optDumpEnv opts) $ putStrLn $ showCompilerEnv env
  putStrLn $ unlines [header, replicate (length header) '=', dump]
305
306
307
308
309
310
  where
  header = lookupHeader dumpLevel
  lookupHeader []            = "Unknown dump level " ++ show level
  lookupHeader ((l,_,h):lhs)
    | level == l = h
    | otherwise  = lookupHeader lhs
311

312
errModuleFileMismatch :: ModuleIdent -> Message
313
314
315
errModuleFileMismatch mid = posMessage mid $ hsep $ map text
  [ "Module", moduleName mid, "must be in a file"
  , moduleName mid ++ ".(l)curry" ]