Modules.hs 14.5 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 83 84
  (env, mdl) <- loadAndCheckModule opts fn
  liftIO $ writeOutput opts fn (env, mdl)

loadAndCheckModule :: Options -> FilePath -> CYIO (CompilerEnv, CS.Module)
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
-- ---------------------------------------------------------------------------

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

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

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

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
140 141 142

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

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

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

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

180 181 182 183 184 185
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 ()
186

187 188 189 190
-- ---------------------------------------------------------------------------
-- Checking a module
-- ---------------------------------------------------------------------------

191
-- TODO: The order of the checks should be improved!
192 193 194
-- 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.
195
checkModule :: Options -> (CompilerEnv, CS.Module)
Björn Peemöller 's avatar
Björn Peemöller committed
196
            -> CYIO (CompilerEnv, CS.Module)
197
checkModule opts (env, mdl) = do
198
  doDump debugOpts (DumpParsed       , env , show $ CS.ppModule mdl)
199
  (env1, kc) <- kindCheck   opts env mdl -- should be only syntax checking ?
200
  doDump debugOpts (DumpKindChecked  , env1, show $ CS.ppModule kc)
201
  (env2, sc) <- syntaxCheck opts env1 kc
202
  doDump debugOpts (DumpSyntaxChecked, env2, show $ CS.ppModule sc)
203
  (env3, pc) <- precCheck   opts env2 sc
204
  doDump debugOpts (DumpPrecChecked  , env3, show $ CS.ppModule pc)
205
  (env4, tc) <- if withTypeCheck
206
                   then typeCheck opts env3 pc >>= uncurry (exportCheck opts)
207
                   else return (env3, pc)
208
  doDump debugOpts (DumpTypeChecked  , env4, show $ CS.ppModule tc)
209
  return (env4, tc)
210
  where
211
  debugOpts = optDebugOpts opts
212
  withTypeCheck = any (`elem` optTargetTypes opts)
213
                      [FlatCurry, ExtendedFlatCurry, AbstractCurry]
214 215 216 217 218

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

219 220
type Dump = (DumpLevel, CompilerEnv, String)

221 222
-- |Translate FlatCurry into the intermediate language 'IL'
transModule :: Options -> CompilerEnv -> CS.Module
223
            -> (CompilerEnv, IL.Module, [Dump])
224 225
transModule opts env mdl = (env5, ilCaseComp, dumps)
  where
226
  flat' = FlatCurry `elem` optTargetTypes opts
227
  (desugared , env1) = desugar        mdl        env
228 229
  (simplified, env2) = simplify flat' desugared  env1
  (lifted    , env3) = lift           simplified env2
Björn Peemöller 's avatar
Björn Peemöller committed
230
  (il        , env4) = ilTrans  flat' lifted     env3
231
  (ilCaseComp, env5) = completeCase   il         env4
232 233 234 235 236
  dumps = [ (DumpDesugared    , env1, presentCS desugared )
          , (DumpSimplified   , env2, presentCS simplified)
          , (DumpLifted       , env3, presentCS lifted    )
          , (DumpTranslated   , env4, presentIL il        )
          , (DumpCaseCompleted, env5, presentIL ilCaseComp)
237
          ]
238 239 240
  presentCS = if dumpRaw then show else show . CS.ppModule
  presentIL = if dumpRaw then show else show . IL.ppModule
  dumpRaw   = dbDumpRaw (optDebugOpts opts)
241 242 243 244 245

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

246 247 248
writeOutput :: Options -> FilePath -> (CompilerEnv, CS.Module) -> IO ()
writeOutput opts fn (env, modul) = do
  writeParsed opts fn modul
249
  let (qlfd, env1) = qual opts env modul
250
  doDump (optDebugOpts opts) (DumpQualified, env1, show $ CS.ppModule qlfd)
251 252 253 254
  writeAbstractCurry opts fn env1 qlfd
  when withFlat $ do
    let (env2, il, dumps) = transModule opts env1 qlfd
    -- dump intermediate results
255
    mapM_ (doDump (optDebugOpts opts)) dumps
256 257 258 259 260 261 262
    -- 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
263
  withFlat = any (`elem` optTargetTypes opts) [FlatCurry, ExtendedFlatCurry]
264

