Modules.hs 15.5 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
    Copyright   :  (c) 1999 - 2004 Wolfgang Lux
                       2005        Martin Engelke
                       2007        Sebastian Fischer
7
                       2011 - 2014 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, loadAndCheckModule, checkModuleHeader
19
20
  ) where

21
22
23
24
25
26
27
28
29
30
31
import qualified Control.Exception as C   (catch, IOException)
import           Control.Monad            (liftM, unless, when)
import qualified Data.Map          as Map (elems)
import           Data.Maybe               (fromMaybe)
import           System.Directory         (getTemporaryDirectory, removeFile)
import           System.Exit              (ExitCode (..))
import           System.FilePath          (normalise)
import           System.IO
   (IOMode (ReadMode), Handle, hClose, hGetContents, hPutStr, openFile
  , openTempFile)
import           System.Process           (system)
32
33

import Curry.Base.Ident
Björn Peemöller 's avatar
Björn Peemöller committed
34
35
import Curry.Base.Message (runMsg)
import Curry.Base.Position
Björn Peemöller 's avatar
Björn Peemöller committed
36
import Curry.Base.Pretty
37
38
39
40
import Curry.ExtendedFlat.InterfaceEquality (eqInterface)
import Curry.Files.Filenames
import Curry.Files.PathUtils

Björn Peemöller 's avatar
Björn Peemöller committed
41
import Base.Messages
42
import Env.Interface
43
44
45
46
47
48
49
50
51
52
53
54
55

-- 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
56
import InterfaceEquivalence
57
58
59
60
61
62
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
63
-- line options, it will emit either FlatCurry code (standard or in XML
64
-- representation) or AbstractCurry code (typed, untyped or with type
65
66
67
-- signatures) for the module
-- Usually, the first step is to check the module.
-- Then the code is translated into the intermediate
68
-- language. If necessary, this phase will also update the module's
69
70
-- interface file. The resulting code then is written out (in
-- FlatCurry or XML format) to the corresponding file.
71
72
73
-- 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.
74
--
75
76
77
-- The compiler automatically loads the prelude when compiling any
-- module, except for the prelude itself, by adding an appropriate import
-- declaration to the module.
Björn Peemöller 's avatar
Björn Peemöller committed
78
compileModule :: Options -> FilePath -> CYIO ()
79
compileModule opts fn = do
80
81
82
83
84
  (env, mdl) <- loadAndCheckModule opts fn
  liftIO $ writeOutput opts fn (env, mdl)

loadAndCheckModule :: Options -> FilePath -> CYIO (CompilerEnv, CS.Module)
loadAndCheckModule opts fn = do
Björn Peemöller 's avatar
Björn Peemöller committed
85
  (env, mdl) <- loadModule opts fn >>= checkModule opts
86
  warn (optWarnOpts opts) $ warnCheck opts env mdl
87
  return (env, mdl)
88
89
90
91
92

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

Björn Peemöller 's avatar
Björn Peemöller committed
93
loadModule :: Options -> FilePath -> CYIO (CompilerEnv, CS.Module)
94
loadModule opts fn = do
95
  parsed <- parseModule opts fn
Björn Peemöller 's avatar
Björn Peemöller committed
96
97
98
99
  -- check module header
  mdl    <- checkModuleHeader opts fn parsed
  -- load the imported interfaces into an InterfaceEnv
  iEnv   <- loadInterfaces (optImportPaths opts) mdl
100
  checkInterfaces opts iEnv
Björn Peemöller 's avatar
Björn Peemöller committed
101
102
103
104
  -- add information of imported modules
  cEnv   <- importModules opts mdl iEnv
  return (cEnv, mdl)

105
106
parseModule :: Options -> FilePath -> CYIO CS.Module
parseModule opts fn = do
Björn Peemöller 's avatar
Björn Peemöller committed
107
  mbSrc <- liftIO $ readModule fn
108
  case mbSrc of
Björn Peemöller 's avatar
Björn Peemöller committed
109
    Nothing  -> left [message $ text $ "Missing file: " ++ fn]
