MUtils.hs

module MUtils where
import Monad(ap,unless,when)
import List(groupBy,sortBy,sort)
import Maybe(fromMaybe)
--import ExceptM()

-- all eta expansions because of the stupid monomorphism restriction

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

-- Infix versions of two essential operators:
f # x = fmap f x
mf <# mx  = ap mf mx

--Kleisli composition, another essential operator, sadly lacking from the
--Haskell 98 libraries:
m1 @@ m2 = \ x -> m1 =<< m2 x

f #. m = \ x -> f # m x

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

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

whenM m1 m2 = do b <- m1
		 when b m2

ifM bM tM eM = do b <- bM; if b then tM else eM
aM &&& bM = ifM aM bM (return False)
andM ms = foldr (&&&) (return True) ms
allM p = andM . map p

seqMaybe m = maybe (return Nothing) (Just # ) m

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

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

mapFstM f = mapM (apFstM f)
apFstM f (x,y) = flip (,) y # f x
mapSndM f = mapM (apSndM f)
apSndM f (x,y) = (,) x # f y

concatMapM f xs = concat # mapM f xs

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)
dup x = (x,x)
pairWith f x = (x,f x)
-- pairWith f = apSnd f . dup

mapPartition f [] = ([],[])
mapPartition f (x:xs) = either (apFst.(:)) (apSnd.(:)) (f x) (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

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

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

mapEither f g = either (Left . f) (Right . g)
seqEither x = either (Left # ) (Right # ) x

-- squeezeDups removes adjacent duplicates (cheaper than nub):
squeezeDups (r1:rrs@(r2:_)) = if r1==r2
			      then squeezeDups rrs
			      else r1:squeezeDups rrs
squeezeDups rs = rs

usort xs = squeezeDups (sort xs)

read' s = read'' "MUtils.read'" s

read'' msg s =
  case reads s of
    [(x,r)] | readAtEnd r -> x
    [] -> error $ msg++" no parse: "++take 60 s
    _ ->  error $ msg++" ambiguous parse: "++take 60 s

readAtEnd r = lex r == [("","")]

fromJust' = fromMaybe . error

--instance Functor ((->) a) where fmap = (.)

{-
instance Functor (Either err) where
  fmap = mapEither id

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