Base.hs

module Language.Java.Paragon.Monad.Base 
    (
     ErrCtxt, BaseM, runBaseM, runBaseErr,

     MonadIO(..), MonadBase(..), 
     liftEither, liftShowEither, tryCatch,

     getFreshInt, getErrCtxt, withErrCtxt,

     check, checkM, ignore, orElse, orM, anyM,
     maybeM, withFold, withFoldMap

    ) where

import Language.Java.Paragon.Monad.Uniq

import Control.Monad
import Control.Applicative

import System.Exit

type ErrCtxt = String -> String

newtype BaseM a = BaseM (ErrCtxt -> Uniq -> IO (Either String a))

instance Monad BaseM where
  return x = BaseM $ \_ _ -> return $ Right x

  BaseM f >>= k = 
      BaseM $ \ec u -> 
          do esa <- f ec u
             case esa of
               Left err -> return $ Left err
               Right a ->
                 let BaseM g = k a
                  in g ec u

  fail err = BaseM $ \ec _ -> return . Left $ ec err

runBaseM :: BaseM a -> IO (Either String a)
runBaseM (BaseM f) = do
  initU <- initUniq
  f id initU

runBaseErr :: BaseM a -> IO a
runBaseErr bma = do
  esa <- runBaseM bma
  case esa of
    Left err -> do
             putStrLn $ "\n\n" ++ err
             exitWith $ ExitFailure (-1)
    Right a -> return a

instance Functor BaseM where
  fmap = liftM

getUniqRef :: MonadBase m => m Uniq
getUniqRef = liftBase $ BaseM $ \_ u -> return $ Right u

getFreshInt :: MonadBase m => m Int
getFreshInt = do
  u <- getUniqRef
  liftIO $ getUniq u

getErrCtxt :: MonadBase m => m ErrCtxt
getErrCtxt = liftBase $ BaseM $ \ec _ -> return $ Right ec


class Monad m => MonadIO m where
  liftIO :: IO a -> m a

instance MonadIO IO where
  liftIO = id

instance MonadIO BaseM where
  liftIO ioa = BaseM $ \_ _ -> Right <$> ioa

class MonadIO m => MonadBase m where
  liftBase :: BaseM a -> m a
  withErrCtxt' :: (ErrCtxt -> ErrCtxt) -> m a -> m a
  tryM :: m a -> m (Either String a)

instance MonadBase BaseM where
  liftBase = id
  withErrCtxt' strff (BaseM f) = BaseM $ \ec u -> f (strff ec) u
  tryM (BaseM f) = BaseM $ \ec u -> do
                           esa <- f ec u
                           return $ Right esa


withErrCtxt :: MonadBase m => String -> m a -> m a
withErrCtxt str = withErrCtxt' (. (str ++))

tryCatch :: MonadBase m => m a -> (String -> m a) -> m a
tryCatch tr ctch = do esa <- tryM tr
                      case esa of
                        Right a -> return a
                        Left err -> ctch err


--------------------------------------------
--                                        --
--      Monad-independent helpers         --
--                                        --
--------------------------------------------

liftEither :: Monad m => Either String a -> m a
liftEither esa = case esa of
                   Left err -> fail err
                   Right x  -> return x

liftShowEither :: (Monad m, Show err) => Either err a -> m a
liftShowEither eerra = case eerra of
                         Left err -> fail $ show err
                         Right x  -> return x

check :: Monad m => Bool -> String -> m ()
check b err = if b then return () else fail err

checkM :: Monad m => m Bool -> String -> m ()
checkM mb err = mb >>= flip check err

ignore :: Monad m => m a -> m ()
ignore = (>> return ())

orElse :: Monad m => m (Maybe a) -> m a -> m a
orElse monma mona = do
  ma <- monma
  case ma of
    Just a -> return a
    Nothing -> mona

infixr 3 `orElse`

orM :: Monad m => m Bool -> m Bool -> m Bool
orM mba mbb = do
  ba <- mba
  if ba then return True else mbb

anyM :: Monad m => [m Bool] -> m Bool
anyM [] = return False
anyM (m:ms) = m `orM` anyM ms

maybeM :: Monad m => Maybe a -> (a -> m ()) -> m ()
maybeM ma f = maybe (return ()) f ma

withFold :: Monad m => [m a -> m a] -> m a -> m a
withFold = foldr (.) id

withFoldMap :: Monad m => (a -> m b -> m b) -> [a] -> m b -> m b
withFoldMap f = withFold . map f