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

21
import qualified Control.Exception as C (catch, IOException)
22
import           Control.Monad   (unless, when)
23
import qualified Data.Map as Map (elems)
24
import           Data.Maybe      (fromMaybe)
25
import           System.IO       (hClose, hGetContents, openFile, IOMode (ReadMode))
26
27

import Curry.Base.Ident
Björn Peemöller 's avatar
Björn Peemöller committed
28
29
import Curry.Base.Message (runMsg)
import Curry.Base.Position
Björn Peemöller 's avatar
Björn Peemöller committed
30
import Curry.Base.Pretty
31
32
33
34
import Curry.ExtendedFlat.InterfaceEquality (eqInterface)
import Curry.Files.Filenames
import Curry.Files.PathUtils

Björn Peemöller 's avatar
Björn Peemöller committed
35
import Base.Messages
36
import Env.Interface
37
38
39
40
41
42
43
44
45
46
47
48
49

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

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

Björn Peemöller 's avatar
Björn Peemöller committed
83
loadModule :: Options -> FilePath -> CYIO (CompilerEnv, CS.Module)
84
loadModule opts fn = do
Björn Peemöller 's avatar
Björn Peemöller committed
85
86
87
88
89
  parsed <- parseModule fn
  -- check module header
  mdl    <- checkModuleHeader opts fn parsed
  -- load the imported interfaces into an InterfaceEnv
  iEnv   <- loadInterfaces (optImportPaths opts) mdl
90
  checkInterfaces opts iEnv
Björn Peemöller 's avatar
Björn Peemöller committed
91
92
93
94
95
96
97
  -- add information of imported modules
  cEnv   <- importModules opts mdl iEnv
  return (cEnv, mdl)

parseModule :: FilePath -> CYIO CS.Module
parseModule fn = do
  mbSrc <- liftIO $ readModule fn
98
  case mbSrc of
Björn Peemöller 's avatar
Björn Peemöller committed
99
    Nothing  -> left [message $ text $ "Missing file: " ++ fn]
100
101
    Just src -> do
      -- parse module
Björn Peemöller 's avatar
Björn Peemöller committed
102
103
104
105
106
107
      case runMsg (CS.parseModule fn src) of
        Left  err         -> left [err]
        Right (parsed, _) -> right parsed

checkModuleHeader :: Monad m => Options -> FilePath -> CS.Module
                  -> CYT m CS.Module
108
checkModuleHeader opts fn = checkModuleId fn
109
                          . importPrelude opts fn
110
                          . CS.patchModuleId fn
111
112

-- |Check whether the 'ModuleIdent' and the 'FilePath' fit together
Björn Peemöller 's avatar
Björn Peemöller committed
113
114
checkModuleId :: Monad m => FilePath -> CS.Module
              -> CYT m CS.Module
115
checkModuleId fn m@(CS.Module mid _ _ _)
116
  | last (midQualifiers mid) == takeBaseName fn
Björn Peemöller 's avatar
Björn Peemöller committed
117
  = right m
118
  | otherwise
Björn Peemöller 's avatar
Björn Peemöller committed
119
  = left [errModuleFileMismatch mid]
120
121
122
123
124
125

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

126
127
importPrelude :: Options -> FilePath -> CS.Module -> CS.Module
importPrelude opts fn m@(CS.Module mid es is ds)
128
129
130
131
132
133
134
135
136
    -- the Prelude itself
  | mid == preludeMIdent          = m
    -- disabled by compiler option
  | noImpPrelude                  = m
    -- already imported
  | preludeMIdent `elem` imported = m
    -- let's add it!
  | otherwise                     = CS.Module mid es (preludeImp : is) ds
  where
137
  noImpPrelude = NoImplicitPrelude `elem` optExtensions opts
138
  preludeImp   = CS.ImportDecl (first fn) preludeMIdent
139
140
141
142
                  False   -- qualified?
                  Nothing -- no alias
                  Nothing -- no selection of types, functions, etc.
  imported     = [imp | (CS.ImportDecl _ imp _ _ _) <- is]
143

144
145
146
147
148
149
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 ()
150

