possible cabal monad

23 Nov 2010

      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

possible cabal monad

Phyx