module Precis.ReportMonad
(
ReportM
, Log
, CMP(..)
, ChangeStats(..)
, ModuleParseFunction
, ReportLevel(..)
, runReportM
, execReportM
, askParseFun
, liftIO
, tellHtml
, tellParseFail
, incrRemovedModules
, incrRemovedExports
, incrChangedExports
, incrRemovedDatatypes
, incrChangedDatatypes
, incrRemovedTypeSigs
, incrChangedTypeSigs
, incrRemovedInstances
, incrChangedInstances
) where
import Precis.Datatypes
import Precis.Utils
import Language.Haskell.Exts ( Module )
import Text.XHtml hiding ( name )
import Control.Monad
type Log = ([Html],ChangeStats)
data CMP a = NEW a | OLD a
deriving (Eq,Show)
instance Functor CMP where
fmap f (NEW a) = NEW (f a)
fmap f (OLD a) = OLD (f a)
data ChangeStats = ChangeStats
{ unparseable_modules :: [CMP StrName]
, removed_modules :: Int
, removed_exports :: Int
, changed_exports :: Int
, removed_datatypes :: Int
, changed_datatypes :: Int
, removed_typesigs :: Int
, changed_typesigs :: Int
, removed_instances :: Int
, changed_instances :: Int
}
deriving (Show)
type ModuleParseFunction = SourceFile -> IO (Either ModuleParseError Module)
data ReportLevel = JUST_MSG | MSG_AND_HTML
deriving (Eq,Show)
type Env = (ModuleParseFunction, ReportLevel)
newtype ReportM a = ReportM { getReportM :: Env -> Log -> IO (a,Log) }
instance Functor ReportM where
fmap f (ReportM rf) = ReportM $ \e w ->
rf e w `bindIO` \(a,w') -> returnIO (f a,w')
returnIO :: a -> IO a
returnIO = return
bindIO :: IO a -> (a -> IO b) -> IO b
bindIO = (>>=)
instance Monad ReportM where
return a = ReportM $ \_ w -> returnIO (a,w)
ma >>= mf = ReportM $ \e w -> (getReportM ma e w) `bindIO` \(a,w') ->
(getReportM . mf) a e w'
log_zero :: Log
log_zero = ([],stats_zero)
where
stats_zero = ChangeStats [] 0 0 0 0 0 0 0 0 0
runReportM :: ModuleParseFunction -> ReportLevel -> ReportM a -> IO (a,Log)
runReportM pf lvl mf = (getReportM mf) (pf,lvl) log_zero `bindIO` post
where
post (a,(hs,stats)) = returnIO (a,(reverse hs,stats))
execReportM :: ModuleParseFunction -> ReportLevel -> ReportM a -> IO Log
execReportM pf lvl mf = liftM snd (runReportM pf lvl mf)
askParseFun :: ReportM ModuleParseFunction
askParseFun = ReportM $ \(pf,_) w -> returnIO (pf,w)
liftIO :: IO a -> ReportM a
liftIO mf = ReportM $ \_ w -> mf `bindIO` \a -> returnIO (a,w)
tellHtml :: Html -> ReportM ()
tellHtml h = ReportM $ \(_,lvl) (hs,stats) -> case lvl of
JUST_MSG -> returnIO ((),(hs,stats))
MSG_AND_HTML -> returnIO ((),(h:hs,stats))
updateStats :: (ChangeStats -> ChangeStats) -> ReportM ()
updateStats fn = ReportM $ \_ (hs,stats) -> returnIO ((),(hs, fn stats))
tellParseFail :: CMP StrName -> ReportM ()
tellParseFail name = updateStats $
pstar (\xs s -> s { unparseable_modules = name:xs}) unparseable_modules
incrRemovedModules :: ReportM ()
incrRemovedModules = updateStats $
pstar (\i s -> s { removed_modules = i+1}) removed_modules
incrRemovedExports :: ReportM ()
incrRemovedExports = updateStats $
pstar (\i s -> s { removed_exports = i+1}) removed_exports
incrChangedExports :: ReportM ()
incrChangedExports = updateStats $
pstar (\i s -> s { changed_exports = i+1}) changed_exports
incrRemovedDatatypes :: ReportM ()
incrRemovedDatatypes = updateStats $
pstar (\i s -> s { removed_datatypes = i+1}) removed_datatypes
incrChangedDatatypes :: ReportM ()
incrChangedDatatypes = updateStats $
pstar (\i s -> s { changed_datatypes = i+1}) changed_datatypes
incrRemovedTypeSigs :: ReportM ()
incrRemovedTypeSigs = updateStats $
pstar (\i s -> s { removed_typesigs = i+1}) removed_typesigs
incrChangedTypeSigs :: ReportM ()
incrChangedTypeSigs = updateStats $
pstar (\i s -> s { changed_typesigs = i+1}) changed_typesigs
incrRemovedInstances :: ReportM ()
incrRemovedInstances = updateStats $
pstar (\i s -> s { removed_instances = i+1}) removed_instances
incrChangedInstances :: ReportM ()
incrChangedInstances = updateStats $
pstar (\i s -> s { changed_instances = i+1}) changed_instances