Modules.hs 14.9 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
  -- TODO: This is a workaround to avoid the expansion of the export
203
204
205
206
207
  -- 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.
208
  if null (optTargetTypes opts)
209
210
211
    then return tc
    else exportCheck opts tc >>= dumpCS DumpExportChecked
  where dumpCS = dumpWith opts CS.ppModule
212
213
214
215
216

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

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

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

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

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

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

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

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

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

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

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

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

331
332
writeAbstractCurry :: Options -> FilePath -> CompEnv CS.Module -> IO ()
writeAbstractCurry opts fname (env, modul) = do
333
334
335
336
  when acyTarget  $ AC.writeCurry (useSubDir $ acyName fname)
                  $ genTypedAbstractCurry env modul
  when uacyTarget $ AC.writeCurry (useSubDir $ uacyName fname)
                  $ genUntypedAbstractCurry env modul
337
  where
338
  acyTarget  = AbstractCurry        `elem` optTargetTypes opts
339
  uacyTarget = UntypedAbstractCurry `elem` optTargetTypes opts
340
  useSubDir  = addCurrySubdirModule (optUseSubdir opts) (moduleIdent env)
341

342
343
type Dump = (DumpLevel, CompilerEnv, String)

344
345
346
347
348
349
350
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

351
-- |Translate FlatCurry into the intermediate language 'IL'
352
-- |The 'dump' function writes the selected information to standard output.
353
doDump :: MonadIO m => DebugOpts -> Dump -> m ()
Björn Peemöller 's avatar
Björn Peemöller committed
354
355
356
357
358
359
360
361
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
362
  where
Björn Peemöller 's avatar
Björn Peemöller committed
363
  heading h s = '\n' : h ++ '\n' : replicate (length h) s
364
365
366
367
  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
368
369
370
  capitalize = unwords . map firstUpper . words
  firstUpper ""     = ""
  firstUpper (c:cs) = toUpper c : cs
371

372
errModuleFileMismatch :: ModuleIdent -> Message
373
374
375
errModuleFileMismatch mid = posMessage mid $ hsep $ map text
  [ "Module", moduleName mid, "must be in a file"
  , moduleName mid ++ ".(l)curry" ]