265 266 267 268
-- 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'
269
-- (depending on the compiler flag "force") and other modules importing this
270 271 272 273 274
-- 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 $
275
  writeModule useSubDir (sourceRepName fn) source
276
  where
277 278 279
  srcTarget  = Parsed `elem` optTargetTypes opts
  useSubDir  = optUseSubdir opts
  source     = CS.showModule modul
280

281 282
writeInterface :: Options -> FilePath -> CS.Interface -> IO ()
writeInterface opts fn intf
283 284 285 286
  | optForce opts = outputInterface
  | otherwise     = do
      equal <- C.catch (matchInterface interfaceFile intf) ignoreIOException
      unless equal outputInterface
287
  where
288 289 290
  ignoreIOException :: C.IOException -> IO Bool
  ignoreIOException _ = return False

291 292 293 294
  interfaceFile   = interfName fn
  outputInterface = writeModule (optUseSubdir opts) interfaceFile
                    (show $ CS.ppInterface intf)

295 296 297 298
matchInterface :: FilePath -> CS.Interface -> IO Bool
matchInterface ifn i = do
  hdl <- openFile ifn ReadMode
  src <- hGetContents hdl
299
  case runCYM (CS.parseInterface ifn src) of
300 301
    Left  _  -> hClose hdl >> return False
    Right i' -> return (i `intfEquiv` fixInterface i')
302

303
writeFlat :: Options -> FilePath -> CompilerEnv -> ModuleSummary -> IL.Module
304 305
          -> IO ()
writeFlat opts fn env modSum il = do
306 307
  when (extTarget || fcyTarget) $ do
    writeFlatCurry opts fn env modSum il
308
    writeFlatIntf  opts fn env modSum il
309 310 311
  where
  extTarget    = ExtendedFlatCurry `elem` optTargetTypes opts
  fcyTarget    = FlatCurry         `elem` optTargetTypes opts
312 313 314 315 316 317

-- |Export an 'IL.Module' into a FlatCurry file
writeFlatCurry :: Options -> FilePath -> CompilerEnv -> ModuleSummary
               -> IL.Module -> IO ()
writeFlatCurry opts fn env modSum il = do
  when extTarget $ EF.writeExtendedFlat useSubDir (extFlatName fn) prog
318
  when fcyTarget $ EF.writeFlatCurry    useSubDir (flatName    fn) prog
319
  where
320 321 322 323
  extTarget = ExtendedFlatCurry `elem` optTargetTypes opts
  fcyTarget = FlatCurry         `elem` optTargetTypes opts
  useSubDir = optUseSubdir opts
  prog      = genFlatCurry modSum env il
324

325 326 327
writeFlatIntf :: Options -> FilePath -> CompilerEnv -> ModuleSummary
              -> IL.Module -> IO ()
writeFlatIntf opts fn env modSum il
328 329 330 331 332 333
  | 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
334
      unless (oldInterface `eqInterface` intf) $ outputInterface
335
  where
336 337
  targetFile = flatIntName fn
  emptyIntf = EF.Prog "" [] [] [] []
338 339
  intf = genFlatInterface modSum env il
  outputInterface = EF.writeFlatCurry (optUseSubdir opts) targetFile intf
340 341 342 343 344 345 346 347

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
348 349 350
  acyTarget  = AbstractCurry        `elem` optTargetTypes opts
  uacyTarget = UntypedAbstractCurry `elem` optTargetTypes opts
  useSubDir  = optUseSubdir opts
351

352
-- |The 'dump' function writes the selected information to standard output.
353 354 355
doDump :: MonadIO m => DebugOpts -> Dump -> m ()
doDump opts (level, env, dump) = when (level `elem` dbDumpLevels opts) $ do
  when (dbDumpEnv opts) $ liftIO $ putStrLn $ showCompilerEnv env
356
  liftIO $ putStrLn $ unlines [header, replicate (length header) '=', dump]
357 358 359 360 361 362
  where
  header = lookupHeader dumpLevel
  lookupHeader []            = "Unknown dump level " ++ show level
  lookupHeader ((l,_,h):lhs)
    | level == l = h
    | otherwise  = lookupHeader lhs
363

364
errModuleFileMismatch :: ModuleIdent -> Message
365 366 367
errModuleFileMismatch mid = posMessage mid $ hsep $ map text
  [ "Module", moduleName mid, "must be in a file"
  , moduleName mid ++ ".(l)curry" ]