Modules.hs 15.3 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 22 23 24 25 26 27 28 29 30 31
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)
32 33

import Curry.Base.Ident
Björn Peemöller 's avatar
Björn Peemöller committed
34 35
import Curry.Base.Message (runMsg)
import Curry.Base.Position
Björn Peemöller 's avatar
Björn Peemöller committed
36
import Curry.Base.Pretty
37 38 39 40
import Curry.ExtendedFlat.InterfaceEquality (eqInterface)
import Curry.Files.Filenames
import Curry.Files.PathUtils

Björn Peemöller 's avatar
Björn Peemöller committed
41
import Base.Messages
42
import Env.Interface
43 44 45 46 47 48 49 50 51 52 53 54 55

-- 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
56
import InterfaceEquivalence
57 58 59 60 61 62
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
63
-- line options, it will emit either FlatCurry code (standard or in XML
64
-- representation) or AbstractCurry code (typed, untyped or with type
65 66 67
-- signatures) for the module
-- 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 (in
-- FlatCurry or XML format) 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 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
Björn Peemöller 's avatar
Björn Peemöller committed
81
  (env, mdl) <- loadModule opts fn >>= checkModule opts
82
  warn (optWarnOpts opts) $ warnCheck opts env mdl
Björn Peemöller 's avatar
Björn Peemöller committed
83
  liftIO $ writeOutput opts fn (env, mdl)
84 85 86 87 88

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

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

101 102
parseModule :: Options -> FilePath -> CYIO CS.Module
parseModule opts fn = do
Björn Peemöller 's avatar
Björn Peemöller committed
103
  mbSrc <- liftIO $ readModule fn
104
  case mbSrc of
Björn Peemöller 's avatar
Björn Peemöller committed
105
    Nothing  -> left [message $ text $ "Missing file: " ++ fn]
106
    Just src -> do
107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140
      case runMsg (CS.unlit fn src) of
        Left err      -> left [err]
        Right (ul, _) -> do
        prepd <- preprocess (optPrepOpts opts) fn ul
        -- parse module
        case runMsg (CS.parseModule fn prepd) of
          Left  err         -> left [err]
          Right (parsed, _) -> right parsed

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
    either left right res

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

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

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

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

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

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

188 189 190 191
-- ---------------------------------------------------------------------------
-- Checking a module
-- ---------------------------------------------------------------------------

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

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

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

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

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

247 248 249 250
writeOutput :: Options -> FilePath -> (CompilerEnv, CS.Module) -> IO ()
writeOutput opts fn (env, modul) = do
  writeParsed opts fn modul
  let (env1, qlfd) = qual opts env modul
251
  doDump (optDebugOpts opts) (DumpQualified, env1, show $ CS.ppModule qlfd)
252 253 254 255 256 257 258
  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
259
    mapM_ (doDump (optDebugOpts opts)) dumps
260 261 262 263 264 265 266 267 268 269
    -- 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]

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

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

296 297 298 299
  interfaceFile   = interfName fn
  outputInterface = writeModule (optUseSubdir opts) interfaceFile
                    (show $ CS.ppInterface intf)

300 301 302 303 304 305 306 307
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')

308
writeFlat :: Options -> FilePath -> CompilerEnv -> ModuleSummary -> IL.Module
309 310
          -> IO ()
writeFlat opts fn env modSum il = do
311 312
  when (extTarget || fcyTarget) $ do
    writeFlatCurry opts fn env modSum il
313
    writeFlatIntf  opts fn env modSum il
314
  when (xmlTarget) $ writeFlatXml opts fn modSum il
315 316 317 318
  where
  extTarget    = ExtendedFlatCurry `elem` optTargetTypes opts
  fcyTarget    = FlatCurry         `elem` optTargetTypes opts
  xmlTarget    = FlatXml           `elem` optTargetTypes opts
319 320 321 322 323

-- |Export an 'IL.Module' into a FlatCurry file
writeFlatCurry :: Options -> FilePath -> CompilerEnv -> ModuleSummary
               -> IL.Module -> IO ()
writeFlatCurry opts fn env modSum il = do
324
  warn (optWarnOpts opts) msgs
325
  when extTarget $ EF.writeExtendedFlat useSubDir (extFlatName fn) prog
326
  when fcyTarget $ EF.writeFlatCurry    useSubDir (flatName    fn) prog
327
  where
328 329 330 331
  extTarget    = ExtendedFlatCurry `elem` optTargetTypes opts
  fcyTarget    = FlatCurry         `elem` optTargetTypes opts
  useSubDir    = optUseSubdir opts
  (prog, msgs) = genFlatCurry opts modSum env il
332

333
-- |Export an 'IL.Module' into an XML file
334 335
writeFlatXml :: Options -> FilePath -> ModuleSummary -> IL.Module -> IO ()
writeFlatXml opts fn modSum il = writeModule useSubDir (xmlName fn) curryXml
336 337 338 339
  where
  useSubDir = optUseSubdir opts
  curryXml  = shows (IL.xmlModule (interface modSum) (infixDecls modSum) il) "\n"

340 341 342
writeFlatIntf :: Options -> FilePath -> CompilerEnv -> ModuleSummary
              -> IL.Module -> IO ()
writeFlatIntf opts fn env modSum il
343 344 345 346 347 348 349 350
  | 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
351 352 353 354
  targetFile = flatIntName fn
  emptyIntf = EF.Prog "" [] [] [] []
  (newInterface, intMsgs) = genFlatInterface opts modSum env il
  outputInterface = do
355
    warn (optWarnOpts opts) intMsgs
356
    EF.writeFlatCurry (optUseSubdir opts) targetFile newInterface
357 358 359 360 361 362 363 364

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
365 366 367
  acyTarget  = AbstractCurry        `elem` optTargetTypes opts
  uacyTarget = UntypedAbstractCurry `elem` optTargetTypes opts
  useSubDir  = optUseSubdir opts
368

369
-- |The 'dump' function writes the selected information to standard output.
370 371 372
doDump :: MonadIO m => DebugOpts -> Dump -> m ()
doDump opts (level, env, dump) = when (level `elem` dbDumpLevels opts) $ do
  when (dbDumpEnv opts) $ liftIO $ putStrLn $ showCompilerEnv env
373
  liftIO $ putStrLn $ unlines [header, replicate (length header) '=', dump]
374 375 376 377 378 379
  where
  header = lookupHeader dumpLevel
  lookupHeader []            = "Unknown dump level " ++ show level
  lookupHeader ((l,_,h):lhs)
    | level == l = h
    | otherwise  = lookupHeader lhs
380

381
errModuleFileMismatch :: ModuleIdent -> Message
382 383 384
errModuleFileMismatch mid = posMessage mid $ hsep $ map text
  [ "Module", moduleName mid, "must be in a file"
  , moduleName mid ++ ".(l)curry" ]