Commit 8905d8f8 authored by Björn Peemöller 's avatar Björn Peemöller
Browse files

Refactoring of CurryBuilder

parent 5e2f31cf
......@@ -15,10 +15,10 @@
-}
module CurryBuilder (buildCurry, smake) where
import Control.Monad (liftM)
import Data.Maybe (catMaybes, mapMaybe)
import Control.Monad (liftM)
import Data.Maybe (catMaybes, mapMaybe)
import System.FilePath (normalise)
import System.Time (ClockTime)
import System.Time (ClockTime)
import Curry.Base.Ident
import Curry.Files.Filenames
......@@ -27,14 +27,14 @@ import Curry.Files.PathUtils
import Base.Messages (info, status, abortWith)
import CompilerOpts (Options (..), TargetType (..))
import CurryDeps (Source (..), flatDeps)
import Modules (compileModule)
import CurryDeps (Source (..), flatDeps)
import Modules (compileModule)
-- |Compile the Curry module in the given source file including all imported
-- modules, depending on the 'Options'.
buildCurry :: Options -> String -> IO ()
buildCurry opts str = do
target <- findCurry opts str
buildCurry opts s = do
target <- findCurry opts s
case target of
Left err -> abortWith [err]
Right fn -> do
......@@ -49,27 +49,27 @@ buildCurry opts str = do
-- |Search for a compilation target identified by the given 'String'.
findCurry :: Options -> String -> IO (Either String FilePath)
findCurry opts str = do
findCurry opts s = do
mbTarget <- findFile `orIfNotFound` findModule
case mbTarget of
Nothing -> return $ Left complaint
Just fn -> return $ Right fn
where
canBeFile = isCurryFilePath str
canBeModule = isValidModuleName str
moduleFile = moduleNameToFile $ fromModuleName str
canBeFile = isCurryFilePath s
canBeModule = isValidModuleName s
moduleFile = moduleNameToFile $ fromModuleName s
paths = optImportPaths opts
findFile = if canBeFile
then lookupCurryFile paths str
then lookupCurryFile paths s
else return Nothing
findModule = if canBeModule
then lookupCurryFile paths moduleFile
else return Nothing
complaint
| canBeFile && canBeModule = errMissingTarget str
| canBeFile = errMissingFile str
| canBeModule = errMissingModule str
| otherwise = errUnrecognized str
| canBeFile && canBeModule = errMissingTarget s
| canBeFile = errMissingFile s
| canBeModule = errMissingModule s
| otherwise = errUnrecognized s
first `orIfNotFound` second = do
mbFile <- first
case mbFile of
......@@ -78,36 +78,37 @@ findCurry opts str = do
-- |Compiles the given source modules, which must be in topological order
makeCurry :: Options -> [(ModuleIdent, Source)] -> FilePath -> IO ()
makeCurry opts srcs targetFile = mapM_ (compile . snd) srcs where
compile (Source fn deps) = do
interfaceExists <- doesModuleExist $ flatIntName fn
makeCurry opts srcs targetFile = mapM_ (process . snd) srcs
where
process (Source fn deps) = do
let isFinalFile = dropExtension targetFile == dropExtension fn
isEnforced = optForce opts || (not $ null $ optDumps opts)
destFiles = if isFinalFile then destNames fn else [flatName' fn]
destFiles = if isFinalFile then destNames fn else [getFlatName fn]
depFiles = fn : mapMaybe flatInterface deps
actOutdated = if isFinalFile then generateFile fn else compileFile fn
actUpToDate = if isFinalFile then skipFinalFile fn else skipFile fn
actOutdated = if isFinalFile then compileFinal else compile
actUpToDate = if isFinalFile then skipFinal else skip
interfaceExists <- doesModuleExist $ flatIntName fn
if interfaceExists && not (isEnforced && isFinalFile)
then smake destFiles depFiles actOutdated actUpToDate
else actOutdated
compile _ = return ()
then smake destFiles depFiles (actOutdated fn) (actUpToDate fn)
else (actOutdated fn)
process _ = return ()
compileFinal f = do
status opts $ "generating " ++ (normalise $ head $ destNames f)
compileModule opts f
compileFile f = do
compile f = do
status opts $ "compiling " ++ normalise f
compileModule (opts { optTargetTypes = [FlatCurry], optDumps = [] }) f
skipFinalFile f = status opts $ "skipping " ++ normalise f
skipFile f = info opts $ "skipping " ++ normalise f
generateFile f = do
status opts $ "generating " ++ (normalise $ head $ destNames f)
compileModule opts f
skipFinal f = status opts $ "skipping " ++ normalise f
skip f = info opts $ "skipping " ++ normalise f
destNames fn = [ gen fn | (tgt, gen) <- nameGens
, tgt `elem` optTargetTypes opts]
, tgt `elem` optTargetTypes opts]
where nameGens =
[ (FlatCurry , flatName )
, (ExtendedFlatCurry , extFlatName )
......@@ -115,7 +116,6 @@ makeCurry opts srcs targetFile = mapM_ (compile . snd) srcs where
, (AbstractCurry , acyName )
, (UntypedAbstractCurry , uacyName )
, (Parsed , sourceRepName)
, (FlatXml , xmlName )
]
flatInterface m = case lookup m srcs of
......@@ -123,8 +123,9 @@ makeCurry opts srcs targetFile = mapM_ (compile . snd) srcs where
Just (Interface fn) -> Just $ flatIntName fn
_ -> Nothing
extTarget = ExtendedFlatCurry `elem` optTargetTypes opts
flatName' = if extTarget then extFlatName else flatName
getFlatName = if ExtendedFlatCurry `elem` optTargetTypes opts
then extFlatName
else flatName
-- |A simple make function
smake :: [FilePath] -- ^ destination files
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment