Hi everyone,
I've been wanting to be able to override/redirect the outputs from Cabal and
Cabal-Install, so if I want to use cabal-install to build something via an
IDE I can display accurate feedback to the users. What I came up with is:
Ps. The mailclient is screwing with the indentation somewhat.
Regards,
Tamar
{-# LANGUAGE MultiParamTypeClasses #-}
-- This api is modelled after the GHC Api, The idea is to provide a way for
someone,
-- say IDE writers to wrap calls to cabal-install commands.
-- In particular control where feedback is returned.
{-
In order to catch all feedback every IO a in Cabal instead be Cabal a, and
at the start of it you'd have a runCabal.
A example of how the functions will become is
--
----------------------------------------------------------------------------
-
-- |Build the libraries and executables in this package.
build :: PackageDescription -- ^mostly information from the .cabal file
-> LocalBuildInfo -- ^Configuration information
-> BuildFlags -- ^Flags that the user passed to build
-> [ PPSuffixHandler ] -- ^preprocessors to run before compiling
-> IO ()
build pkg_descr lbi flags suffixes = do
let distPref = fromFlag (buildDistPref flags)
verbosity = fromFlag (buildVerbosity flags)
initialBuildSteps distPref pkg_descr lbi verbosity suffixes
setupMessage verbosity "Building" (packageId pkg_descr)
=========
build :: PackageDescription -- ^mostly information from the .cabal file
-> LocalBuildInfo -- ^Configuration information
-> BuildFlags -- ^Flags that the user passed to build
-> [ PPSuffixHandler ] -- ^preprocessors to run before compiling
-> Cabal ()
build pkg_descr lbi flags suffixes = do
let distPref = fromFlag (buildDistPref flags)
verbosity = fromFlag (buildVerbosity flags)
setVerbosity verbosity
initialBuildSteps distPref pkg_descr lbi suffixes
setupMessage "Building" (packageId pkg_descr)
----------
-}
module Distribution.Simple.Api
( -- * Types
CabalSession(..)
, Logger(..)
, Cabal()
, CabalMonad
-- * Utility functions
, getVerbosity
, setVerbosity
, setLoggers
, getLoggers
-- * Execution functions
, runCabal
, reflectCabal
)
where
-- * Imports
import Control.Monad.Trans
import Distribution.Verbosity as Verbosity
( Verbosity , normal )
import qualified Distribution.Simple.Utils as Utils
import Distribution.Text
( display )
import Distribution.Package
( PackageIdentifier )
import Data.IORef
import System.IO.Error
import System.FilePath ( normalise )
-- * Types
-- | A type synonym incase we ever want to change Message to something other
than string.
-- It also makes it clear that we are printing a Message for someone.
type Message = String
-- | A Session data type which is used to carry information from function
call to function call.
-- It currently only contains the verbosity level and the logger
functions, but more can be added if needed.
-- maintenance becomes easier since now to add extra information that is
accessable by every function all we
-- need to do is extend this datatype.
data CabalSession
= CabalSession { verbosity :: Verbosity
, loggers :: Logger
}
type Session = IORef CabalSession
-- | This data type holds the functions you should redirect in case you want
to do something other than just
-- print an error out, or if you want to change the formatting of the
feedback messages.
data Logger
= Logger { logger_dieWithLocation :: FilePath -> Maybe Int -> Message ->
IO ()
, logger_die :: Message -> IO ()
, logger_warn :: Verbosity -> Message -> IO ()
, logger_notice :: Verbosity -> Message -> IO ()
, logger_info :: Verbosity -> Message -> IO ()
, logger_debug :: Verbosity -> Message -> IO ()
}
-- | the Cabal Monad data type and a few of it's standard definitions
newtype Cabal a = Cabal { unCabal :: Session -> IO a }
instance Functor Cabal where
fmap f m = Cabal $ \s -> f `fmap` unCabal m s
instance Monad Cabal where
return a = Cabal $ \_ -> return a
m >>= g = Cabal $ \s -> unCabal m s >>= \a -> unCabal (g a) s
instance MonadIO Cabal where
liftIO a = Cabal $ \_ -> a
instance CabalMonad Cabal where
getSession = Cabal $ \s -> readIORef s
setSession s = Cabal $ \r -> writeIORef r s
-- End standard definitions
-- | The CabalMonad declaration which provides two standard functions for
manipulating it's state
class (Functor m, MonadIO m) => CabalMonad m where
getSession :: m CabalSession
setSession :: CabalSession -> m ()
-- | These are the feedback functions, which just wrap the functions in the
Logger data type
-- The names and types were mostly choosen to preserve existing
conventions. They also get
-- the current verbosity level and passes it along explicitly.
-- .
-- These are mostly wrappers around functions in Distribution.Simple.Utils
-- .
-- Note: The >> undefined is just so that the return type is fully
polymorphic. The
-- "die" loggers should always abort computation. So it should never
be reached
-- but I can't marshal the IOError type (atleast not easily) which
is why I just
-- require the loggers in Loggers to return a IO ()
dieWithLocation :: CabalMonad m => FilePath -> Maybe Int -> Message -> m a
dieWithLocation f i m = do l <- fetchLogger logger_dieWithLocation
liftIO $ l f i m >> undefined
die :: CabalMonad m => Message -> m a
die m = do l <- fetchLogger logger_die
liftIO $ l m >> undefined
warn :: CabalMonad m => Message -> m ()
warn = executeLogger logger_warn
notice :: CabalMonad m => Message -> m ()
notice = executeLogger logger_notice
info :: CabalMonad m => Message -> m ()
info = executeLogger logger_info
debug :: CabalMonad m => Message -> m ()
debug = executeLogger logger_debug
setupMessage :: CabalMonad m => Message -> PackageIdentifier -> m ()
setupMessage m pkg = notice (m ++ ' ': display pkg ++ "...")
-- | Execute a logger by first fetching it using /fetchLogger/ and then
calling it
-- with as parameters the current verbosity level and the given Message.
executeLogger :: (CabalMonad m) => (Logger -> Verbosity -> Message -> IO a)
-> Message -> m a
executeLogger f m = do l <- fetchLogger f
v <- getVerbosity
liftIO $ l v m
-- | Retreives a logger from the CabalSession and return it.
-- The argument to this function should be one of the record
-- labels of Loggers
fetchLogger :: (CabalMonad m) => (Logger -> c) -> m c
fetchLogger f = fmap (f . loggers) getSession
-- * Verbosity utility functions
getVerbosity :: CabalMonad m => m Verbosity
getVerbosity = fmap verbosity getSession
setVerbosity :: CabalMonad m => Verbosity -> m ()
setVerbosity v = fmap (\cfg -> (cfg{verbosity = v})) getSession >>=
setSession
-- * Loggers utility functions
setLoggers :: CabalMonad m => Logger -> m ()
setLoggers l = do session <- getSession
let newSession = session{loggers = l}
setSession newSession
getLoggers :: CabalMonad m => m Logger
getLoggers = fmap loggers getSession
-- | A standard set of default loggers.
defaultLoggers :: Logger
defaultLoggers =
Logger { logger_dieWithLocation = Utils.dieWithLocation
, logger_die = Utils.die
, logger_warn = Utils.warn
, logger_notice = Utils.notice
, logger_info = Utils.info
, logger_debug = Utils.debug
}
-- | A standard verbosity level
defaultVerbosity :: Verbosity
defaultVerbosity = normal
-- | Create a default session using the default loggers and default
verbosity
defaultSession :: CabalSession
defaultSession =
CabalSession { verbosity = defaultVerbosity
, loggers = defaultLoggers
}
-- | A way to run a Cabal monad
runCabal :: Cabal a -> IO a
runCabal = flip reflectCabal defaultSession
-- | Reflect a Cabal monad using a given CabalSession
reflectCabal :: Cabal a -> CabalSession -> IO a
reflectCabal c s = unCabal c =<< newIORef s
_______________________________________________
cabal-devel mailing list
cabal-devel@haskell.org
http://www.haskell.org/mailman/listinfo/cabal-devel