110
    Just src -> do
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
      case runMsg (CS.unlit fn src) of
        Left err      -> left [err]
        Right (ul, _) -> do
        prepd <- preprocess (optPrepOpts opts) fn ul
        -- parse module
        case runMsg (CS.parseModule fn prepd) of
          Left  err         -> left [err]
          Right (parsed, _) -> right parsed

preprocess :: PrepOpts -> FilePath -> String -> CYIO String
preprocess opts fn src
  | not (ppPreprocess opts) = return src
  | otherwise               = do
    res <- liftIO $ withTempFile $ \ inFn inHdl -> do
      hPutStr inHdl src
      hClose inHdl
      withTempFile $ \ outFn outHdl -> do
        hClose outHdl
        ec <- system $ unwords $
          [ppCmd opts, normalise fn, inFn, outFn] ++ ppOpts opts
        case ec of
          ExitFailure x -> return $ Left [message $ text $
              "Preprocessor exited with exit code " ++ show x]
          ExitSuccess   -> Right `liftM` readFile outFn
    either left right res

withTempFile :: (FilePath -> Handle -> IO a) -> IO a
withTempFile act = do
  tmp       <- getTemporaryDirectory
  (fn, hdl) <- openTempFile tmp "cymake.curry"
  res       <- act fn hdl
  hClose hdl
  removeFile fn
  return res
Björn Peemöller 's avatar
Björn Peemöller committed
145
146
147

checkModuleHeader :: Monad m => Options -> FilePath -> CS.Module
                  -> CYT m CS.Module
148
checkModuleHeader opts fn = checkModuleId fn
149
                          . importPrelude opts fn
150
                          . CS.patchModuleId fn
151
152

-- |Check whether the 'ModuleIdent' and the 'FilePath' fit together
Björn Peemöller 's avatar
Björn Peemöller committed
153
154
checkModuleId :: Monad m => FilePath -> CS.Module
              -> CYT m CS.Module
155
checkModuleId fn m@(CS.Module _ mid _ _ _)
156
  | last (midQualifiers mid) == takeBaseName fn
Björn Peemöller 's avatar
Björn Peemöller committed
157
  = right m
158
  | otherwise
Björn Peemöller 's avatar
Björn Peemöller committed
159
  = left [errModuleFileMismatch mid]
160
161
162
163
164
165

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

166
importPrelude :: Options -> FilePath -> CS.Module -> CS.Module
167
importPrelude opts fn m@(CS.Module ps mid es is ds)
168
169
170
171
172
173
174
    -- the Prelude itself
  | mid == preludeMIdent          = m
    -- disabled by compiler option
  | noImpPrelude                  = m
    -- already imported
  | preludeMIdent `elem` imported = m
    -- let's add it!
175
  | otherwise                     = CS.Module ps mid es (preludeImp : is) ds
176
  where
177
  noImpPrelude = NoImplicitPrelude `elem` optExtensions opts
178
                 || m `CS.hasLanguageExtension` NoImplicitPrelude
179
  preludeImp   = CS.ImportDecl (first fn) preludeMIdent
180
181
182
183
                  False   -- qualified?
                  Nothing -- no alias
                  Nothing -- no selection of types, functions, etc.
  imported     = [imp | (CS.ImportDecl _ imp _ _ _) <- is]
184

185
186
187
188
189
190
checkInterfaces :: Monad m => Options -> InterfaceEnv -> CYT m ()
checkInterfaces opts iEnv = mapM_ checkInterface (Map.elems iEnv)
  where
  checkInterface intf = do
    _ <- interfaceCheck opts (importInterfaces opts intf iEnv) intf
    return ()
191

192
193
194
195
-- ---------------------------------------------------------------------------
-- Checking a module
-- ---------------------------------------------------------------------------

196
-- TODO: The order of the checks should be improved!
197
198
199
-- 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.
200
checkModule :: Options -> (CompilerEnv, CS.Module)
Björn Peemöller 's avatar
Björn Peemöller committed
201
            -> CYIO (CompilerEnv, CS.Module)
202
checkModule opts (env, mdl) = do
203
  doDump debugOpts (DumpParsed       , env , show $ CS.ppModule mdl)
204
  (env1, kc) <- kindCheck   opts env mdl -- should be only syntax checking ?
205
  doDump debugOpts (DumpKindChecked  , env1, show $ CS.ppModule kc)
206
  (env2, sc) <- syntaxCheck opts env1 kc
207
  doDump debugOpts (DumpSyntaxChecked, env2, show $ CS.ppModule sc)
208
  (env3, pc) <- precCheck   opts env2 sc
209
  doDump debugOpts (DumpPrecChecked  , env3, show $ CS.ppModule pc)
210
  (env4, tc) <- if withTypeCheck
211
                   then typeCheck opts env3 pc >>= uncurry (exportCheck opts)
212
                   else return (env3, pc)
213
  doDump debugOpts (DumpTypeChecked  , env4, show $ CS.ppModule tc)
214
  return (env4, tc)
215
  where
216
  debugOpts = optDebugOpts opts
217
218
  withTypeCheck = any (`elem` optTargetTypes opts)
                      [FlatCurry, ExtendedFlatCurry, FlatXml, AbstractCurry]
219
220
221
222
223

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

224
225
type Dump = (DumpLevel, CompilerEnv, String)

226
227
-- |Translate FlatCurry into the intermediate language 'IL'
transModule :: Options -> CompilerEnv -> CS.Module
228
            -> (CompilerEnv, IL.Module, [Dump])
229
230
transModule opts env mdl = (env5, ilCaseComp, dumps)
  where
231
  flat' = FlatCurry `elem` optTargetTypes opts
232
  (desugared , env1) = desugar        mdl        env
233
234
  (simplified, env2) = simplify flat' desugared  env1
  (lifted    , env3) = lift           simplified env2
Björn Peemöller 's avatar
Björn Peemöller committed
235
  (il        , env4) = ilTrans  flat' lifted     env3
236
  (ilCaseComp, env5) = completeCase   il         env4
237
238
239
240
241
  dumps = [ (DumpDesugared    , env1, presentCS desugared )
          , (DumpSimplified   , env2, presentCS simplified)
          , (DumpLifted       , env3, presentCS lifted    )
          , (DumpTranslated   , env4, presentIL il        )
          , (DumpCaseCompleted, env5, presentIL ilCaseComp)
242
          ]
243
244
245
  presentCS = if dumpRaw then show else show . CS.ppModule
  presentIL = if dumpRaw then show else show . IL.ppModule
  dumpRaw   = dbDumpRaw (optDebugOpts opts)
246
247
248
249
250

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

251
252
253
254
writeOutput :: Options -> FilePath -> (CompilerEnv, CS.Module) -> IO ()
writeOutput opts fn (env, modul) = do
  writeParsed opts fn modul
  let (env1, qlfd) = qual opts env modul
255
  doDump (optDebugOpts opts) (DumpQualified, env1, show $ CS.ppModule qlfd)
256
257
258
259
260
261
262
  writeAbstractCurry opts fn env1 qlfd
  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 env1 qlfd
    -- dump intermediate results
263
    mapM_ (doDump (optDebugOpts opts)) dumps
264
265
266
267
268
269
270
271
272
273
    -- generate interface file
    let intf = exportInterface env2 qlfd
    writeInterface opts fn intf
    -- generate target code
    let modSum = summarizeModule (tyConsEnv env2) intf qlfd
    writeFlat opts fn env2 modSum il
  where
  withFlat = any (`elem` optTargetTypes opts)
              [FlatCurry, FlatXml, ExtendedFlatCurry]

274
275
276
277
-- 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'
278
-- (depending on the compiler flag "force") and other modules importing this
279
280
281
282
283
-- 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 $
284
  writeModule useSubDir (sourceRepName fn) source
285
  where
286
287
288
  srcTarget  = Parsed `elem` optTargetTypes opts
  useSubDir  = optUseSubdir opts
  source     = CS.showModule modul
