Modules.hs 15 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
                       2016        Jan Tikovsky
9
10
11
12
13
14
15
16
17
18
    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
19
20
  ( compileModule, loadAndCheckModule, loadModule, checkModule
  , parseModule, checkModuleHeader
21
22
  ) where

23
24
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
25
import           Data.Char                (toUpper)
26
import qualified Data.Map          as Map (elems, lookup)
27
28
29
30
31
32
33
34
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)
35
36

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

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

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

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

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

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

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

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

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

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
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
157
  = ok m
158
  | otherwise
159
  = failMessages [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
167
importPrelude :: Options -> CS.Module -> CS.Module
importPrelude opts 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 NoPos 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
checkInterfaces :: Monad m => Options -> InterfaceEnv -> CYT m ()
checkInterfaces opts iEnv = mapM_ checkInterface (Map.elems iEnv)
  where
188
189
190
191
192
193
194
195
196
197
198
  checkInterface intf = do
    let env = importInterfaces intf iEnv
    interfaceCheck opts (env, intf)

importSyntaxCheck :: Monad m => InterfaceEnv -> CS.Module -> CYT m [CS.ImportDecl]
importSyntaxCheck iEnv (CS.Module _ _ _ imps _) = mapM checkImportDecl imps
  where
  checkImportDecl (CS.ImportDecl p m q asM is) = case Map.lookup m iEnv of
    Just intf -> CS.ImportDecl p m q asM `liftM` importCheck intf is
    Nothing   -> internalError $ "Modules.importModules: no interface for "
                                    ++ show m
199

200
201
202
203
-- ---------------------------------------------------------------------------
-- Checking a module
-- ---------------------------------------------------------------------------

204
-- TODO: The order of the checks should be improved!
205
206
207
checkModule :: Options -> CompEnv CS.Module -> CYIO (CompEnv CS.Module)
checkModule opts mdl = do
  _  <- dumpCS DumpParsed mdl
208
   -- Should be separated into kind checking and type syntax checking (see MCC)
209
210
211
212
  kc <- kindCheck   opts mdl >>= dumpCS DumpKindChecked
  sc <- syntaxCheck opts kc  >>= dumpCS DumpSyntaxChecked
  pc <- precCheck   opts sc  >>= dumpCS DumpPrecChecked
  tc <- typeCheck   opts pc  >>= dumpCS DumpTypeChecked
213
214
  ec <- exportCheck opts tc  >>= dumpCS DumpExportChecked
  return ec
215
  where dumpCS = dumpWith opts CS.showModule CS.ppModule
216
217
218
219
220

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

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

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

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

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

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

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

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

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

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

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

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

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

344
345
type Dump = (DumpLevel, CompilerEnv, String)

346
dumpWith :: (MonadIO m, Show a)
347
348
349
350
351
         => 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)
352
353
354
  doDump (optDebugOpts opts) (lvl, env, str)
  return res

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

376
errModuleFileMismatch :: ModuleIdent -> Message
377
378
379
errModuleFileMismatch mid = posMessage mid $ hsep $ map text
  [ "Module", moduleName mid, "must be in a file"
  , moduleName mid ++ ".(l)curry" ]