Modules.hs 12.5 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 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 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90
{- |
    Module      :  $Header$
    Description :  Compilation of a single module
    Copyright   :  (c) 1999-2004, Wolfgang Lux
                       2005, Martin Engelke (men@informatik.uni-kiel.de)
                       2007, Sebastian Fischer (sebf@informatik.uni-kiel.de)
                       2011, Björn Peemöller (bjp@informatik.uni-kiel.de)
    License     :  OtherLicense

    Maintainer  :  bjp@informatik.uni-kiel.de
    Stability   :  experimental
    Portability :  portable

    This module controls the compilation of modules.
-}

module Modules
  ( compileModule, loadModule, checkModuleHeader, checkModule
  ) where

import Control.Monad (liftM, unless, when)
import Data.Maybe (fromMaybe)

import Curry.Base.MessageMonad
import Curry.Base.Position
import Curry.Base.Ident
import Curry.ExtendedFlat.InterfaceEquality (eqInterface)
import Curry.Files.Filenames
import Curry.Files.PathUtils

import Base.Messages (abortWith, putErrsLn)

import Env.Eval (evalEnv)
import Env.Value (ppTypes)

-- 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.
-- 
-- The compiler automatically loads the prelude when compiling any
-- module, except for the prelude itself, by adding an appropriate import
-- declaration to the module.
-- 
-- 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
  let (env, modul) = uncurry (checkModule opts) loaded
  showWarnings opts $ uncurry warnCheck loaded
  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
    -- generate target code
    let intf = exportInterface env2 modul
    let modSum = summarizeModule (tyConsEnv env2) intf modul
91
    writeFlat opts fn env2 modSum il
92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 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 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165
  where
    withFlat = any (`elem` optTargetTypes opts)
                   [FlatCurry, FlatXml, ExtendedFlatCurry]

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

loadModule :: Options -> FilePath -> IO (CompilerEnv, CS.Module)
loadModule opts fn = do
  -- read and parse module
  parsed <- (ok . CS.parseModule (not extTarget) fn) `liftM` readModule fn
  -- check module header
  let (mdl, hdrErrs) = checkModuleHeader opts fn parsed
  unless (null hdrErrs) $ abortWith hdrErrs
  -- load the imported interfaces into an InterfaceEnv
  iEnv <- loadInterfaces (optImportPaths opts) mdl
  -- add information of imported modules
  let env = importModules opts mdl iEnv
  return (env, mdl)
  where extTarget = ExtendedFlatCurry `elem` optTargetTypes opts

checkModuleHeader :: Options -> FilePath -> CS.Module -> (CS.Module, [String])
checkModuleHeader opts fn = checkModuleId fn
                          . importPrelude opts
                          . patchModuleId fn