289

290
291
writeInterface :: Options -> FilePath -> CS.Interface -> IO ()
writeInterface opts fn intf
292
293
294
295
  | optForce opts = outputInterface
  | otherwise     = do
      equal <- C.catch (matchInterface interfaceFile intf) ignoreIOException
      unless equal outputInterface
296
  where
297
298
299
  ignoreIOException :: C.IOException -> IO Bool
  ignoreIOException _ = return False

300
301
302
303
  interfaceFile   = interfName fn
  outputInterface = writeModule (optUseSubdir opts) interfaceFile
                    (show $ CS.ppInterface intf)

304
305
306
307
308
309
310
311
matchInterface :: FilePath -> CS.Interface -> IO Bool
matchInterface ifn i = do
  hdl <- openFile ifn ReadMode
  src <- hGetContents hdl
  case runMsg (CS.parseInterface ifn src) of
    Left _        -> hClose hdl >> return False
    Right (i', _) -> return (i `intfEquiv` fixInterface i')

312
writeFlat :: Options -> FilePath -> CompilerEnv -> ModuleSummary -> IL.Module
313
314
          -> IO ()
writeFlat opts fn env modSum il = do
315
316
  when (extTarget || fcyTarget) $ do
    writeFlatCurry opts fn env modSum il
317
    writeFlatIntf  opts fn env modSum il
318
  when (xmlTarget) $ writeFlatXml opts fn modSum il
319
320
321
322
  where
  extTarget    = ExtendedFlatCurry `elem` optTargetTypes opts
  fcyTarget    = FlatCurry         `elem` optTargetTypes opts
  xmlTarget    = FlatXml           `elem` optTargetTypes opts
323
324
325
326
327

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

337
-- |Export an 'IL.Module' into an XML file
338
339
writeFlatXml :: Options -> FilePath -> ModuleSummary -> IL.Module -> IO ()
writeFlatXml opts fn modSum il = writeModule useSubDir (xmlName fn) curryXml
340
341
342
343
  where
  useSubDir = optUseSubdir opts
  curryXml  = shows (IL.xmlModule (interface modSum) (infixDecls modSum) il) "\n"

344
345
346
writeFlatIntf :: Options -> FilePath -> CompilerEnv -> ModuleSummary
              -> IL.Module -> IO ()
writeFlatIntf opts fn env modSum il
347
348
349
350
351
352
353
354
  | 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
355
356
357
358
  targetFile = flatIntName fn
  emptyIntf = EF.Prog "" [] [] [] []
  (newInterface, intMsgs) = genFlatInterface opts modSum env il
  outputInterface = do
359
    warn (optWarnOpts opts) intMsgs
360
    EF.writeFlatCurry (optUseSubdir opts) targetFile newInterface
361
362
363
364
365
366
367
368

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
369
370
371
  acyTarget  = AbstractCurry        `elem` optTargetTypes opts
  uacyTarget = UntypedAbstractCurry `elem` optTargetTypes opts
  useSubDir  = optUseSubdir opts
372

373
-- |The 'dump' function writes the selected information to standard output.
374
375
376
doDump :: MonadIO m => DebugOpts -> Dump -> m ()
doDump opts (level, env, dump) = when (level `elem` dbDumpLevels opts) $ do
  when (dbDumpEnv opts) $ liftIO $ putStrLn $ showCompilerEnv env
377
  liftIO $ putStrLn $ unlines [header, replicate (length header) '=', dump]
378
379
380
381
382
383
  where
  header = lookupHeader dumpLevel
  lookupHeader []            = "Unknown dump level " ++ show level
  lookupHeader ((l,_,h):lhs)
    | level == l = h
    | otherwise  = lookupHeader lhs
384

385
errModuleFileMismatch :: ModuleIdent -> Message
386
387
388
errModuleFileMismatch mid = posMessage mid $ hsep $ map text
  [ "Module", moduleName mid, "must be in a file"
  , moduleName mid ++ ".(l)curry" ]