Modules.hs 13.7 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 Data.Maybe (fromMaybe)
23
import Text.PrettyPrint
24 25

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

Björn Peemöller 's avatar
Björn Peemöller committed
32 33
import Base.Messages
  (Message, message, posMessage, warn, abortWithMessages)
34 35 36 37 38 39 40 41 42 43 44 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
-- 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.
64
--
65 66 67
-- The compiler automatically loads the prelude when compiling any
-- module, except for the prelude itself, by adding an appropriate import
-- declaration to the module.
68
--
69 70 71 72 73 74 75
-- 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
76
  case checkModule opts loaded of
77
    CheckFailed errs -> abortWithMessages errs
78
    CheckSuccess (env, mdl, dumps) -> do
Björn Peemöller 's avatar
Björn Peemöller committed
79
      warn opts $ warnCheck env mdl
80 81
      mapM_ (doDump opts) dumps
      writeOutput opts fn (env, mdl)
82 83 84 85 86 87 88 89 90 91 92 93

writeOutput :: Options -> FilePath -> (CompilerEnv, CS.Module) -> IO ()
writeOutput opts fn (env, modul) = do
  writeParsed        opts fn     modul
  writeAbstractCurry opts fn env modul
  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 env modul
    -- dump intermediate results
    mapM_ (doDump opts) dumps
94
    -- generate interface file
95
    let intf = exportInterface env2 modul
96 97
    writeInterface opts fn intf
    -- generate target code
98 99 100 101 102
    let modSum = summarizeModule (tyConsEnv env2) intf modul
    writeFlat opts fn env2 modSum il
  where
  withFlat = any (`elem` optTargetTypes opts)
              [FlatCurry, FlatXml, ExtendedFlatCurry]
103 104 105 106 107 108 109

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

loadModule :: Options -> FilePath -> IO (CompilerEnv, CS.Module)
loadModule opts fn = do
110 111 112
  -- read module
  mbSrc <- readModule fn
  case mbSrc of
Björn Peemöller 's avatar
Björn Peemöller committed
113
    Nothing  -> abortWithMessages [message $ text $ "Missing file: " ++ fn] -- TODO
114 115
    Just src -> do
      -- parse module
116
      case runMsg $ CS.parseModule fn src of
Björn Peemöller 's avatar
Björn Peemöller committed
117 118 119 120 121 122 123 124 125 126 127 128
        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
          -- add information of imported modules
          let (env, impErrs) = importModules opts mdl iEnv
          unless (null impErrs) $ abortWithMessages impErrs -- TODO
          return (env, mdl)
129

130
checkModuleHeader :: Options -> FilePath -> CS.Module -> (CS.Module, [Message])
131
checkModuleHeader opts fn = checkModuleId fn
132
                          . importPrelude opts fn
133
                          . CS.patchModuleId fn
134 135

-- |Check whether the 'ModuleIdent' and the 'FilePath' fit together
136
checkModuleId :: FilePath -> CS.Module -> (CS.Module, [Message])
137
checkModuleId fn m@(CS.Module mid _ _ _)
138
  | last (midQualifiers mid) == takeBaseName fn
