MUtils.hs

-- Thomas' misc utils
module MUtils where
import Monad(ap,unless)
import List(groupBy,sort,sortBy)

-- all eta expansions because of the stupid monomorphism restriction

infixl 1 #,<#,@@, >#<


f # x = fmap f x
mf <# mx  = ap mf mx

m1 @@ m2 = \ x -> m1 =<< m2 x

done :: Monad m => m ()
done = return ()

unlessM m1 m2 = do b <- m1
		   unless b m2

-- Property: f # x == return f <# x

(f >#< g) (x,y) = (,) # f x <# g y

mapSndM f = mapM (apSndM f)
apSndM f (x,y) = (,) x # f y

mapFst f = map (apFst f)
mapSnd f = map (apSnd f)
apSnd f (x,y) = (x,f y)
apFst f (x,y) = (f x,y)

mapBoth f = map (apBoth f)
apBoth f (x,y) = (f x,f y)

mapPartition f [] = ([],[])
mapPartition f (x:xs) =
  case f x of
    Left y -> apFst (y:) (mapPartition f xs)
    Right z -> apSnd (z:) (mapPartition f xs)


collectBySnd x =
    map pick .
    groupBy eqSnd .
    sortBy cmpSnd $ x
  where
    pick xys@((_,y):_) = ({-sort $-} map fst xys,y)

collectByFst x = map swap . collectBySnd . map swap $ x

onSnd f (_,y1) (_,y2) = f y1 y2
cmpSnd x = onSnd compare x
eqSnd x = onSnd (==) x
--onFst f (x1,_) (x2,_) = f x1 x2
--cmpFst = onFst compare
--eqFst = onFst (==)

swap (x,y) = (y,x)

instance Functor (Either err) where
  fmap f (Left err) = Left err
  fmap f (Right ans) = Right (f ans)

instance Monad (Either err) where
  return = Right
  Left err >>= _ = Left err
  Right ans >>= m = m ans