Modules.hs 14 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
  (env, mdl) <- loadModule opts fn >>= checkModule opts
76
  warn (optWarnOpts opts) $ warnCheck opts env mdl
Björn Peemöller 's avatar
Björn Peemöller committed
77
  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
importPrelude :: Options -> FilePath -> CS.Module -> CS.Module
127
importPrelude opts fn m@(CS.Module ps mid es is ds)
128 129 130 131 132 133 134
    -- the Prelude itself
  | mid == preludeMIdent          = m
    -- disabled by compiler option
  | noImpPrelude                  = m
    -- already imported
  | preludeMIdent `elem` imported = m
    -- let's add it!
135
  | otherwise                     = CS.Module ps mid es (preludeImp : is) ds
136
  where
137
  noImpPrelude = NoImplicitPrelude `elem` optExtensions opts
138
                 || m `CS.hasLanguageExtension` NoImplicitPrelude
139
  preludeImp   = CS.ImportDecl (first fn) preludeMIdent
140 141 142 143
                  False   -- qualified?
                  Nothing -- no alias
                  Nothing -- no selection of types, functions, etc.
  imported     = [imp | (CS.ImportDecl _ imp _ _ _) <- is]
144

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

152 153 154 155
-- ---------------------------------------------------------------------------
-- Checking a module
-- ---------------------------------------------------------------------------

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

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

184 185
type Dump = (DumpLevel, CompilerEnv, String)

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

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

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

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

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

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

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

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

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

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

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

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

333
-- |The 'dump' function writes the selected information to standard output.
334 335 336
doDump :: MonadIO m => DebugOpts -> Dump -> m ()
doDump opts (level, env, dump) = when (level `elem` dbDumpLevels opts) $ do
  when (dbDumpEnv opts) $ liftIO $ putStrLn $ showCompilerEnv env
337
  liftIO $ putStrLn $ unlines [header, replicate (length header) '=', dump]
338 339 340 341 342 343
  where
  header = lookupHeader dumpLevel
  lookupHeader []            = "Unknown dump level " ++ show level
  lookupHeader ((l,_,h):lhs)
    | level == l = h
    | otherwise  = lookupHeader lhs
344

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