-- |Check whether the 'ModuleIdent' and the 'FilePath' fit together
checkModuleId :: FilePath -> CS.Module -> (CS.Module, [String])
checkModuleId fn m@(CS.Module mid _ _ _)
  | last (moduleQualifiers mid) == takeBaseName fn
  = (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.

importPrelude :: Options -> CS.Module -> CS.Module
importPrelude opts m@(CS.Module mid es is ds)
    -- 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
    noImpPrelude = NoImplicitPrelude `elem` optExtensions opts
    preludeImp   = CS.ImportDecl NoPos preludeMIdent
                   False   -- qualified?
                   Nothing -- no alias
                   Nothing -- no selection of types, functions, etc.
    imported     = [imp | (CS.ImportDecl _ imp _ _ _) <- is]

-- A module which doesn't contain a \texttt{module ... where} declaration
-- obtains its filename as module identifier (unlike the definition in
-- Haskell and original MCC where a module obtains \texttt{main}).

patchModuleId :: FilePath -> CS.Module -> CS.Module
patchModuleId fn m@(CS.Module mid es is ds)
  | mid == mainMIdent
    = CS.Module (mkMIdent [takeBaseName fn]) es is ds
  | otherwise
    = m

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

checkModule :: Options -> CompilerEnv -> CS.Module -> (CompilerEnv, CS.Module)
166 167
checkModule opts env mdl = qualEnv
                         $ uncurry exportCheck
168
                         $ uncurry qual
169
                         $ (if withTypeCheck then uncurry typeCheck else id)
170 171 172 173
                         $ uncurry precCheck
                         $ uncurry (syntaxCheck opts)
                         $ kindCheck env mdl
  where
174
  qualEnv (e, m) = (qualifyEnv opts e, m)
175 176
  withTypeCheck  = any (`elem` optTargetTypes opts)
                       [FlatCurry, ExtendedFlatCurry, FlatXml, AbstractCurry]
177 178 179 180 181 182 183

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

-- |Translate FlatCurry into the intermediate language 'IL'
transModule :: Options -> CompilerEnv -> CS.Module
Björn Peemöller 's avatar
Björn Peemöller committed
184
            -> (CompilerEnv, IL.Module, [(DumpLevel, String)])
185 186 187 188 189 190 191 192 193
transModule opts env mdl = (env5, ilCaseComp, dumps)
  where
    flat' = FlatCurry `elem` optTargetTypes opts
    env0 = env { evalAnnotEnv = evalEnv mdl }
    (desugared , env1) = desugar        mdl        env0
    (simplified, env2) = simplify flat' desugared  env1
    (lifted    , env3) = lift           simplified env2
    (il        , env4) = ilTrans flat'  lifted     env3
    (ilCaseComp, env5) = completeCase   il         env4
Björn Peemöller 's avatar
Björn Peemöller committed
194 195 196 197 198 199 200
    dumps = [ (DumpRenamed   , show $ CS.ppModule    mdl         )
            , (DumpTypes     , show $ ppTypes     (moduleIdent env) (valueEnv env))
            , (DumpDesugared , show $ CS.ppModule    desugared   )
            , (DumpSimplified, show $ CS.ppModule    simplified  )
            , (DumpLifted    , show $ CS.ppModule    lifted    )
            , (DumpIL        , show $ IL.ppModule il        )
            , (DumpCase      , show $ IL.ppModule ilCaseComp)
201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288
            ]

-- ---------------------------------------------------------------------------
-- 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'
-- (depending on the compiler flag "force") and other modules importing this 
-- 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
    srcTarget  = Parsed `elem` optTargetTypes opts
    useSubDir  = optUseSubdir opts
    targetFile = fromMaybe (sourceRepName fn) (optOutput opts)
    source     = CS.showModule modul

writeFlat :: Options -> FilePath -> CompilerEnv -> ModuleSummary -> IL.Module 
          -> IO ()
writeFlat opts fn env modSum il = do
  writeFlatCurry opts fn env modSum il
  writeInterface opts fn env modSum il
  writeXML       opts fn     modSum il

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

writeInterface :: Options -> FilePath -> CompilerEnv -> ModuleSummary
               -> IL.Module -> IO ()
writeInterface opts fn env modSum il
  | 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
    targetFile = flatIntName fn
    emptyIntf = EF.Prog "" [] [] [] []
    (newInterface, intMsgs) = genFlatInterface opts modSum env il
    outputInterface = do
      showWarnings opts intMsgs
      EF.writeFlatCurry (optUseSubdir opts) targetFile newInterface

-- |Export an 'IL.Module' into an XML file
writeXML :: Options -> FilePath -> ModuleSummary -> IL.Module -> IO ()
writeXML opts fn modSum il = when xmlTarget $
  writeModule useSubDir targetFile curryXml
  where
    xmlTarget  = FlatXml `elem` optTargetTypes opts
    useSubDir  = optUseSubdir opts
    targetFile = fromMaybe (xmlName fn) (optOutput opts)
    curryXml   = shows (IL.xmlModule modSum il) "\n"

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

showWarnings :: Options -> [Message] -> IO ()
showWarnings opts msgs = when (optWarn opts)
                       $ putErrsLn $ map showWarning msgs

-- |The 'doDump' function writes the selected information to the
-- standard output.
Björn Peemöller 's avatar
Björn Peemöller committed
289
doDump :: Options -> (DumpLevel, String) -> IO ()
290
doDump opts (level, dump) = when (level `elem` optDumps opts) $ putStrLn $
Björn Peemöller 's avatar
Björn Peemöller committed
291
  unlines [header, replicate (length header) '=', dump]
292 293 294 295 296 297 298 299 300 301 302 303 304 305
  where header = dumpHeader level

dumpHeader :: DumpLevel -> String
dumpHeader DumpRenamed    = "Module after renaming"
dumpHeader DumpTypes      = "Types"
dumpHeader DumpDesugared  = "Source code after desugaring"
dumpHeader DumpSimplified = "Source code after simplification"
dumpHeader DumpLifted     = "Source code after lifting"
dumpHeader DumpIL         = "Intermediate code"
dumpHeader DumpCase       = "Intermediate code after case completion"

errModuleFileMismatch :: ModuleIdent -> String
errModuleFileMismatch mid = "module \"" ++ moduleName mid
  ++ "\" must be in a file \"" ++ moduleName mid ++ ".(l)curry\""