{- | Module : $Header$ Description : Compilation of a single module Copyright : (c) 1999 - 2004 Wolfgang Lux 2005 Martin Engelke 2007 Sebastian Fischer 2011 - 2015 Björn Peemöller 2016 Jan Tikovsky 2016 - 2017 Finn Teegen 2018 Kai-Oliver Prott License : BSD-3-clause Maintainer : fte@informatik.uni-kiel.de Stability : experimental Portability : portable This module controls the compilation of modules. -} module Modules ( compileModule, loadAndCheckModule, loadModule, checkModule , parseModule, checkModuleHeader ) where import qualified Control.Exception as C (catch, IOException) import Control.Monad (liftM, unless, when) import Data.Char (toUpper) import qualified Data.Map as Map (elems, lookup) import Data.Maybe (fromMaybe) import System.Directory (getTemporaryDirectory, removeFile) import System.Exit (ExitCode (..)) import System.FilePath (normalise) import System.IO (IOMode (ReadMode), Handle, hClose, hGetContents, hPutStr, openFile , openTempFile) import System.Process (system) import Curry.Base.Ident import Curry.Base.Monad import Curry.Base.SpanInfo import Curry.Base.Pretty import Curry.Base.Span import Curry.FlatCurry.InterfaceEquivalence (eqInterface) import Curry.Files.Filenames import Curry.Files.PathUtils import Curry.Syntax.InterfaceEquivalence import Curry.Syntax.Utils (shortenModuleAST) import Curry.Syntax.Lexer (Token(..), Category(..)) import Base.Messages import Base.Types import Env.Interface -- source representations import qualified Curry.AbstractCurry as AC import qualified Curry.FlatCurry as FC import qualified Curry.Syntax as CS import qualified IL as IL import Checks import CompilerEnv import CompilerOpts import CondCompile (condCompile) import Exports import Generators import Html.CurryHtml (source2html) import Imports import Interfaces (loadInterfaces) import TokenStream (showTokenStream, showCommentTokenStream) 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 FlatCurry code 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 written out -- to the corresponding file. -- 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. compileModule :: Options -> ModuleIdent -> FilePath -> CYIO () compileModule opts m fn = do mdl <- loadAndCheckModule opts m fn writeTokens opts (fst mdl) writeComments opts (fst mdl) writeParsed opts mdl let qmdl = qual mdl writeHtml opts qmdl let umdl = (fst qmdl, fmap (const ()) (snd qmdl)) writeAST opts umdl writeShortAST opts umdl mdl' <- expandExports opts mdl qmdl' <- dumpWith opts CS.showModule CS.ppModule DumpQualified $ qual mdl' writeAbstractCurry opts qmdl' -- generate interface file let intf = uncurry exportInterface qmdl' writeInterface opts (fst mdl') intf when withFlat $ do ((env, il), mdl'') <- transModule opts qmdl' writeFlat opts env (snd mdl'') il where withFlat = any (`elem` optTargetTypes opts) [TypedFlatCurry, FlatCurry] loadAndCheckModule :: Options -> ModuleIdent -> FilePath -> CYIO (CompEnv (CS.Module PredType)) loadAndCheckModule opts m fn = do ce <- loadModule opts m fn >>= checkModule opts warnMessages $ uncurry (warnCheck opts) ce return ce -- --------------------------------------------------------------------------- -- Loading a module -- --------------------------------------------------------------------------- loadModule :: Options -> ModuleIdent -> FilePath -> CYIO (CompEnv (CS.Module ())) loadModule opts m fn = do -- parse and check module header (toks, mdl) <- parseModule opts m fn -- load the imported interfaces into an InterfaceEnv let paths = map (addCurrySubdir (optUseSubdir opts)) ("." : optImportPaths opts) iEnv <- loadInterfaces paths mdl checkInterfaces opts iEnv is <- importSyntaxCheck iEnv mdl -- add information of imported modules cEnv <- importModules mdl iEnv is return (cEnv { filePath = fn, tokens = toks }, mdl) parseModule :: Options -> ModuleIdent -> FilePath -> CYIO ([(Span, CS.Token)], CS.Module ()) parseModule opts m fn = do mbSrc <- liftIO $ readModule fn case mbSrc of Nothing -> failMessages [message $ text $ "Missing file: " ++ fn] Just src -> do ul <- liftCYM $ CS.unlit fn src prepd <- preprocess (optPrepOpts opts) fn ul condC <- condCompile (optCppOpts opts) fn prepd doDump ((optDebugOpts opts) { dbDumpEnv = False }) (DumpCondCompiled, undefined, condC) -- We ignore the warnings issued by the lexer because -- they will be issued a second time during parsing. spanToks <- liftCYM $ silent $ CS.lexSource fn condC ast <- liftCYM $ CS.parseModule fn condC checked <- checkModuleHeader opts m fn ast return (spanToks, checked) preprocess :: PrepOpts -> FilePath -> String -> CYIO String preprocess opts fn src | not (ppPreprocess opts) = return src | otherwise = do res <- liftIO $ withTempFile $ \ inFn inHdl -> do hPutStr inHdl src hClose inHdl withTempFile $ \ outFn outHdl -> do hClose outHdl ec <- system $ unwords $ [ppCmd opts, normalise fn, inFn, outFn] ++ ppOpts opts case ec of ExitFailure x -> return $ Left [message $ text $ "Preprocessor exited with exit code " ++ show x] ExitSuccess -> Right `liftM` readFile outFn either failMessages ok res withTempFile :: (FilePath -> Handle -> IO a) -> IO a withTempFile act = do tmp <- getTemporaryDirectory (fn, hdl) <- openTempFile tmp "cymake.curry" res <- act fn hdl hClose hdl removeFile fn return res checkModuleHeader :: Monad m => Options -> ModuleIdent -> FilePath -> CS.Module () -> CYT m (CS.Module ()) checkModuleHeader opts m fn = checkModuleId m . importPrelude opts . CS.patchModuleId fn -- |Check whether the 'ModuleIdent' and the 'FilePath' fit together checkModuleId :: Monad m => ModuleIdent -> CS.Module () -> CYT m (CS.Module ()) checkModuleId mid m@(CS.Module _ _ mid' _ _ _) | mid == mid' = ok m | otherwise = failMessages [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 spi ps 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 spi ps mid es (preludeImp : is) ds where noImpPrelude = NoImplicitPrelude `elem` optExtensions opts || m `CS.hasLanguageExtension` NoImplicitPrelude preludeImp = CS.ImportDecl NoSpanInfo preludeMIdent False -- qualified? Nothing -- no alias Nothing -- no selection of types, functions, etc. imported = [imp | (CS.ImportDecl _ imp _ _ _) <- is] checkInterfaces :: Monad m => Options -> InterfaceEnv -> CYT m () checkInterfaces opts iEnv = mapM_ checkInterface (Map.elems iEnv) where checkInterface intf = do let env = importInterfaces intf iEnv interfaceCheck opts (env, intf) importSyntaxCheck :: Monad m => InterfaceEnv -> CS.Module a -> CYT m [CS.ImportDecl] importSyntaxCheck iEnv (CS.Module _ _ _ _ imps _) = mapM checkImportDecl imps where checkImportDecl (CS.ImportDecl p m q asM is) = case Map.lookup m iEnv of Just intf -> CS.ImportDecl p m q asM `liftM` importCheck intf is Nothing -> internalError $ "Modules.importModules: no interface for " ++ show m -- --------------------------------------------------------------------------- -- Checking a module -- --------------------------------------------------------------------------- -- TODO: The order of the checks should be improved! checkModule :: Options -> CompEnv (CS.Module ()) -> CYIO (CompEnv (CS.Module PredType)) checkModule opts mdl = do _ <- dumpCS DumpParsed mdl exc <- extensionCheck opts mdl >>= dumpCS DumpExtensionChecked tsc <- typeSyntaxCheck opts exc >>= dumpCS DumpTypeSyntaxChecked kc <- kindCheck opts tsc >>= dumpCS DumpKindChecked sc <- syntaxCheck opts kc >>= dumpCS DumpSyntaxChecked pc <- precCheck opts sc >>= dumpCS DumpPrecChecked dc <- deriveCheck opts pc >>= dumpCS DumpDeriveChecked inc <- instanceCheck opts dc >>= dumpCS DumpInstanceChecked tc <- typeCheck opts inc >>= dumpCS DumpTypeChecked ec <- exportCheck opts tc >>= dumpCS DumpExportChecked return ec where dumpCS :: (MonadIO m, Show a) => DumpLevel -> CompEnv (CS.Module a) -> m (CompEnv (CS.Module a)) dumpCS = dumpWith opts CS.showModule CS.ppModule -- --------------------------------------------------------------------------- -- Translating a module -- --------------------------------------------------------------------------- transModule :: Options -> CompEnv (CS.Module PredType) -> CYIO (CompEnv IL.Module, CompEnv (CS.Module Type)) transModule opts mdl = do derived <- dumpCS DumpDerived $ derive mdl desugared <- dumpCS DumpDesugared $ desugar derived dicts <- dumpCS DumpDictionaries $ insertDicts desugared newtypes <- dumpCS DumpNewtypes $ removeNewtypes dicts simplified <- dumpCS DumpSimplified $ simplify newtypes lifted <- dumpCS DumpLifted $ lift simplified il <- dumpIL DumpTranslated $ ilTrans lifted ilCaseComp <- dumpIL DumpCaseCompleted $ completeCase il return (ilCaseComp, newtypes) where dumpCS :: Show a => DumpLevel -> CompEnv (CS.Module a) -> CYIO (CompEnv (CS.Module a)) dumpCS = dumpWith opts CS.showModule CS.ppModule dumpIL = dumpWith opts IL.showModule IL.ppModule -- --------------------------------------------------------------------------- -- 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. writeTokens :: Options -> CompilerEnv -> CYIO () writeTokens opts env = when tokTarget $ liftIO $ writeModule (useSubDir $ tokensName (filePath env)) (showTokenStream (tokens env)) where tokTarget = Tokens `elem` optTargetTypes opts useSubDir = addCurrySubdirModule (optUseSubdir opts) (moduleIdent env) writeComments :: Options -> CompilerEnv -> CYIO () writeComments opts env = when tokTarget $ liftIO $ writeModule (useSubDir $ commentsName (filePath env)) (showCommentTokenStream $ tokens env) where tokTarget = Comments `elem` optTargetTypes opts useSubDir = addCurrySubdirModule (optUseSubdir opts) (moduleIdent env) -- |Output the parsed 'Module' on request writeParsed :: Show a => Options -> CompEnv (CS.Module a) -> CYIO () writeParsed opts (env, mdl) = when srcTarget $ liftIO $ writeModule (useSubDir $ sourceRepName (filePath env)) (CS.showModule mdl) where srcTarget = Parsed `elem` optTargetTypes opts useSubDir = addCurrySubdirModule (optUseSubdir opts) (moduleIdent env) writeHtml :: Options -> CompEnv (CS.Module a) -> CYIO () writeHtml opts (env, mdl) = when htmlTarget $ source2html opts (moduleIdent env) (map (\(sp, tok) -> (span2Pos sp, tok)) (tokens env)) mdl where htmlTarget = Html `elem` optTargetTypes opts writeInterface :: Options -> CompilerEnv -> CS.Interface -> CYIO () writeInterface opts env intf@(CS.Interface m _ _) | optForce opts = outputInterface | otherwise = do equal <- liftIO $ C.catch (matchInterface interfaceFile intf) ignoreIOException unless equal outputInterface where ignoreIOException :: C.IOException -> IO Bool ignoreIOException _ = return False interfaceFile = interfName (filePath env) outputInterface = liftIO $ writeModule (addCurrySubdirModule (optUseSubdir opts) m interfaceFile) (show $ CS.ppInterface intf) matchInterface :: FilePath -> CS.Interface -> IO Bool matchInterface ifn i = do hdl <- openFile ifn ReadMode src <- hGetContents hdl case runCYMIgnWarn (CS.parseInterface ifn src) of Left _ -> hClose hdl >> return False Right i' -> return (i `intfEquiv` fixInterface i') writeFlat :: Options -> CompilerEnv -> CS.Module Type -> IL.Module -> CYIO () writeFlat opts env mdl il = do (_, tfc) <- dumpWith opts show (FC.ppProg . genFlatCurry) DumpTypedFlatCurry (env, tfcyProg) when tfcyTarget $ liftIO $ FC.writeFlatCurry (useSubDir tfcyName) tafcyProg when tafcyTarget $ liftIO $ FC.writeFlatCurry (useSubDir tafcyName) tfc when fcyTarget $ do (_, fc) <- dumpWith opts show FC.ppProg DumpFlatCurry (env, fcyProg) liftIO $ FC.writeFlatCurry (useSubDir fcyName) fc writeFlatIntf opts env fcyProg where tfcyName = typedFlatName (filePath env) tfcyProg = genTypedFlatCurry env mdl il tfcyTarget = TypedFlatCurry `elem` optTargetTypes opts tafcyName = typeAnnFlatName (filePath env) tafcyProg = genTypeAnnotatedFlatCurry env mdl il tafcyTarget = TypeAnnotatedFlatCurry `elem` optTargetTypes opts fcyName = flatName (filePath env) fcyProg = genFlatCurry tfcyProg fcyTarget = FlatCurry `elem` optTargetTypes opts useSubDir = addCurrySubdirModule (optUseSubdir opts) (moduleIdent env) writeFlatIntf :: Options -> CompilerEnv -> FC.Prog -> CYIO () writeFlatIntf opts env prog | not (optInterface opts) = return () | optForce opts = outputInterface | otherwise = do mfint <- liftIO $ FC.readFlatInterface targetFile let oldInterface = fromMaybe emptyIntf mfint when (mfint == mfint) $ return () -- necessary to close file -- TODO unless (oldInterface `eqInterface` fint) $ outputInterface where targetFile = flatIntName (filePath env) emptyIntf = FC.Prog "" [] [] [] [] fint = genFlatInterface prog useSubDir = addCurrySubdirModule (optUseSubdir opts) (moduleIdent env) outputInterface = liftIO $ FC.writeFlatCurry (useSubDir targetFile) fint writeAbstractCurry :: Options -> CompEnv (CS.Module PredType) -> CYIO () writeAbstractCurry opts (env, mdl) = do when acyTarget $ liftIO $ AC.writeCurry (useSubDir $ acyName (filePath env)) $ genTypedAbstractCurry env mdl when uacyTarget $ liftIO $ AC.writeCurry (useSubDir $ uacyName (filePath env)) $ genUntypedAbstractCurry env mdl where acyTarget = AbstractCurry `elem` optTargetTypes opts uacyTarget = UntypedAbstractCurry `elem` optTargetTypes opts useSubDir = addCurrySubdirModule (optUseSubdir opts) (moduleIdent env) writeAST :: Options -> CompEnv (CS.Module ()) -> CYIO () writeAST opts (env, mdl) = when astTarget $ liftIO $ writeModule (useSubDir $ astName (filePath env)) (CS.showModule mdl) where astTarget = AST `elem` optTargetTypes opts useSubDir = addCurrySubdirModule (optUseSubdir opts) (moduleIdent env) writeShortAST :: Options -> CompEnv (CS.Module ()) -> CYIO () writeShortAST opts (env, mdl) = when astTarget $ liftIO $ writeModule (useSubDir $ shortASTName (filePath env)) (CS.showModule $ shortenModuleAST mdl) where astTarget = ShortAST `elem` optTargetTypes opts useSubDir = addCurrySubdirModule (optUseSubdir opts) (moduleIdent env) type Dump = (DumpLevel, CompilerEnv, String) dumpWith :: MonadIO m => Options -> (a -> String) -> (a -> Doc) -> DumpLevel -> CompEnv a -> m (CompEnv a) dumpWith opts rawView view lvl res@(env, mdl) = do let str = if dbDumpRaw (optDebugOpts opts) then rawView mdl else show (view mdl) doDump (optDebugOpts opts) (lvl, env, str) return res -- |Translate FlatCurry into the intermediate language 'IL' -- |The 'dump' function writes the selected information to standard output. doDump :: MonadIO m => DebugOpts -> Dump -> m () doDump opts (level, env, dump) = when (level `elem` dbDumpLevels opts) $ liftIO $ do putStrLn (heading (capitalize $ lookupHeader dumpLevel) '=') when (dbDumpEnv opts) $ do putStrLn (heading "Environment" '-') putStrLn (showCompilerEnv env (dbDumpAllBindings opts) (dbDumpSimple opts)) putStrLn (heading "Source Code" '-') putStrLn dump where heading h s = '\n' : h ++ '\n' : replicate (length h) s lookupHeader [] = "Unknown dump level " ++ show level lookupHeader ((l,_,h):lhs) | level == l = h | otherwise = lookupHeader lhs capitalize = unwords . map firstUpper . words firstUpper "" = "" firstUpper (c:cs) = toUpper c : cs errModuleFileMismatch :: ModuleIdent -> Message errModuleFileMismatch mid = posMessage mid $ hsep $ map text [ "Module", moduleName mid, "must be in a file" , moduleName mid ++ ".(l)curry" ]