Modules.hs 12.6 KB
Newer Older
1
2
3
{- |
    Module      :  $Header$
    Description :  Compilation of a single module
Björn Peemöller 's avatar
Björn Peemöller committed
4
5
6
7
    Copyright   :  (c) 1999 - 2004 Wolfgang Lux
                       2005        Martin Engelke
                       2007        Sebastian Fischer
                       2011 - 2013 Björn Peemöller
8
9
10
11
12
13
14
15
16
17
    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)
Björn Peemöller 's avatar
Björn Peemöller committed
22
import Data.Maybe    (fromMaybe)
23
24

import Curry.Base.Ident
Björn Peemöller 's avatar
Björn Peemöller committed
25
26
import Curry.Base.Message (runMsg)
import Curry.Base.Position
Björn Peemöller 's avatar
Björn Peemöller committed
27
import Curry.Base.Pretty
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
import Base.Messages
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

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

Björn Peemöller 's avatar
Björn Peemöller committed
72
compileModule :: Options -> FilePath -> CYIO ()
73
compileModule opts fn = do
Björn Peemöller 's avatar
Björn Peemöller committed
74
75
76
77
  (env, mdl) <- loadModule opts fn >>= checkModule opts
  warn opts $ warnCheck opts env mdl
  liftIO $ writeParsed opts fn mdl
  liftIO $ writeOutput opts fn (env, mdl)
78
79
80

writeOutput :: Options -> FilePath -> (CompilerEnv, CS.Module) -> IO ()
writeOutput opts fn (env, modul) = do
81
82
83
  let (env1, qlfd) = qual opts env modul
  doDump opts (DumpQualified, env1, show $ CS.ppModule qlfd)
  writeAbstractCurry opts fn env1 qlfd
84
85
86
87
  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)
88
    let (env2, il, dumps) = transModule opts env1 qlfd
89
90
91
    -- dump intermediate results
    mapM_ (doDump opts) dumps
    -- generate target code
92
93
    let intf = exportInterface env2 qlfd
    let modSum = summarizeModule (tyConsEnv env2) intf qlfd
94
95
96
97
    writeFlat opts fn env2 modSum il
  where
  withFlat = any (`elem` optTargetTypes opts)
              [FlatCurry, FlatXml, ExtendedFlatCurry]
98
99
100
101
102

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

Björn Peemöller 's avatar
Björn Peemöller committed
103
loadModule :: Options -> FilePath -> CYIO (CompilerEnv, CS.Module)
104
loadModule opts fn = do
Björn Peemöller 's avatar
Björn Peemöller committed
105
106
107
108
109
110
111
112
113
114
115
116
  parsed <- parseModule fn
  -- check module header
  mdl    <- checkModuleHeader opts fn parsed
  -- load the imported interfaces into an InterfaceEnv
  iEnv   <- loadInterfaces (optImportPaths opts) mdl
  -- add information of imported modules
  cEnv   <- importModules opts mdl iEnv
  return (cEnv, mdl)

parseModule :: FilePath -> CYIO CS.Module
parseModule fn = do
  mbSrc <- liftIO $ readModule fn
117
  case mbSrc of
Björn Peemöller 's avatar
Björn Peemöller committed
118
    Nothing  -> left [message $ text $ "Missing file: " ++ fn]
119
120
    Just src -> do
      -- parse module
Björn Peemöller 's avatar
Björn Peemöller committed
121
122
123
124
125
126
      case runMsg (CS.parseModule fn src) of
        Left  err         -> left [err]
        Right (parsed, _) -> right parsed

checkModuleHeader :: Monad m => Options -> FilePath -> CS.Module
                  -> CYT m CS.Module
127
checkModuleHeader opts fn = checkModuleId fn
128
                          . importPrelude opts fn
129
                          . CS.patchModuleId fn
130
131

-- |Check whether the 'ModuleIdent' and the 'FilePath' fit together
Björn Peemöller 's avatar
Björn Peemöller committed
132
133
checkModuleId :: Monad m => FilePath -> CS.Module
              -> CYT m CS.Module
134
checkModuleId fn m@(CS.Module mid _ _ _)
135
  | last (midQualifiers mid) == takeBaseName fn
Björn Peemöller 's avatar
Björn Peemöller committed
136
  = right m
137
  | otherwise
Björn Peemöller 's avatar
Björn Peemöller committed
138
  = left [errModuleFileMismatch mid]
139
140
141
142
143
144

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

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

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

167
-- TODO: The order of the checks should be improved!
168
169
170
-- 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.
171
checkModule :: Options -> (CompilerEnv, CS.Module)
Björn Peemöller 's avatar
Björn Peemöller committed
172
            -> CYIO (CompilerEnv, CS.Module)
173
checkModule opts (env, mdl) = do
174
175
176
  doDump opts (DumpParsed       , env , show $ CS.ppModule mdl)
  (env1, kc) <- kindCheck   opts env mdl -- should be only syntax checking ?
  doDump opts (DumpKindChecked  , env1, show $ CS.ppModule kc)
177
  (env2, sc) <- syntaxCheck opts env1 kc
178
179
180
  doDump opts (DumpSyntaxChecked, env2, show $ CS.ppModule sc)
  (env3, pc) <- precCheck   opts env2 sc
  doDump opts (DumpPrecChecked  , env3, show $ CS.ppModule pc)
181
  (env4, tc) <- if withTypeCheck
182
                   then typeCheck opts env3 pc >>= uncurry (exportCheck opts)
183
                   else return (env3, pc)
184
  doDump opts (DumpTypeChecked  , env4, show $ CS.ppModule tc)
185
  return (env4, tc)
186
  where
187
188
  withTypeCheck = any (`elem` optTargetTypes opts)
                      [FlatCurry, ExtendedFlatCurry, FlatXml, AbstractCurry]
189
190
191
192
193

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

194
195
type Dump = (DumpLevel, CompilerEnv, String)

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

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

237
writeFlat :: Options -> FilePath -> CompilerEnv -> ModuleSummary -> IL.Module
238
239
          -> IO ()
writeFlat opts fn env modSum il = do
240
241
242
243
244
245
246
247
  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
248
249
250
251
252

-- |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
253
  warn opts msgs
254
  when extTarget $ EF.writeExtendedFlat useSubDir (extFlatName fn) prog
255
  when fcyTarget $ EF.writeFlatCurry    useSubDir (flatName    fn) prog
256
  where
257
258
259
260
  extTarget    = ExtendedFlatCurry `elem` optTargetTypes opts
  fcyTarget    = FlatCurry         `elem` optTargetTypes opts
  useSubDir    = optUseSubdir opts
  (prog, msgs) = genFlatCurry opts modSum env il
261

262
263
264
265
266
267
268
-- |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"

269
270
271
272
273
274
275
276
277
278
279
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
280
281
282
283
  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
284
    warn opts intMsgs
285
    EF.writeFlatCurry (optUseSubdir opts) targetFile newInterface
286
287
288
289
290
291
292
293

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

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

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