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

Merge branch 'master' into curry-interface

Conflicts:
	src/Checks.hs
	src/CurryBuilder.hs
	src/Exports.hs
	src/Interfaces.hs
	src/Modules.hs
parents 2f0327c4 6d150d52
......@@ -36,7 +36,7 @@ Executable cymake
Build-Depends: base == 3.*
Build-Depends:
curry-base == 0.3.8
, containers, either, mtl, pretty, transformers
, containers, either, mtl, transformers
ghc-options: -Wall
Other-Modules:
Base.CurryTypes
......
......@@ -6,9 +6,12 @@ module Base.Messages
, internalError, errorMessage, errorMessages
-- * creating messages
, Message, message, posMessage
, MonadIO (..), CYIO, CYT, left, right, runEitherCYIO
) where
import Control.Monad (unless, when)
import Control.Monad.IO.Class
import Control.Monad.Trans.Either
import Data.List (sort)
import System.IO (hPutStrLn, stderr)
import System.Exit (exitFailure)
......@@ -16,33 +19,46 @@ import System.Exit (exitFailure)
import Curry.Base.Message hiding (warn)
import CompilerOpts (Options (..), Verbosity (..))
info :: Options -> String -> IO ()
info opts msg = unless (optVerbosity opts < VerbInfo)
(putStrLn $ msg ++ " ...")
type CYT m a = EitherT [Message] m a
status :: Options -> String -> IO ()
status opts msg = unless (optVerbosity opts < VerbStatus)
(putStrLn $ msg ++ " ...")
type CYIO a = EitherT [Message] IO a
warn :: Options -> [Message] -> IO ()
runEitherCYIO :: CYIO a -> IO a
runEitherCYIO act = do
res <- runEitherT act
case res of
Left errs -> abortWithMessages errs
Right val -> return val
info :: MonadIO m => Options -> String -> m ()
info opts msg = unless (optVerbosity opts < VerbInfo) (putMsg msg)
status :: MonadIO m => Options -> String -> m ()
status opts msg = unless (optVerbosity opts < VerbStatus) (putMsg msg)
warn :: MonadIO m => Options -> [Message] -> m ()
warn opts msgs = when (optWarn opts && not (null msgs)) $ do
putErrLn (show $ ppMessages ppWarning $ sort msgs)
when (optWarnAsError opts) $ do
liftIO $ putErrLn (show $ ppMessages ppWarning $ sort msgs)
when (optWarnAsError opts) $ liftIO $ do
putErrLn "Failed due to -Werror"
exitFailure
-- |Print a message on 'stdout'
putMsg :: MonadIO m => String -> m ()
putMsg msg = liftIO $ putStrLn $ msg ++ " ..."
-- |Print an error message on 'stderr'
putErrLn :: String -> IO ()
putErrLn = hPutStrLn stderr
putErrLn :: MonadIO m => String -> m ()
putErrLn = liftIO . hPutStrLn stderr
-- |Print a list of error messages on 'stderr'
putErrsLn :: [String] -> IO ()
putErrsLn :: MonadIO m => [String] -> m ()
putErrsLn = mapM_ putErrLn
-- |Print a list of 'String's as error messages on 'stderr'
-- and abort the program
abortWith :: [String] -> IO a
abortWith errs = unless (null errs) (putErrsLn errs) >> exitFailure
abortWith errs = putErrsLn errs >> exitFailure
-- |Print a single error message on 'stderr' and abort the program
abortWithMessage :: Message -> IO a
......
{- |
Module : $Header$
Description : Different checks on a Curry module
Copyright : (c) 2011, Björn Peemöller (bjp@informatik.uni-kiel.de)
Copyright : (c) 2011 - 2013, Björn Peemöller
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
......@@ -13,11 +13,6 @@
-}
module Checks where
import Control.Monad.Trans.Either
import Curry.Syntax (Module (..), Interface (..))
import Base.Messages
import qualified Checks.InterfaceCheck as IC (interfaceCheck)
import qualified Checks.ExportCheck as EC (exportCheck)
import qualified Checks.KindCheck as KC (kindCheck)
......@@ -26,17 +21,19 @@ import qualified Checks.SyntaxCheck as SC (syntaxCheck)
import qualified Checks.TypeCheck as TC (typeCheck)
import qualified Checks.WarnCheck as WC (warnCheck)
import Curry.Syntax (Module (..), Interface (..))
import Base.Messages
import CompilerEnv
import CompilerOpts
type Check m = Options -> CompilerEnv -> Module
-> EitherT [Message] m (CompilerEnv, Module)
type Check m a = Options -> CompilerEnv -> a -> CYT m (CompilerEnv, a)
interfaceCheck :: CompilerEnv -> Interface -> CheckResult ()
interfaceCheck env intf
| null errs = return ()
| otherwise = CheckFailed errs
where errs = IC.interfaceCheck (opPrecEnv env) (tyConsEnv env)
interfaceCheck :: Monad m => Check m Interface
interfaceCheck _ env intf
| null msgs = right (env, intf)
| otherwise = left msgs
where msgs = IC.interfaceCheck (opPrecEnv env) (tyConsEnv env)
(valueEnv env) intf
-- |Check the kinds of type definitions and signatures.
......@@ -44,7 +41,7 @@ interfaceCheck env intf
-- * Declarations: Nullary type constructors and type variables are
-- disambiguated
-- * Environment: remains unchanged
kindCheck :: Monad m => Check m
kindCheck :: Monad m => Check m Module
kindCheck _ env (Module m es is ds)
| null msgs = right (env, Module m es is ds')
| otherwise = left msgs
......@@ -55,7 +52,7 @@ kindCheck _ env (Module m es is ds)
-- * Declarations: Nullary data constructors and variables are
-- disambiguated, variables are renamed
-- * Environment: remains unchanged
syntaxCheck :: Monad m => Check m
syntaxCheck :: Monad m => Check m Module
syntaxCheck opts env (Module m es is ds)
| null msgs = right (env, Module m es is ds')
| otherwise = left msgs
......@@ -67,7 +64,7 @@ syntaxCheck opts env (Module m es is ds)
-- * Declarations: Expressions are reordered according to the specified
-- precedences
-- * Environment: The operator precedence environment is updated
precCheck :: Monad m => Check m
precCheck :: Monad m => Check m Module
precCheck _ env (Module m es is ds)
| null msgs = right (env { opPrecEnv = pEnv' }, Module m es is ds')
| otherwise = left msgs
......@@ -76,7 +73,7 @@ precCheck _ env (Module m es is ds)
-- |Apply the correct typing of the module.
-- The declarations remain unchanged; the type constructor and value
-- environments are updated.
typeCheck :: Monad m => Check m
typeCheck :: Monad m => Check m Module
typeCheck _ env mdl@(Module _ _ _ ds)
| null msgs = right (env { tyConsEnv = tcEnv', valueEnv = tyEnv' }, mdl)
| otherwise = left msgs
......@@ -84,7 +81,7 @@ typeCheck _ env mdl@(Module _ _ _ ds)
(tyConsEnv env) (valueEnv env) ds
-- |Check the export specification
exportCheck :: Monad m => Check m
exportCheck :: Monad m => Check m Module
exportCheck _ env (Module m es is ds)
| null msgs = right (env, Module m es' is ds)
| otherwise = left msgs
......
module Checks.ExportCheck (exportCheck) where
import Control.Monad (liftM, unless)
import qualified Control.Monad.State as S (State, runState, gets, modify)
import Data.List (nub, union)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import qualified Data.Set as Set
import Text.PrettyPrint
import Control.Monad (liftM, unless)
import qualified Control.Monad.State as S (State, runState, gets, modify)
import Data.List (nub, union)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import qualified Data.Set as Set
import Curry.Base.Ident
import Curry.Base.Position
import Curry.Base.Pretty
import Curry.Syntax
import Base.Messages (Message, internalError, posMessage)
......
......@@ -47,13 +47,13 @@ interface module only. However, this has not been implemented yet.
> module Checks.InterfaceCheck (interfaceCheck) where
> import Control.Monad (unless)
> import Control.Monad (unless)
> import qualified Control.Monad.State as S
> import Data.Maybe (catMaybes, fromMaybe)
> import Text.PrettyPrint
> import Data.Maybe (catMaybes, fromMaybe)
> import Curry.Base.Ident
> import Curry.Base.Position
> import Curry.Base.Pretty
> import Curry.Syntax
> import Base.CurryTypes
......
......@@ -20,19 +20,19 @@ the global environments.
> module Checks.InterfaceSyntaxCheck (intfSyntaxCheck) where
> import Control.Monad (liftM, liftM2)
> import Control.Monad (liftM, liftM2)
> import qualified Control.Monad.State as S
> import Data.List (nub, partition)
> import Data.Maybe (catMaybes)
> import Text.PrettyPrint
> import Data.List (nub, partition)
> import Data.Maybe (catMaybes)
> import Base.Expr
> import Base.Messages (Message, posMessage, internalError)
> import Base.TopEnv
> import Base.Utils (findMultiples)
> import Base.Utils (findMultiples)
> import Env.TypeConstructor
> import Curry.Base.Ident
> import Curry.Base.Pretty
> import Curry.Syntax
import Base
......
......@@ -25,12 +25,12 @@ is defined more than once.
> module Checks.KindCheck (kindCheck) where
> import Control.Monad (forM, liftM, liftM2, liftM3, unless, when)
> import Control.Monad (forM, liftM, liftM2, liftM3, unless, when)
> import qualified Control.Monad.State as S (State, runState, gets, modify)
> import Text.PrettyPrint
> import Curry.Base.Ident
> import Curry.Base.Position
> import Curry.Base.Pretty
> import Curry.Syntax
> import Base.Messages (Message, posMessage, internalError)
......
......@@ -18,13 +18,13 @@ of the operators involved.
> module Checks.PrecCheck (precCheck) where
> import Control.Monad (liftM, liftM2, liftM3, unless, when)
> import Control.Monad (liftM, liftM2, liftM3, unless, when)
> import qualified Control.Monad.State as S (State, runState, gets, modify)
> import Data.List (partition)
> import Text.PrettyPrint
> import Data.List (partition)
> import Curry.Base.Ident
> import Curry.Base.Position
> import Curry.Base.Pretty
> import Curry.Syntax
> import Base.Expr
......
......@@ -27,10 +27,10 @@ definition.
> import Data.List ((\\), insertBy, nub, partition)
> import Data.Maybe (fromJust, isJust, isNothing, maybeToList)
> import qualified Data.Set as Set (empty, insert, member)
> import Text.PrettyPrint
> import Curry.Base.Ident
> import Curry.Base.Position
> import Curry.Base.Pretty
> import Curry.Syntax
> import Curry.Syntax.Pretty (ppPattern)
......
......@@ -21,10 +21,10 @@ import qualified Data.Map as Map (empty, insert, lookup)
import Data.Maybe (catMaybes, isJust)
import Data.List
(intersect, intersectBy, nub, partition, sort, unionBy)
import Text.PrettyPrint
import Curry.Base.Ident
import Curry.Base.Position
import Curry.Base.Pretty
import Curry.Syntax
import Curry.Syntax.Pretty (ppPattern, ppExpr, ppIdent)
......
......@@ -14,9 +14,9 @@
module CompilerEnv where
import qualified Data.Map as Map (Map, keys, toList)
import Text.PrettyPrint
import Curry.Base.Ident (ModuleIdent)
import Curry.Base.Ident (ModuleIdent)
import Curry.Base.Pretty
import Base.TopEnv (allLocalBindings)
......
{- |
Module : $Header$
Description : Build tool for compiling multiple Curry modules
Copyright : (c) 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)
Copyright : (c) 2005 Martin Engelke
2007 Sebastian Fischer
2011 - 2013 Björn Peemöller
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
......@@ -18,14 +18,13 @@ module CurryBuilder (buildCurry, smake) where
import Control.Monad (liftM)
import Data.Maybe (catMaybes, mapMaybe)
import System.FilePath (normalise)
import Text.PrettyPrint
import Curry.Base.Ident
import Curry.Base.Pretty
import Curry.Files.Filenames
import Curry.Files.PathUtils
import Base.Messages
(info, status, Message, message, abortWithMessage, abortWithMessages)
import CompilerOpts (Options (..), TargetType (..))
import CurryDeps (Source (..), flatDeps)
......@@ -33,38 +32,33 @@ 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 :: Options -> String -> CYIO ()
buildCurry opts s = do
target <- findCurry opts s
case target of
Left err -> abortWithMessage err
Right fn -> do
(srcs, depErrs) <- flatDeps opts fn
if not $ null depErrs
then abortWithMessages depErrs
else makeCurry (defaultToFlatCurry opts) srcs fn
where
defaultToFlatCurry opt
| null $ optTargetTypes opt = opt { optTargetTypes = [FlatCurry] }
| otherwise = opt
fn <- findCurry opts s
srcs <- flatDeps opts fn
makeCurry (defaultToFlatCurry opts) srcs fn
where
defaultToFlatCurry opt
| null $ optTargetTypes opt = opt { optTargetTypes = [FlatCurry] }
| otherwise = opt
-- |Search for a compilation target identified by the given 'String'.
findCurry :: Options -> String -> IO (Either Message FilePath)
findCurry :: Options -> String -> CYIO FilePath
findCurry opts s = do
mbTarget <- findFile `orIfNotFound` findModule
case mbTarget of
Nothing -> return $ Left complaint
Just fn -> return $ Right fn
Nothing -> left [complaint]
Just fn -> right fn
where
canBeFile = isCurryFilePath s
canBeModule = isValidModuleName s
moduleFile = moduleNameToFile $ fromModuleName s
paths = optImportPaths opts
findFile = if canBeFile
then lookupCurryFile paths s
then liftIO $ lookupCurryFile paths s
else return Nothing
findModule = if canBeModule
then lookupCurryFile paths moduleFile
then liftIO $ lookupCurryFile paths moduleFile
else return Nothing
complaint
| canBeFile && canBeModule = errMissing "target" s
......@@ -78,9 +72,10 @@ findCurry opts s = do
justFn -> return justFn
-- |Compiles the given source modules, which must be in topological order
makeCurry :: Options -> [(ModuleIdent, Source)] -> FilePath -> IO ()
makeCurry :: Options -> [(ModuleIdent, Source)] -> FilePath -> CYIO ()
makeCurry opts srcs targetFile = mapM_ (process . snd) srcs
where
process :: Source -> CYIO ()
process (Source fn deps) = do
let isFinalFile = dropExtension targetFile == dropExtension fn
isEnforced = optForce opts || (not $ null $ optDumps opts)
......@@ -91,7 +86,7 @@ makeCurry opts srcs targetFile = mapM_ (process . snd) srcs
actOutdated = if isFinalFile then compileFinal else compile
actUpToDate = if isFinalFile then skipFinal else skip
interfaceExists <- doesModuleExist $ interfName fn
interfaceExists <- liftIO $ doesModuleExist $ flatIntName fn
if interfaceExists && not (isEnforced && isFinalFile)
then smake destFiles depFiles (actOutdated fn) (actUpToDate fn)
else actOutdated fn
......@@ -131,12 +126,12 @@ makeCurry opts srcs targetFile = mapM_ (process . snd) srcs
-- |A simple make function
smake :: [FilePath] -- ^ destination files
-> [FilePath] -- ^ dependency files
-> IO a -- ^ action to perform if depedency files are newer
-> IO a -- ^ action to perform if destination files are newer
-> IO a
-> CYIO a -- ^ action to perform if depedency files are newer
-> CYIO a -- ^ action to perform if destination files are newer
-> CYIO a
smake dests deps actOutdated actUpToDate = do
destTimes <- catMaybes `liftM` mapM getModuleModTime dests
depTimes <- mapM (abortOnMissing getModuleModTime) deps
destTimes <- catMaybes `liftM` mapM (liftIO . getModuleModTime) dests
depTimes <- mapM (cancelMissing getModuleModTime) deps
make destTimes depTimes
where
make destTimes depTimes
......@@ -146,10 +141,10 @@ smake dests deps actOutdated actUpToDate = do
outOfDate tgtimes dptimes = or [ tg < dp | tg <- tgtimes, dp <- dptimes]
abortOnMissing :: (FilePath -> IO (Maybe a)) -> FilePath -> IO a
abortOnMissing act f = act f >>= \res -> case res of
Nothing -> abortWithMessage $ errModificationTime f
Just val -> return val
cancelMissing :: (FilePath -> IO (Maybe a)) -> FilePath -> CYIO a
cancelMissing act f = liftIO (act f) >>= \res -> case res of
Nothing -> left [errModificationTime f]
Just val -> right val
errMissing :: String -> String -> Message
errMissing what which = message $ sep $ map text
......
......@@ -4,7 +4,7 @@
Copyright : (c) 2002 - 2004 Wolfgang Lux
2005 Martin Engelke
2007 Sebastian Fischer
2011 - 2012 Björn Peemöller
2011 - 2013 Björn Peemöller
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
......@@ -16,26 +16,22 @@
dependencies and to update programs composed of multiple modules.
-}
-- TODO (bjp): Propagate errors
-- Currently errors during the dependency search (like missing files
-- or errors during parsing a module header) lead to calls of the error
-- function. This dramatically limits the usability as a library.
module CurryDeps
( Source (..), flatDeps, deps, flattenDeps, sourceDeps, moduleDeps ) where
import Control.Monad (foldM, liftM, unless)
import Data.List (isSuffixOf, nub)
import Control.Monad (foldM)
import Data.List (isSuffixOf, nub)
import qualified Data.Map as Map (Map, empty, insert, lookup, toList)
import Text.PrettyPrint
import Curry.Base.Ident
import Curry.Base.Message (runMsg, Message, message)
import Curry.Base.Message (runMsg)
import Curry.Base.Pretty
import Curry.Files.Filenames
import Curry.Files.PathUtils
import Curry.Syntax (Module (..), ImportDecl (..), parseHeader, patchModuleId)
import Curry.Syntax
(Module (..), ImportDecl (..), parseHeader, patchModuleId)
import Base.Messages (abortWithMessage, internalError)
import Base.Messages
import Base.SCC (scc)
import CompilerOpts (Options (..), Extension (..))
......@@ -50,11 +46,15 @@ type SourceEnv = Map.Map ModuleIdent Source
-- |Retrieve the dependencies of a source file in topological order
-- and possible errors during flattering
flatDeps :: Options -> FilePath -> IO ([(ModuleIdent, Source)], [Message])
flatDeps opts fn = flattenDeps `liftM` deps opts Map.empty fn
flatDeps :: Options -> FilePath -> CYIO [(ModuleIdent, Source)]
flatDeps opts fn = do
sEnv <- deps opts Map.empty fn
case flattenDeps sEnv of
(env, [] ) -> right env
(_ , errs) -> left errs
-- |Retrieve the dependencies of a source file as a 'SourceEnv'
deps :: Options -> SourceEnv -> FilePath -> IO SourceEnv
deps :: Options -> SourceEnv -> FilePath -> CYIO SourceEnv
deps opts sEnv fn
| ext == icurryExt = return sEnv
| ext `elem` sourceExts = sourceDeps opts sEnv fn
......@@ -77,19 +77,19 @@ deps opts sEnv fn
-- prelude itself.
-- |Retrieve the dependencies of a given target file
targetDeps :: Options -> SourceEnv -> FilePath -> IO SourceEnv
targetDeps :: Options -> SourceEnv -> FilePath -> CYIO SourceEnv
targetDeps opts sEnv fn = do
mFile <- lookupFile [""] sourceExts fn
mFile <- liftIO $ lookupFile [""] sourceExts fn
case mFile of
Nothing -> return $ Map.insert (mkMIdent [fn]) Unknown sEnv
Just file -> sourceDeps opts sEnv file
-- |Retrieve the dependencies of a given source file
sourceDeps :: Options -> SourceEnv -> FilePath -> IO SourceEnv
sourceDeps :: Options -> SourceEnv -> FilePath -> CYIO SourceEnv
sourceDeps opts sEnv fn = readHeader fn >>= moduleDeps opts sEnv fn
-- |Retrieve the dependencies of a given module
moduleDeps :: Options -> SourceEnv -> FilePath -> Module -> IO SourceEnv
moduleDeps :: Options -> SourceEnv -> FilePath -> Module -> CYIO SourceEnv
moduleDeps opts sEnv fn (Module m _ is _) = case Map.lookup m sEnv of
Just _ -> return sEnv
Nothing -> do
......@@ -106,11 +106,12 @@ imports opts m ds = nub $
where implicitPrelude = NoImplicitPrelude `notElem` optExtensions opts
-- |Retrieve the dependencies for a given 'ModuleIdent'
moduleIdentDeps :: Options -> SourceEnv -> ModuleIdent -> IO SourceEnv
moduleIdentDeps :: Options -> SourceEnv -> ModuleIdent -> CYIO SourceEnv
moduleIdentDeps opts sEnv m = case Map.lookup m sEnv of
Just _ -> return sEnv
Nothing -> do
mFile <- lookupCurryModule (optImportPaths opts) (optLibraryPaths opts) m
mFile <- liftIO $ lookupCurryModule (optImportPaths opts)
(optLibraryPaths opts) m
case mFile of
Nothing -> return $ Map.insert m Unknown sEnv
Just fn
......@@ -118,17 +119,17 @@ moduleIdentDeps opts sEnv m = case Map.lookup m sEnv of
return $ Map.insert m (Interface fn) sEnv
| otherwise -> do
hdr@(Module m' _ _ _) <- readHeader fn
unless (m == m') $ abortWithMessage $ errWrongModule m m'
moduleDeps opts sEnv fn hdr
if (m == m') then moduleDeps opts sEnv fn hdr
else left [errWrongModule m m']
readHeader :: FilePath -> IO Module
readHeader :: FilePath -> CYIO Module
readHeader fn = do
mbFile <- readModule fn
mbFile <- liftIO $ readModule fn
case mbFile of
Nothing -> abortWithMessage $ errMissingFile fn
Nothing -> left [errMissingFile fn]
Just src -> do
case runMsg $ parseHeader fn src of
Left err -> abortWithMessage err
Left err -> left [err]
Right (hdr, _) -> return $ patchModuleId fn hdr
-- If we want to compile the program instead of generating Makefile
......
......@@ -27,10 +27,9 @@ module Env.Value
, initDCEnv, ppTypes
) where
import Text.PrettyPrint (Doc, vcat)
import Curry.Base.Ident
import Curry.Base.Position
import Curry.Base.Pretty (Doc, vcat)
import Curry.Syntax
import Base.CurryTypes (fromQualType)
......
......@@ -17,8 +17,8 @@
-}
module Exports (exportInterface) where
import Data.Maybe (isNothing, catMaybes)
import qualified Data.Set as Set (delete, fromList, toList)
import Data.Maybe (isNothing, catMaybes)
import qualified Data.Set as Set (delete, fromList, toList)
import Curry.Base.Position
import Curry.Base.Ident
......
......@@ -37,10 +37,11 @@ import Modules (checkModule, checkModuleHeader, compileModule, loadModule)
parse :: FilePath -> String -> MessageM Module
parse fn src = parseModule fn src >>= genCurrySyntax
where
genCurrySyntax mod1
| null hdrErrs = return mdl
| otherwise = failWith $ show $ head hdrErrs
where (mdl, hdrErrs) = checkModuleHeader defaultOptions fn mod1
genCurrySyntax mod1 = do
checked <- lift $ runEitherT $ checkModuleHeader defaultOptions fn mod1
case checked of
Left hdrErrs -> failWith $ show $ head hdrErrs
Right mdl -> return mdl
{- |Return the syntax tree of the source program 'src' (type 'Module'; see
Module "CurrySyntax").after inferring the types of identifiers.
......@@ -59,8 +60,7 @@ genFullCurrySyntax opts fn m = case runMsg m of
errs <- liftIO $ makeInterfaces opts fn mod1