Modules.hs 14.4 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
Björn Peemöller 's avatar
Björn Peemöller committed
18
19
  ( compileModule, loadAndCheckModule, loadModule, checkModule
  , parseModule, checkModuleHeader
20
21
  ) where

22
23
24
25
26
27
28
29
30
31
32
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)
33
34

import Curry.Base.Ident
35
import Curry.Base.Monad
Björn Peemöller 's avatar
Björn Peemöller committed
36
import Curry.Base.Position
Björn Peemöller 's avatar
Björn Peemöller committed
37
import Curry.Base.Pretty
38
import Curry.ExtendedFlat.InterfaceEquivalence (eqInterface)
39
40
import Curry.Files.Filenames
import Curry.Files.PathUtils
41
import Curry.Syntax.InterfaceEquivalence
42

Björn Peemöller 's avatar
Björn Peemöller committed
43
import Base.Messages
44
import Env.Interface
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
64
65
-- line options, it will emit either FlatCurry code or AbstractCurry code
-- (typed, untyped or with type signatures) for the module.
66
67
-- 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
-- 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
  (env, mdl) <- loadAndCheckModule opts fn
  liftIO $ writeOutput opts fn (env, mdl)

83
loadAndCheckModule :: Options -> FilePath -> CYIO (CompEnv CS.Module)
84
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
-- ---------------------------------------------------------------------------

