Modules.hs 14.7 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 - 2015 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
import qualified Control.Exception as C   (catch, IOException)
import           Control.Monad            (liftM, unless, when)
Björn Peemöller 's avatar
Björn Peemöller committed
24
import           Data.Char                (toUpper)
25
26
27
28
29
30
31
32
33
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)
34
35

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

Björn Peemöller 's avatar
Björn Peemöller committed
44
import Base.Messages
45
import Env.Interface
46
47
48

-- source representations
import qualified Curry.AbstractCurry as AC
49
50
51
import qualified Curry.ExtendedFlat  as EF
import qualified Curry.Syntax        as CS
import qualified IL                  as IL
52
53
54
55
56
57
58

import Checks
import CompilerEnv
import CompilerOpts
import Exports
import Generators
import Imports
59
import Interfaces (loadInterfaces)
60
61
62
63
64
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
65
66
-- line options, it will emit either FlatCurry code or AbstractCurry code
-- (typed, untyped or with type signatures) for the module.
67
68
-- Usually, the first step is to check the module.
-- Then the code is translated into the intermediate
69
-- language. If necessary, this phase will also update the module's
70
71
-- interface file. The resulting code then is written out
-- to the corresponding file.
72
73
74
-- 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.
75
--
76
77
78
-- 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
79
compileModule :: Options -> FilePath -> CYIO ()
80
compileModule opts fn = do
81
82
83
  (env, mdl) <- loadAndCheckModule opts fn
  liftIO $ writeOutput opts fn (env, mdl)

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

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

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

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

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

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

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

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

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

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

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

189
190
191
192
-- ---------------------------------------------------------------------------
-- Checking a module
-- ---------------------------------------------------------------------------

193
-- TODO: The order of the checks should be improved!
194
195
196
checkModule :: Options -> CompEnv CS.Module -> CYIO (CompEnv CS.Module)
checkModule opts mdl = do
  _  <- dumpCS DumpParsed mdl
197
   -- Should be separated into kind checking and type syntax checking (see MCC)
198
199
200
201
  kc <- kindCheck   opts mdl >>= dumpCS DumpKindChecked
  sc <- syntaxCheck opts kc  >>= dumpCS DumpSyntaxChecked
  pc <- precCheck   opts sc  >>= dumpCS DumpPrecChecked
  tc <- typeCheck   opts pc  >>= dumpCS DumpTypeChecked
202
203
  ec <- exportCheck opts tc  >>= dumpCS DumpExportChecked
  return ec
204
  where dumpCS = dumpWith opts CS.showModule CS.ppModule
205
206
207
208
209

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

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

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

229
writeOutput :: Options -> FilePath -> CompEnv CS.Module -> IO ()
230
writeOutput opts fn mdl@(_, modul) = do
231
  writeParsed opts fn modul
232
  mdl' <- expandExports opts mdl
233
  qmdl <- dumpWith opts CS.showModule CS.ppModule DumpQualified $ qual mdl'
234
  writeAbstractCurry opts fn qmdl
235
236
237
  -- generate interface file
  let intf = uncurry exportInterface qmdl
  writeInterface opts fn intf
238
  when withFlat $ do
Björn Peemöller 's avatar
Björn Peemöller committed
239
    (env2, il) <- transModule opts qmdl
240
    -- generate target code
Björn Peemöller 's avatar
Björn Peemöller committed
241
    let modSum = summarizeModule (tyConsEnv env2) intf (snd qmdl)
242
243
    writeFlat opts fn env2 modSum il
  where
244
  withFlat = any (`elem` optTargetTypes opts) [FlatCurry, ExtendedFlatCurry]
245

246
247
248
249
-- 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'
250
-- (depending on the compiler flag "force") and other modules importing this
251
252
253
254
-- module won't be dependent on it any longer.

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

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

272
  interfaceFile   = interfName fn
273
274
  outputInterface = writeModule
                    (addCurrySubdirModule (optUseSubdir opts) m interfaceFile)
275
276
                    (show $ CS.ppInterface intf)

277
278
279
280
matchInterface :: FilePath -> CS.Interface -> IO Bool
matchInterface ifn i = do
  hdl <- openFile ifn ReadMode
  src <- hGetContents hdl
281
  case runCYM (CS.parseInterface ifn src) of
282
283
    Left  _  -> hClose hdl >> return False
    Right i' -> return (i `intfEquiv` fixInterface i')
284

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

-- |Export an 'IL.Module' into a FlatCurry file
writeFlatCurry :: Options -> FilePath -> CompilerEnv -> ModuleSummary
               -> IL.Module -> IO ()
writeFlatCurry opts fn env modSum il = do
299
  (_, fc) <- dumpWith opts show EF.ppProg DumpFlatCurry (env, prog)
300
301
  when extTarget $ EF.writeExtendedFlat (useSubDir $ extFlatName fn) fc
  when fcyTarget $ EF.writeFlatCurry    (useSubDir $ flatName    fn) fc
302
  where
303
304
  extTarget = ExtendedFlatCurry `elem` optTargetTypes opts
  fcyTarget = FlatCurry         `elem` optTargetTypes opts
305
  useSubDir = addCurrySubdirModule (optUseSubdir opts) (moduleIdent env)
306
  prog      = genFlatCurry modSum env il
307

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

325
326
writeAbstractCurry :: Options -> FilePath -> CompEnv CS.Module -> IO ()
writeAbstractCurry opts fname (env, modul) = do
327
328
329
330
  when acyTarget  $ AC.writeCurry (useSubDir $ acyName fname)
                  $ genTypedAbstractCurry env modul
  when uacyTarget $ AC.writeCurry (useSubDir $ uacyName fname)
                  $ genUntypedAbstractCurry env modul
331
  where
332
  acyTarget  = AbstractCurry        `elem` optTargetTypes opts
333
  uacyTarget = UntypedAbstractCurry `elem` optTargetTypes opts
334
  useSubDir  = addCurrySubdirModule (optUseSubdir opts) (moduleIdent env)
335

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

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

347
-- |Translate FlatCurry into the intermediate language 'IL'
348
-- |The 'dump' function writes the selected information to standard output.
349
doDump :: MonadIO m => DebugOpts -> Dump -> m ()
Björn Peemöller 's avatar
Björn Peemöller committed
350
351
352
353
354
355
356
357
doDump opts (level, env, dump)
  = when (level `elem` dbDumpLevels opts) $ liftIO $ do
      putStrLn (heading (capitalize $ lookupHeader dumpLevel) '=')
      when (dbDumpEnv opts) $ do
        putStrLn (heading "Environment" '-')
        putStrLn (showCompilerEnv env)
      putStrLn (heading "Source Code" '-')
      putStrLn dump
358
  where
Björn Peemöller 's avatar
Björn Peemöller committed
359
  heading h s = '\n' : h ++ '\n' : replicate (length h) s
360
361
362
363
  lookupHeader []            = "Unknown dump level " ++ show level
  lookupHeader ((l,_,h):lhs)
    | level == l = h
    | otherwise  = lookupHeader lhs
Björn Peemöller 's avatar
Björn Peemöller committed
364
365
366
  capitalize = unwords . map firstUpper . words
  firstUpper ""     = ""
  firstUpper (c:cs) = toUpper c : cs
367

368
errModuleFileMismatch :: ModuleIdent -> Message
369
370
371
errModuleFileMismatch mid = posMessage mid $ hsep $ map text
  [ "Module", moduleName mid, "must be in a file"
  , moduleName mid ++ ".(l)curry" ]