151
152
153
154
-- ---------------------------------------------------------------------------
-- Checking a module
-- ---------------------------------------------------------------------------

155
-- TODO: The order of the checks should be improved!
156
157
158
-- 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.
159
checkModule :: Options -> (CompilerEnv, CS.Module)
Björn Peemöller 's avatar
Björn Peemöller committed
160
            -> CYIO (CompilerEnv, CS.Module)
161
checkModule opts (env, mdl) = do
162
163
164
  doDump opts (DumpParsed       , env , show $ CS.ppModule mdl)
  (env1, kc) <- kindCheck   opts env mdl -- should be only syntax checking ?
  doDump opts (DumpKindChecked  , env1, show $ CS.ppModule kc)
165
  (env2, sc) <- syntaxCheck opts env1 kc
166
167
168
  doDump opts (DumpSyntaxChecked, env2, show $ CS.ppModule sc)
  (env3, pc) <- precCheck   opts env2 sc
  doDump opts (DumpPrecChecked  , env3, show $ CS.ppModule pc)
169
  (env4, tc) <- if withTypeCheck
170
                   then typeCheck opts env3 pc >>= uncurry (exportCheck opts)
171
                   else return (env3, pc)
172
  doDump opts (DumpTypeChecked  , env4, show $ CS.ppModule tc)
173
  return (env4, tc)
174
  where
175
176
  withTypeCheck = any (`elem` optTargetTypes opts)
                      [FlatCurry, ExtendedFlatCurry, FlatXml, AbstractCurry]
177
178
179
180
181

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

182
183
type Dump = (DumpLevel, CompilerEnv, String)

184
185
-- |Translate FlatCurry into the intermediate language 'IL'
transModule :: Options -> CompilerEnv -> CS.Module
186
            -> (CompilerEnv, IL.Module, [Dump])
187
188
transModule opts env mdl = (env5, ilCaseComp, dumps)
  where
189
  flat' = FlatCurry `elem` optTargetTypes opts
190
  (desugared , env1) = desugar        mdl        env
191
192
  (simplified, env2) = simplify flat' desugared  env1
  (lifted    , env3) = lift           simplified env2
Björn Peemöller 's avatar
Björn Peemöller committed
193
  (il        , env4) = ilTrans  flat' lifted     env3
194
  (ilCaseComp, env5) = completeCase   il         env4
195
196
197
198
199
  dumps = [ (DumpDesugared    , env1, presentCS desugared )
          , (DumpSimplified   , env2, presentCS simplified)
          , (DumpLifted       , env3, presentCS lifted    )
          , (DumpTranslated   , env4, presentIL il        )
          , (DumpCaseCompleted, env5, presentIL ilCaseComp)
200
          ]
201
202
  presentCS = if optDumpRaw opts then show else show . CS.ppModule
  presentIL = if optDumpRaw opts then show else show . IL.ppModule
203
204
205
206
207

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

208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
writeOutput :: Options -> FilePath -> (CompilerEnv, CS.Module) -> IO ()
writeOutput opts fn (env, modul) = do
  writeParsed opts fn modul
  let (env1, qlfd) = qual opts env modul
  doDump opts (DumpQualified, env1, show $ CS.ppModule qlfd)
  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
    mapM_ (doDump opts) dumps
    -- 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]

231
232
233
234
-- 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'
235
-- (depending on the compiler flag "force") and other modules importing this
236
237
238
239
240
241
242
-- 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 $
  writeModule useSubDir targetFile source
  where
243
244
245
246
  srcTarget  = Parsed `elem` optTargetTypes opts
  useSubDir  = optUseSubdir opts
  targetFile = fromMaybe (sourceRepName fn) (optOutput opts)
  source     = CS.showModule modul
247

248
249
writeInterface :: Options -> FilePath -> CS.Interface -> IO ()
writeInterface opts fn intf
250
251
252
253
  | optForce opts = outputInterface
  | otherwise     = do
      equal <- C.catch (matchInterface interfaceFile intf) ignoreIOException
      unless equal outputInterface
254
  where
255
256
257
  ignoreIOException :: C.IOException -> IO Bool
  ignoreIOException _ = return False