93
loadModule :: Options -> FilePath -> CYIO (CompEnv 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
  -- check module header
  mdl    <- checkModuleHeader opts fn parsed
  -- load the imported interfaces into an InterfaceEnv
99
100
101
  let paths = map (addCurrySubdir (optUseSubdir opts))
                  ("." : optImportPaths opts)
  iEnv   <- loadInterfaces paths mdl
102
  checkInterfaces opts iEnv
Björn Peemöller 's avatar
Björn Peemöller committed
103
  -- add information of imported modules
104
  cEnv   <- importModules mdl iEnv
Björn Peemöller 's avatar
Björn Peemöller committed
105
106
  return (cEnv, mdl)

107
108
parseModule :: Options -> FilePath -> CYIO CS.Module
parseModule opts fn = do
Björn Peemöller 's avatar
Björn Peemöller committed
109
  mbSrc <- liftIO $ readModule fn
110
  case mbSrc of
111
    Nothing  -> failMessages [message $ text $ "Missing file: " ++ fn]
112
    Just src -> do
113
114
115
      ul    <- liftCYM $ CS.unlit fn src
      prepd <- preprocess (optPrepOpts opts) fn ul
      liftCYM $ CS.parseModule fn prepd
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131

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
132
    either failMessages ok res
133
134
135
136
137
138
139
140
141

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
142
143
144

checkModuleHeader :: Monad m => Options -> FilePath -> CS.Module
                  -> CYT m CS.Module
145
checkModuleHeader opts fn = checkModuleId fn
146
                          . importPrelude opts fn
147
                          . CS.patchModuleId fn
148
149

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

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

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

182
183
184
checkInterfaces :: Monad m => Options -> InterfaceEnv -> CYT m ()
checkInterfaces opts iEnv = mapM_ checkInterface (Map.elems iEnv)
  where
185
  checkInterface intf
186
    = interfaceCheck opts (importInterfaces intf iEnv, intf) >> return ()
187

188
189
190
191
-- ---------------------------------------------------------------------------
-- Checking a module
-- ---------------------------------------------------------------------------

192
-- TODO: The order of the checks should be improved!
193
194
195
checkModule :: Options -> CompEnv CS.Module -> CYIO (CompEnv CS.Module)
checkModule opts mdl = do
  _  <- dumpCS DumpParsed mdl
196
   -- Should be separated into kind checking and type syntax checking (see MCC)
197
198
199
200
  kc <- kindCheck   opts mdl >>= dumpCS DumpKindChecked
  sc <- syntaxCheck opts kc  >>= dumpCS DumpSyntaxChecked
  pc <- precCheck   opts sc  >>= dumpCS DumpPrecChecked
  tc <- typeCheck   opts pc  >>= dumpCS DumpTypeChecked
201
  -- TODO: This is a workaround to avoid the expansion of the export
202
203
204
205
206
  -- specification for generating the HTML listing. If a module does not
  -- contain an export specification, the check generates one which leads
  -- to a mismatch between the identifiers from the lexer and those in the
  -- resulting module.
  -- Therefore, it would be better if checking and expansion are separated.
207
  if null (optTargetTypes opts)
208
209
210
    then return tc
    else exportCheck opts tc >>= dumpCS DumpExportChecked
  where dumpCS = dumpWith opts CS.ppModule
211
212
213
214
215

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

216
217
transModule :: Options -> CompEnv CS.Module -> IO (CompEnv IL.Module)
transModule opts mdl = do
218
  desugared   <- dumpCS DumpDesugared     $ desugar False mdl
219
220
  simplified  <- dumpCS DumpSimplified    $ simplify      desugared
  lifted      <- dumpCS DumpLifted        $ lift          simplified
221
222
223
224
  desugared2  <- dumpCS DumpDesugared     $ desugar True  lifted
  simplified2 <- dumpCS DumpSimplified    $ simplify      desugared2
  lifted2     <- dumpCS DumpLifted        $ lift          simplified2
  il          <- dumpIL DumpTranslated    $ ilTrans       lifted2
225
  ilCaseComp  <- dumpIL DumpCaseCompleted $ completeCase  il
226
  return ilCaseComp
227
  where
228
229
  dumpCS = dumpWith opts CS.ppModule
  dumpIL = dumpWith opts IL.ppModule
230
231
232
233
234

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

235
writeOutput :: Options -> FilePath -> CompEnv CS.Module -> IO ()
236
writeOutput opts fn mdl@(_, modul) = do
237
  writeParsed opts fn modul
238
  (env1, qlfd) <- dumpWith opts CS.ppModule DumpQualified $ qual mdl
239
240
  writeAbstractCurry opts fn env1 qlfd
  when withFlat $ do
241
    (env2, il) <- transModule opts (env1, qlfd)
242
243
244
245
246
247
248
    -- 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
249
  withFlat = any (`elem` optTargetTypes opts) [FlatCurry, ExtendedFlatCurry]
250

251
252
253
254
-- 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'
255
-- (depending on the compiler flag "force") and other modules importing this
256
257
258
259
-- module won't be dependent on it any longer.

-- |Output the parsed 'Module' on request
writeParsed :: Options -> FilePath -> CS.Module -> IO ()
260
261
writeParsed opts fn modul@(CS.Module _ m _ _ _) = when srcTarget $
  writeModule (useSubDir $ sourceRepName fn) source
262
  where
263
  srcTarget  = Parsed `elem` optTargetTypes opts
264
  useSubDir  = addCurrySubdirModule (optUseSubdir opts) m
265
  source     = CS.showModule modul
266

267
writeInterface :: Options -> FilePath -> CS.Interface -> IO ()
268
writeInterface opts fn intf@(CS.Interface m _ _)
269
270
271
272
  | optForce opts = outputInterface
  | otherwise     = do
      equal <- C.catch (matchInterface interfaceFile intf) ignoreIOException
      unless equal outputInterface
273
  where
274
275
276
  ignoreIOException :: C.IOException -> IO Bool
  ignoreIOException _ = return False

277
  interfaceFile   = interfName fn
278
279
  outputInterface = writeModule
                    (addCurrySubdirModule (optUseSubdir opts) m interfaceFile)
280
281
                    (show $ CS.ppInterface intf)

282
283
284
285
matchInterface :: FilePath -> CS.Interface -> IO Bool
matchInterface ifn i = do
  hdl <- openFile ifn ReadMode
  src <- hGetContents hdl
286
  case runCYM (CS.parseInterface ifn src) of
287
288
    Left  _  -> hClose hdl >> return False
    Right i' -> return (i `intfEquiv` fixInterface i')
289

