Modules.hs 14.2 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 Control.Monad (unless, when)
22
import qualified Data.Map as Map (elems)
23
import Data.Maybe (fromMaybe)
24
import Text.PrettyPrint
25 26

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

Björn Peemöller 's avatar
Björn Peemöller committed
33 34
import Base.Messages
  (Message, message, posMessage, warn, abortWithMessages)
35
import Env.Interface
36 37 38 39 40 41 42 43 44 45 46 47 48

-- 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
49
import InterfaceEquivalence
50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66
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
-- line options it will emit either C code or FlatCurry code (standard
-- or in XML
-- representation) or AbstractCurry code (typed, untyped or with type
-- signatures) for the module. Usually the first step is to
-- check the module. Then the code is translated into the intermediate
-- language. If necessary, this phase will also update the module's
-- interface file. The resulting code then is either written out (in
-- FlatCurry or XML format) or translated further into C code.
-- 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.
67
--
68 69 70
-- The compiler automatically loads the prelude when compiling any
-- module, except for the prelude itself, by adding an appropriate import
-- declaration to the module.
71
--
72 73 74 75 76 77 78
-- Since this modified version of the Muenster Curry Compiler is used
-- as a frontend for PAKCS, all functions for evaluating goals and generating
-- C code are obsolete and commented out.

compileModule :: Options -> FilePath -> IO ()
compileModule opts fn = do
  loaded <- loadModule opts fn
79 80 81 82
  checked <- runEitherT $ checkModule opts loaded
  case checked of
    Left errs -> abortWithMessages errs
    Right (env, mdl) -> do
83
      warn opts $ warnCheck opts env mdl
84
      writeParsed opts fn mdl
85
      writeOutput opts fn (env, mdl)
86 87 88

writeOutput :: Options -> FilePath -> (CompilerEnv, CS.Module) -> IO ()
writeOutput opts fn (env, modul) = do
89 90 91
  let (env1, qlfd) = qual opts env modul
  doDump opts (DumpQualified, env1, show $ CS.ppModule qlfd)
  writeAbstractCurry opts fn env1 qlfd
92 93 94 95
  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)
96
    let (env2, il, dumps) = transModule opts env1 qlfd
97 98 99
    -- dump intermediate results
    mapM_ (doDump opts) dumps
    -- generate target code
100 101
    let intf = exportInterface env2 qlfd
    let modSum = summarizeModule (tyConsEnv env2) intf qlfd
102 103 104 105
    writeFlat opts fn env2 modSum il
  where
  withFlat = any (`elem` optTargetTypes opts)
              [FlatCurry, FlatXml, ExtendedFlatCurry]
106 107 108 109 110 111 112

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

loadModule :: Options -> FilePath -> IO (CompilerEnv, CS.Module)
loadModule opts fn = do
113 114
  mbSrc <- readModule fn
  case mbSrc of
Björn Peemöller 's avatar
Björn Peemöller committed
115
    Nothing  -> abortWithMessages [message $ text $ "Missing file: " ++ fn] -- TODO
116 117
    Just src -> do
      -- parse module
118
      case runMsg $ CS.parseModule fn src of
Björn Peemöller 's avatar
Björn Peemöller committed
119 120 121 122 123 124 125 126
        Left err -> abortWithMessages [err]
        Right (parsed, _) -> do
          -- check module header
          let (mdl, hdrErrs) = checkModuleHeader opts fn parsed
          unless (null hdrErrs) $ abortWithMessages hdrErrs -- TODO
          -- load the imported interfaces into an InterfaceEnv
          (iEnv, intfErrs) <- loadInterfaces (optImportPaths opts) mdl
          unless (null intfErrs) $ abortWithMessages intfErrs -- TODO
127 128 129 130 131 132 133
          case checkInterfaces opts iEnv of
            CheckFailed intfImpErrs -> abortWithMessages intfImpErrs -- TODO
            _ -> do
              -- add information of imported modules
              let (env, impErrs) = importModules opts mdl iEnv
              unless (null impErrs) $ abortWithMessages impErrs -- TODO
              return (env, mdl)
134

135
checkModuleHeader :: Options -> FilePath -> CS.Module -> (CS.Module, [Message])
136
checkModuleHeader opts fn = checkModuleId fn
137
                          . importPrelude opts fn
138
                          . CS.patchModuleId fn
139 140

-- |Check whether the 'ModuleIdent' and the 'FilePath' fit together
141
checkModuleId :: FilePath -> CS.Module -> (CS.Module, [Message])
142
checkModuleId fn m@(CS.Module mid _ _ _)
143
  | last (midQualifiers mid) == takeBaseName fn
