{- | 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 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 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 writeAST opts (fst mdl, fmap (const ()) (snd mdl)) writeShortAST opts (fst qmdl, fmap (const ()) (snd qmdl)) mdl' <- expandExports opts mdl qmdl' <- dumpWith opts CS.showModule pPrint 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) [ AnnotatedFlatCurry , 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 (addOutDir (optUseOutDir opts) (optOutDir opts)) ("." : optImportPaths opts) let withPrel = importPrelude opts mdl iEnv <- loadInterfaces paths withPrel checkInterfaces opts iEnv is <- importSyntaxCheck iEnv withPrel -- add information of imported modules cEnv <- importModules withPrel 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 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 => ModuleIdent -> FilePath -> CS.Module () -> CYT m (CS.Module ()) checkModuleHeader m fn = checkModuleId m . 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 temporariliy 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 li ps mid es is ds) -- the Prelude itself | mid == preludeMIdent = m -- disabled by compiler option | noImpPrelude = m -- already imported | preludeMIdent `elem` imports = m -- let's add it! | otherwise = CS.Module spi li 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. imports = [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 pPrint -- --------------------------------------------------------------------------- -- 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 inlDi desugared newtypes <- dumpCS DumpNewtypes $ removeNewtypes remNT dicts simplified <- dumpCS DumpSimplified $ simplify newtypes lifted <- dumpCS DumpLifted $ lift simplified il <- dumpIL DumpTranslated $ ilTrans remIm lifted ilCaseComp <- dumpIL DumpCaseCompleted $ completeCase il return (ilCaseComp, newtypes) where optOpts = optOptimizations opts inlDi = optInlineDictionaries optOpts remIm = optRemoveUnusedImports optOpts remNT = optDesugarNewtypes optOpts dumpCS :: Show a => DumpLevel -> CompEnv (CS.Module a) -> CYIO (CompEnv (CS.Module a)) dumpCS = dumpWith opts CS.showModule pPrint 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 = addOutDirModule (optUseOutDir opts) (optOutDir 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 = addOutDirModule (optUseOutDir opts) (optOutDir 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 = addOutDirModule (optUseOutDir opts) (optOutDir 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 (addOutDirModule (optUseOutDir opts) (optOutDir opts) m interfaceFile) (show $ pPrint 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 _ <- dumpWith opts show (pPrint . genFlatCurry) DumpTypedFlatCurry (env, afcy) when afcyTarget $ liftIO $ FC.writeFlatCurry (useSubDir afcyName) afcy when tfcyTarget $ liftIO $ FC.writeFlatCurry (useSubDir tfcyName) tfcy when fcyTarget $ do _ <- dumpWith opts show pPrint DumpFlatCurry (env, fcy) liftIO $ FC.writeFlatCurry (useSubDir fcyName) fcy writeFlatIntf opts env fcy where afcy = genAnnotatedFlatCurry env mdl il afcyName = annotatedFlatName (filePath env) afcyTarget = AnnotatedFlatCurry `elem` optTargetTypes opts tfcy = genTypedFlatCurry afcy tfcyName = typedFlatName (filePath env) tfcyTarget = TypedFlatCurry `elem` optTargetTypes opts fcy = genFlatCurry afcy fcyName = flatName (filePath env) fcyTarget = FlatCurry `elem` optTargetTypes opts useSubDir = addOutDirModule (optUseOutDir opts) (optOutDir 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 = addOutDirModule (optUseOutDir opts) (optOutDir 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 = addOutDirModule (optUseOutDir opts) (optOutDir 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 = addOutDirModule (optUseOutDir opts) (optOutDir 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 = addOutDirModule (optUseOutDir opts) (optOutDir 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" ]