290
writeFlat :: Options -> FilePath -> CompilerEnv -> ModuleSummary -> IL.Module
291
292
          -> IO ()
writeFlat opts fn env modSum il = do
293
294
  when (extTarget || fcyTarget) $ do
    writeFlatCurry opts fn env modSum il
295
    writeFlatIntf  opts fn env modSum il
296
  where
297
298
  extTarget = ExtendedFlatCurry `elem` optTargetTypes opts
  fcyTarget = FlatCurry         `elem` optTargetTypes opts
299
300
301
302
303

-- |Export an 'IL.Module' into a FlatCurry file
writeFlatCurry :: Options -> FilePath -> CompilerEnv -> ModuleSummary
               -> IL.Module -> IO ()
writeFlatCurry opts fn env modSum il = do
304
305
  when extTarget $ EF.writeExtendedFlat (useSubDir $ extFlatName fn) prog
  when fcyTarget $ EF.writeFlatCurry    (useSubDir $ flatName    fn) prog
306
  where
307
308
  extTarget = ExtendedFlatCurry `elem` optTargetTypes opts
  fcyTarget = FlatCurry         `elem` optTargetTypes opts
309
  useSubDir = addCurrySubdirModule (optUseSubdir opts) (moduleIdent env)
310
  prog      = genFlatCurry modSum env il
311

312
313
314
writeFlatIntf :: Options -> FilePath -> CompilerEnv -> ModuleSummary
              -> IL.Module -> IO ()
writeFlatIntf opts fn env modSum il
315
316
317
318
319
320
  | 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
321
      unless (oldInterface `eqInterface` intf) $ outputInterface
322
  where
323
324
325
326
327
  targetFile      = flatIntName fn
  emptyIntf       = EF.Prog "" [] [] [] []
  intf            = genFlatInterface modSum env il
  useSubDir       = addCurrySubdirModule (optUseSubdir opts) (moduleIdent env)
  outputInterface = EF.writeFlatCurry (useSubDir targetFile) intf
328
329

writeAbstractCurry :: Options -> FilePath -> CompilerEnv -> CS.Module -> IO ()
330
331
332
writeAbstractCurry opts fn env mdl = do
  when acyTarget $ AC.writeCurry (useSubDir $ acyName fn)
                 $ genAbstractCurry env mdl
333
  where
334
  acyTarget  = AbstractCurry        `elem` optTargetTypes opts
335
  useSubDir  = addCurrySubdirModule (optUseSubdir opts) (moduleIdent env)
336

337
338
type Dump = (DumpLevel, CompilerEnv, String)

339
340
341
342
343
344
345
dumpWith :: (MonadIO m, Show a)
         => Options -> (a -> Doc) -> DumpLevel -> CompEnv a -> m (CompEnv a)
dumpWith opts view lvl res@(env, mdl) = do
  let str = if dbDumpRaw (optDebugOpts opts) then show mdl else show (view mdl)
  doDump (optDebugOpts opts) (lvl, env, str)
  return res

346
-- |Translate FlatCurry into the intermediate language 'IL'
347
-- |The 'dump' function writes the selected information to standard output.
348
349
350
doDump :: MonadIO m => DebugOpts -> Dump -> m ()
doDump opts (level, env, dump) = when (level `elem` dbDumpLevels opts) $ do
  when (dbDumpEnv opts) $ liftIO $ putStrLn $ showCompilerEnv env
351
  liftIO $ putStrLn $ unlines [header, replicate (length header) '=', dump]
352
353
354
355
356
357
  where
  header = lookupHeader dumpLevel
  lookupHeader []            = "Unknown dump level " ++ show level
  lookupHeader ((l,_,h):lhs)
    | level == l = h
    | otherwise  = lookupHeader lhs
358

359
errModuleFileMismatch :: ModuleIdent -> Message
360
361
362
errModuleFileMismatch mid = posMessage mid $ hsep $ map text
  [ "Module", moduleName mid, "must be in a file"
  , moduleName mid ++ ".(l)curry" ]