144 145 146 147 148 149 150 151 152
  = (m, [])
  | otherwise
  = (m, [errModuleFileMismatch mid])

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

153 154
importPrelude :: Options -> FilePath -> CS.Module -> CS.Module
importPrelude opts fn m@(CS.Module mid es is ds)
155 156 157 158 159 160 161 162 163
    -- 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
164
  noImpPrelude = NoImplicitPrelude `elem` optExtensions opts
165
  preludeImp   = CS.ImportDecl (first fn) preludeMIdent
166 167 168 169
                  False   -- qualified?
                  Nothing -- no alias
                  Nothing -- no selection of types, functions, etc.
  imported     = [imp | (CS.ImportDecl _ imp _ _ _) <- is]
170

171 172 173 174 175 176 177
checkInterfaces :: Options -> InterfaceEnv -> CheckResult ()
checkInterfaces opts iEnv = mapM_ (checkInterface opts iEnv) (Map.elems iEnv)

checkInterface :: Options -> InterfaceEnv -> CS.Interface -> CheckResult ()
checkInterface opts iEnv intf = interfaceCheck env intf
  where env = importInterfaces opts intf iEnv

178 179 180 181
-- ---------------------------------------------------------------------------
-- Checking a module
-- ---------------------------------------------------------------------------

182
-- TODO: The order of the checks should be improved!
183 184 185
-- 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.
186
checkModule :: Options -> (CompilerEnv, CS.Module)
187
            -> EitherT [Message] IO (CompilerEnv, CS.Module)
188
checkModule opts (env, mdl) = do
189 190 191
  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)
192
  (env2, sc) <- syntaxCheck opts env1 kc
193 194 195
  doDump opts (DumpSyntaxChecked, env2, show $ CS.ppModule sc)
  (env3, pc) <- precCheck   opts env2 sc
  doDump opts (DumpPrecChecked  , env3, show $ CS.ppModule pc)
196
  (env4, tc) <- if withTypeCheck
197
                   then typeCheck opts env3 pc >>= uncurry (exportCheck opts)
198
                   else return (env3, pc)
199
  doDump opts (DumpTypeChecked  , env4, show $ CS.ppModule tc)
200
  return (env4, tc)
201
  where
202 203
  withTypeCheck = any (`elem` optTargetTypes opts)
                      [FlatCurry, ExtendedFlatCurry, FlatXml, AbstractCurry]
204 205 206 207 208

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

209 210
type Dump = (DumpLevel, CompilerEnv, String)

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

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

-- 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'
239
-- (depending on the compiler flag "force") and other modules importing this
240 241 242 243 244 245 246
-- 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
247 248 249 250
  srcTarget  = Parsed `elem` optTargetTypes opts
  useSubDir  = optUseSubdir opts
  targetFile = fromMaybe (sourceRepName fn) (optOutput opts)
  source     = CS.showModule modul
251

252 253 254 255 256 257 258 259 260 261
writeInterface :: Options -> FilePath -> CS.Interface -> IO ()
writeInterface opts fn intf
  | not (optInterface opts) = return () -- TODO: reasonable?
  | optForce opts           = outputInterface
  | otherwise               = do
      mbOldIntf <- readModule interfaceFile
      case mbOldIntf of
        Nothing  -> outputInterface
        Just src -> case runMsg (CS.parseInterface interfaceFile src) of
          Left  _     -> outputInterface
262
          Right (i,_) -> unless (intf `intfEquiv` fixInterface i) outputInterface
263 264 265 266 267
  where
  interfaceFile   = interfName fn
  outputInterface = writeModule (optUseSubdir opts) interfaceFile
                    (show $ CS.ppInterface intf)

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

-- |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
284
  warn opts msgs
285
  when extTarget $ EF.writeExtendedFlat useSubDir (extFlatName fn) prog
286
  when fcyTarget $ EF.writeFlatCurry    useSubDir (flatName    fn) prog
287
  where
288 289 290 291
  extTarget    = ExtendedFlatCurry `elem` optTargetTypes opts
  fcyTarget    = FlatCurry         `elem` optTargetTypes opts
  useSubDir    = optUseSubdir opts
  (prog, msgs) = genFlatCurry opts modSum env il
292

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

300 301 302
writeFlatIntf :: Options -> FilePath -> CompilerEnv -> ModuleSummary
              -> IL.Module -> IO ()
writeFlatIntf opts fn env modSum il
303 304 305 306 307 308 309 310
  | 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
311 312 313 314
  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
315
    warn opts intMsgs
316
    EF.writeFlatCurry (optUseSubdir opts) targetFile newInterface
317 318 319 320 321 322 323 324

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

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

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