MUtils

Plain source file: base/lib/MUtils.hs (2005-05-19)

MUtils is imported by: HsDeclMaps, HsExpMaps, HsExpUtil, HsFieldsMaps, HsGuardsMaps, HsKindMaps, HsModuleMaps, HsPatMaps, HsTypeMaps, WorkModule, NameMapsDecorate, OrigTiMonad, TiBySuper, TiClassInst, TiClasses, TiContextReduction, TiD, TiDecorate, TiDefault, TiDefinedNames, TiDerivedInstances, TiDinst, TiDkc, TiDs, TiE, TiFields, TiFresh, TiFunDeps, TiGeneralize, TiHsName, TiInstanceDB, TiLit, TiModule, TiP, TiPNT, TiPretty, TiRhs, TiSCC, TiSolve, TiTypes, TiUtil, Unification, FreeNames, NameMaps, NameMapsBaseStruct, ReAssocModule, ScopeModule, ScopeNames, ScopeNamesBaseStruct, DirUtils, FileUtils, SIO, SimpleGraphs, Unlit, ParseMonad, ParseUtil, PPU, PrettyPrint2, DerivingUtils, SimpPatMatch, BaseStruct2Alfa, PfeAlfaCmds, Prop2Alfa, ConvRefsTypes, HLex2html, MyDoc, StrategoCmds, PFE0, PFE2, PFE3, PFE4, PFE_Rewrite, PFE_Rewrites, PFE_StdNames, PFEdeps, Pfe0Cmds, Pfe1Cmds, Pfe2Cmds, Pfe3Cmds, Pfe3Metrics, Pfe4Cmds, PfeChase, PfeDepCmds, PfeParse, PfeSocket, IsabelleCmds, HsPropMaps, NameMapsPropDecorate, TiPropDecorate, TiPropInstances, TiPropStruct, NameMapsPropStruct, ScopeNamesProp, PropParseUtil, PropPlogic, CertServers, PFE_Certs, ParseAttrs, ParseCertAttrs, PfePropCmds, PropSyntaxStruct, ToQC.

-- Thomas' misc utils (things that are missing in the standard libraries)
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 &lt;# 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
-}

Index

(HTML for this module was generated on 2006-08-12. About the conversion tool.)