Modules.hs 13.6 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 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
Björn Peemöller 's avatar
Björn Peemöller committed
28
import Curry.Base.Pretty
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
import Base.Messages
34
import Env.Interface
35 36 37 38 39 40 41 42 43 44 45 46 47

-- 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
48
import InterfaceEquivalence
49 50 51 52 53 54
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
55
-- line options, it will emit either FlatCurry code (standard or in XML
56
-- representation) or AbstractCurry code (typed, untyped or with type
57 58 59
-- signatures) for the module
-- Usually, the first step is to check the module.
-- Then the code is translated into the intermediate
60
-- language. If necessary, this phase will also update the module's
61 62
-- interface file. The resulting code then is written out (in
-- FlatCurry or XML format) to the corresponding file.
63 64 65
-- 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.
66
--
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.

Björn Peemöller 's avatar
Björn Peemöller committed
71
compileModule :: Options -> FilePath -> CYIO ()
72
compileModule opts fn = do
Björn Peemöller 's avatar
Björn Peemöller committed
73 74 75
  (env, mdl) <- loadModule opts fn >>= checkModule opts
  warn opts $ warnCheck opts env mdl
  liftIO $ writeOutput opts fn (env, mdl)
76 77 78 79 80

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

Björn Peemöller 's avatar
Björn Peemöller committed
81
loadModule :: Options -> FilePath -> CYIO (CompilerEnv, CS.Module)
82
loadModule opts fn = do
Björn Peemöller 's avatar
Björn Peemöller committed
83 84 85 86 87
  parsed <- parseModule fn
  -- check module header
  mdl    <- checkModuleHeader opts fn parsed
  -- load the imported interfaces into an InterfaceEnv
  iEnv   <- loadInterfaces (optImportPaths opts) mdl
88
  checkInterfaces opts iEnv
Björn Peemöller 's avatar
Björn Peemöller committed
89 90 91 92 93 94 95
  -- 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
96
  case mbSrc of
Björn Peemöller 's avatar
Björn Peemöller committed
97
    Nothing  -> left [message $ text $ "Missing file: " ++ fn]
98 99
    Just src -> do
      -- parse module
Björn Peemöller 's avatar
Björn Peemöller committed
100 101 102 103 104 105
      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
106
checkModuleHeader opts fn = checkModuleId fn
107
                          . importPrelude opts fn
108
                          . CS.patchModuleId fn
109 110

-- |Check whether the 'ModuleIdent' and the 'FilePath' fit together
Björn Peemöller 's avatar
Björn Peemöller committed
111 112
checkModuleId :: Monad m => FilePath -> CS.Module
              -> CYT m CS.Module
113
checkModuleId fn m@(CS.Module mid _ _ _)
114
  | last (midQualifiers mid) == takeBaseName fn
Björn Peemöller 's avatar
Björn Peemöller committed
115
  = right m
116
  | otherwise
Björn Peemöller 's avatar
Björn Peemöller committed
117
  = left [errModuleFileMismatch mid]
118 119 120 121 122 123

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

124 125
importPrelude :: Options -> FilePath -> CS.Module -> CS.Module
importPrelude opts fn m@(CS.Module mid es is ds)
126 127 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!
  | otherwise                     = CS.Module mid es (preludeImp : is) ds
  where
135
  noImpPrelude = NoImplicitPrelude `elem` optExtensions opts
136
  preludeImp   = CS.ImportDecl (first fn) preludeMIdent
137 138 139 140
                  False   -- qualified?
                  Nothing -- no alias
                  Nothing -- no selection of types, functions, etc.
  imported     = [imp | (CS.ImportDecl _ imp _ _ _) <- is]
141

142 143 144 145 146 147
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 ()
148

149 150 151 152
-- ---------------------------------------------------------------------------
-- Checking a module
-- ---------------------------------------------------------------------------

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

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

180 181
type Dump = (DumpLevel, CompilerEnv, String)

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

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

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

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

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

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

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

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

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

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
319 320 321
  acyTarget  = AbstractCurry        `elem` optTargetTypes opts
  uacyTarget = UntypedAbstractCurry `elem` optTargetTypes opts
  useSubDir  = optUseSubdir opts
322

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

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