139 140 141 142 143 144 145 146 147
  = (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.

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

-- ---------------------------------------------------------------------------
-- Checking a module
-- ---------------------------------------------------------------------------

170
-- TODO: The order of the checks should be improved!
171 172 173
-- 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.
174
checkModule :: Options -> (CompilerEnv, CS.Module)
175 176 177 178 179 180 181 182 183
            -> CheckResult (CompilerEnv, CS.Module, [Dump])
checkModule opts (env, mdl) = do
  (env1, kc) <- kindCheck env mdl -- should be only syntax checking ?
  (env2, sc) <- syntaxCheck opts env1 kc
  (env3, pc) <- precCheck        env2 sc
  (env4, tc) <- if withTypeCheck
                   then typeCheck env3 pc >>= uncurry exportCheck
                   else return (env3, pc)
  (env5, ql) <- return $ qual opts env4 tc
184 185 186 187 188 189
  let dumps = [ (DumpParsed       , env , show $ CS.ppModule mdl)
              , (DumpKindChecked  , env1, show $ CS.ppModule kc)
              , (DumpSyntaxChecked, env2, show $ CS.ppModule sc)
              , (DumpPrecChecked  , env3, show $ CS.ppModule pc)
              , (DumpTypeChecked  , env4, show $ CS.ppModule tc)
              , (DumpQualified    , env5, show $ CS.ppModule ql)
190 191
              ]
  return (env5, ql, dumps)
192
  where
193 194
  withTypeCheck = any (`elem` optTargetTypes opts)
                      [FlatCurry, ExtendedFlatCurry, FlatXml, AbstractCurry]
195 196 197 198 199

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

200 201
type Dump = (DumpLevel, CompilerEnv, String)

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

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

243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258
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
          Right (i,_) -> unless (i == intf) outputInterface
  where
  interfaceFile   = interfName fn
  outputInterface = writeModule (optUseSubdir opts) interfaceFile
                    (show $ CS.ppInterface intf)

259
writeFlat :: Options -> FilePath -> CompilerEnv -> ModuleSummary -> IL.Module
260 261
          -> IO ()
writeFlat opts fn env modSum il = do
262 263
  when (extTarget || fcyTarget) $ do
    writeFlatCurry opts fn env modSum il
264 265
    writeFlatIntf  opts fn env modSum il
  when (xmlTarget) $ writeFlatXml opts fn modSum il
266 267 268 269
  where
  extTarget    = ExtendedFlatCurry `elem` optTargetTypes opts
  fcyTarget    = FlatCurry         `elem` optTargetTypes opts
  xmlTarget    = FlatXml           `elem` optTargetTypes opts
270 271 272 273 274

-- |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
275
  warn opts msgs
276
  when extTarget $ EF.writeExtendedFlat useSubDir (extFlatName fn) prog
277
  when fcyTarget $ EF.writeFlatCurry    useSubDir (flatName    fn) prog
278
  where
279 280 281 282
  extTarget    = ExtendedFlatCurry `elem` optTargetTypes opts
  fcyTarget    = FlatCurry         `elem` optTargetTypes opts
  useSubDir    = optUseSubdir opts
  (prog, msgs) = genFlatCurry opts modSum env il
283

284
-- |Export an 'IL.Module' into an XML file
285 286
writeFlatXml :: Options -> FilePath -> ModuleSummary -> IL.Module -> IO ()
writeFlatXml opts fn modSum il = writeModule useSubDir (xmlName fn) curryXml
287 288 289 290
  where
  useSubDir = optUseSubdir opts
  curryXml  = shows (IL.xmlModule (interface modSum) (infixDecls modSum) il) "\n"

291 292 293
writeFlatIntf :: Options -> FilePath -> CompilerEnv -> ModuleSummary
              -> IL.Module -> IO ()
writeFlatIntf opts fn env modSum il
294 295 296 297 298 299 300 301
  | 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
302 303 304 305
  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
306
    warn opts intMsgs
307
    EF.writeFlatCurry (optUseSubdir opts) targetFile newInterface
308 309 310 311 312 313 314 315

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
316 317 318
  acyTarget  = AbstractCurry        `elem` optTargetTypes opts
  uacyTarget = UntypedAbstractCurry `elem` optTargetTypes opts
  useSubDir  = optUseSubdir opts
319

320
-- |The 'dump' function writes the selected information to standard output.
Björn Peemöller 's avatar
Björn Peemöller committed
321 322
doDump :: Options -> Dump -> IO ()
doDump opts (level, env, dump) = when (level `elem` optDumps opts) $ do
323 324
  when (optDumpEnv opts) $ putStrLn $ showCompilerEnv env
  putStrLn $ unlines [header, replicate (length header) '=', dump]
325 326 327 328 329 330
  where
  header = lookupHeader dumpLevel
  lookupHeader []            = "Unknown dump level " ++ show level
  lookupHeader ((l,_,h):lhs)
    | level == l = h
    | otherwise  = lookupHeader lhs
331

332
errModuleFileMismatch :: ModuleIdent -> Message
333 334 335
errModuleFileMismatch mid = posMessage mid $ hsep $ map text
  [ "Module", moduleName mid, "must be in a file"
  , moduleName mid ++ ".(l)curry" ]