258
259
260
261
  interfaceFile   = interfName fn
  outputInterface = writeModule (optUseSubdir opts) interfaceFile
                    (show $ CS.ppInterface intf)

262
263
264
265
266
267
268
269
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')

270
writeFlat :: Options -> FilePath -> CompilerEnv -> ModuleSummary -> IL.Module
271
272
          -> IO ()
writeFlat opts fn env modSum il = do
273
274
  when (extTarget || fcyTarget) $ do
    writeFlatCurry opts fn env modSum il
275
    writeFlatIntf  opts fn env modSum il
276
  when (xmlTarget) $ writeFlatXml opts fn modSum il
277
278
279
280
  where
  extTarget    = ExtendedFlatCurry `elem` optTargetTypes opts
  fcyTarget    = FlatCurry         `elem` optTargetTypes opts
  xmlTarget    = FlatXml           `elem` optTargetTypes opts
281
282
283
284
285

-- |Export an 'IL.Module' into a FlatCurry file
writeFlatCurry :: Options -> FilePath -> CompilerEnv -> ModuleSummary
               -> IL.Module -> IO ()
writeFlatCurry opts fn env modSum il = do
Björn Peemöller 's avatar
Björn Peemöller committed
286
  warn opts msgs
287
  when extTarget $ EF.writeExtendedFlat useSubDir (extFlatName fn) prog
288
  when fcyTarget $ EF.writeFlatCurry    useSubDir (flatName    fn) prog
289
  where
290
291
292
293
  extTarget    = ExtendedFlatCurry `elem` optTargetTypes opts
  fcyTarget    = FlatCurry         `elem` optTargetTypes opts
  useSubDir    = optUseSubdir opts
  (prog, msgs) = genFlatCurry opts modSum env il
294

295
-- |Export an 'IL.Module' into an XML file
296
297
writeFlatXml :: Options -> FilePath -> ModuleSummary -> IL.Module -> IO ()
writeFlatXml opts fn modSum il = writeModule useSubDir (xmlName fn) curryXml
298
299
300
301
  where
  useSubDir = optUseSubdir opts
  curryXml  = shows (IL.xmlModule (interface modSum) (infixDecls modSum) il) "\n"

302
303
304
writeFlatIntf :: Options -> FilePath -> CompilerEnv -> ModuleSummary
              -> IL.Module -> IO ()
writeFlatIntf opts fn env modSum il
305
306
307
308
309
310
311
312
  | 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
313
314
315
316
  targetFile = flatIntName fn
  emptyIntf = EF.Prog "" [] [] [] []
  (newInterface, intMsgs) = genFlatInterface opts modSum env il
  outputInterface = do
Björn Peemöller 's avatar
Björn Peemöller committed
317
    warn opts intMsgs
318
    EF.writeFlatCurry (optUseSubdir opts) targetFile newInterface
319
320
321
322
323
324
325
326

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
327
328
329
  acyTarget  = AbstractCurry        `elem` optTargetTypes opts
  uacyTarget = UntypedAbstractCurry `elem` optTargetTypes opts
  useSubDir  = optUseSubdir opts
330

331
-- |The 'dump' function writes the selected information to standard output.
332
doDump :: MonadIO m => Options -> Dump -> m ()
Björn Peemöller 's avatar
Björn Peemöller committed
333
doDump opts (level, env, dump) = when (level `elem` optDumps opts) $ do
334
335
  when (optDumpEnv opts) $ liftIO $ putStrLn $ showCompilerEnv env
  liftIO $ putStrLn $ unlines [header, replicate (length header) '=', dump]
336
337
338
339
340
341
  where
  header = lookupHeader dumpLevel
  lookupHeader []            = "Unknown dump level " ++ show level
  lookupHeader ((l,_,h):lhs)
    | level == l = h
    | otherwise  = lookupHeader lhs
342

343
errModuleFileMismatch :: ModuleIdent -> Message
344
345
346
errModuleFileMismatch mid = posMessage mid $ hsep $ map text
  [ "Module", moduleName mid, "must be in a file"
  , moduleName mid ++ ".(l)curry" ]