-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
--
-- CurryBuilder - Generates Curry representations for a Curry source file
-- including all imported modules.
--
-- September 2005,
-- Martin Engelke (men@informatik.uni-kiel.de)
-- March 2007, extensions by Sebastian Fischer (sebf@informatik.uni-kiel.de)
--
module CurryBuilder (buildCurry, smake) where
import System.Exit
import System.Time
import Control.Monad
import Data.Maybe
import Data.List
import System.IO
import Modules (compileModule_)
import CurryCompilerOpts
import CurryDeps
import Ident
import PathUtils
import Env
-------------------------------------------------------------------------------
-- Compiles the Curry program 'file' including all imported modules, depending
-- on the options 'options'. The compilation was successful, if the returned
-- list is empty, otherwise it contains error messages.
buildCurry :: Options -> FilePath -> IO ()
buildCurry options file
= do let paths = importPaths options
file' <- getCurryPath paths file
(cfile, errs1) <- return (maybe ("", [missingModule file])
(\f -> (f,[]))
file')
unless (null errs1) (abortWith errs1)
(deps, errs2) <- genDeps paths cfile
unless (null errs2) (abortWith errs2)
makeCurry options deps cfile
-------------------------------------------------------------------------------
makeCurry :: Options -> [(ModuleIdent,Source)] -> FilePath -> IO ()
makeCurry options deps file
= mapM compile (map snd deps) >> return ()
where
compile (Source file' mods)
| dropExtension file == dropExtension file'
= do
flatIntfExists <- doesModuleExist (flatIntName file')
if flatIntfExists && not (force options) && null (dump options)
then smake (targetNames file')
(file':(catMaybes (map flatInterface mods)))
(generateFile file')
(skipFile file')
else generateFile file'
| otherwise
= do
flatIntfExists <- doesModuleExist (flatIntName file')
if flatIntfExists
then smake [flatName file'] --[flatName file', flatIntName file']
(file':(catMaybes (map flatInterface mods)))
(compileFile file')
(skipFile file')
else compileFile file'
compile _ = return ()
compileFile file
= do unless (noVerb options) (putStrLn ("compiling " ++ file ++ " ..."))
compileCurry (compOpts True) file
return ()
skipFile file
= do unless (noVerb options)
(putStrLn ("skipping " ++ file ++ " ..."))
generateFile file
= do unless (noVerb options)
(putStrLn ("generating "
++ (head (targetNames file))
++ " ..."))
compileCurry (compOpts False) file
return ()
targetNames fn
| flat options = [flatName fn] -- , flatIntName fn]
| flatXml options = [xmlName fn]
| abstract options = [acyName fn]
| untypedAbstract options = [uacyName fn]
| parseOnly options = [maybe (sourceRepName fn) id (output options)]
| otherwise = [flatName fn] -- , flatIntName fn]
flatInterface mod
= case (lookup mod deps) of
Just (Source file _) -> Just (flatIntName (dropExtension file))
Just (Interface file) -> Just (flatIntName (dropExtension file))
_ -> Nothing
compOpts isImport
| isImport
= options
{ flat = True,
flatXml = False,
abstract = False,
untypedAbstract = False,
parseOnly = False,
dump = []
}
| otherwise = options
-------------------------------------------------------------------------------
-- Computes a dependency list for the Curry file 'file' (such a list
-- usualy starts with the prelude and ends with 'file'). The result
-- is a tuple containing an association list (type [(ModuleIdent,Source)];
-- see module "CurryDeps") and a list of error messages.
genDeps :: [FilePath] -> FilePath
-> IO ([(ModuleIdent,Source)], [String])
genDeps paths file
= fmap (flattenDeps . sortDeps) (deps paths [] emptyEnv file)
-------------------------------------------------------------------------------
-- A simple make function
-- smake <destination files>
-- <dependencies>
-- <io action, if dependencies are newer than destination files>
-- <io action, if destination files are newer than dependencies>
smake :: [FilePath] -> [FilePath] -> IO a -> IO a -> IO a
smake dests deps cmd alt
= do destTimes <- getDestTimes dests
depTimes <- getDepTimes deps
make destTimes depTimes
where
make destTimes depTimes
| (length destTimes) < (length dests)
= catch cmd (\err -> abortWith [show err])
| null depTimes
= abortWith ["unknown dependencies"]
| outOfDate destTimes depTimes
= catch cmd (\err -> abortWith [show err])
| otherwise
= alt
--
getDestTimes :: [FilePath] -> IO [ClockTime]
getDestTimes [] = return []
getDestTimes (file:files)
= catch (do time <- getModuleModTime file
times <- getDestTimes files
return (time:times))
(const (getDestTimes files))
--
getDepTimes :: [String] -> IO [ClockTime]
getDepTimes [] = return []
getDepTimes (file:files)
= catch (do time <- getModuleModTime file
times <- getDepTimes files
return (time:times))
(\err -> abortWith [show err])
--
outOfDate :: [ClockTime] -> [ClockTime] -> Bool
outOfDate tgtimes dptimes = or (map (\t -> or (map ((<) t) dptimes)) tgtimes)
compileCurry = compileModule_
-------------------------------------------------------------------------------
-- Error handling
-- Prints an error message on 'stderr'
putErrLn :: String -> IO ()
putErrLn = hPutStrLn stderr
-- Prints a list of error messages on 'stderr'
putErrsLn :: [String] -> IO ()
putErrsLn = mapM_ putErrLn
-- Prints a list of error messages on 'stderr' and aborts the program
abortWith :: [String] -> IO a
abortWith errs = putErrsLn errs >> exitWith (ExitFailure 1)
-- Error messages
missingModule :: FilePath -> String
missingModule file = "Error: missing module \"" ++ file ++ "\""
-------------------------------------------------------------------------------
-------------------------------------------------------------------------------