module Util.ExtendedPrelude (
trimTrailing,
trimLeading,
trimSpaces,
padToLength,
monadDot,
simpleSplit,
findJust,
insertOrdLt,
insertOrdGt,
insertOrd,
insertOrdAlternate,
bottom,
readCheck,
chop,
pairList,
lastOpt,
isPrefix,
HasCoMapIO(..),
HasMapIO(..),
HasMapMonadic(..),
mapPartialM,
splitByChar,
unsplitByChar,
unsplitByChar0,
splitToChar,
splitToElem,
splitToElemGeneral,
deleteFirst,
deleteFirstOpt,
deleteAndFindFirst,
deleteAndFindFirstOpt,
divideList,
treeFold,
treeFoldM,
mapEq,
mapOrd,
BreakFn,
addFallOut,
addFallOutWE,
addSimpleFallOut,
simpleFallOut,
mkBreakFn,
newFallOut,
isOurFallOut,
addGeneralFallOut,
GeneralBreakFn(..),GeneralCatchFn(..),
catchOurExceps,
catchAllExceps,
errorOurExceps,
ourExcepToMess,
breakOtherExceps,
showException2,
EqIO(..),OrdIO(..),
Full(..),
uniqOrd,
uniqOrdOrder,
uniqOrdByKey,
uniqOrdByKeyOrder,
allSame,
allEq,
findDuplicate,
generalisedMerge,
) where
import Data.Char
import Control.Monad
import Data.Maybe
import qualified Data.Map as Map
import qualified Data.Set as Set
import Control.Exception
import System.IO.Unsafe
import Util.Object
import Util.Computation
import Util.Dynamics
trimTrailing :: String -> String
trimTrailing str =
case tt str of
Nothing -> str
Just str2 -> str2
where
tt [] = Nothing
tt (str@[ch]) = if isSpace ch then Just [] else Nothing
tt (ch:rest) =
case tt rest of
Nothing -> Nothing
(j@(Just "")) -> if isSpace ch then j else Just [ch]
Just trimmed -> Just (ch:trimmed)
trimLeading :: String -> String
trimLeading [] = []
trimLeading (str@(ch:rest)) = if isSpace ch then trimLeading rest else str
trimSpaces :: String -> String
trimSpaces = trimTrailing . trimLeading
padToLength :: Int -> String -> String
padToLength l s =
let
len = length s
in
if len < l
then
replicate (l len) ' ' ++ s
else
s
readCheck :: Read a => String -> Maybe a
readCheck str = case reads str of
[(val,s)] | all isSpace s -> Just val
_ -> Nothing
monadDot :: Monad m => (b -> m c) -> (a -> m b) -> (a -> m c)
monadDot f g x =
do
y <- g x
f y
class HasMapIO option where
mapIO :: (a -> IO b) -> option a -> option b
class HasCoMapIO option where
coMapIO :: (a -> IO b) -> option b -> option a
class HasMapMonadic h where
mapMonadic :: Monad m => (a -> m b) -> h a -> m (h b)
instance HasMapMonadic [] where
mapMonadic = mapM
mapPartialM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b]
mapPartialM mapFn as =
do
bOpts <- mapM mapFn as
return (catMaybes bOpts)
simpleSplit :: (a -> Bool) -> [a] -> [[a]]
simpleSplit p s = case dropWhile p s of
[] -> []
s' -> w : simpleSplit p s''
where (w,s'') = break p s'
findJust :: (a -> Maybe b) -> [a] -> Maybe b
findJust f [] = Nothing
findJust f (x:xs) = case f x of
(y@ (Just _)) -> y
Nothing -> findJust f xs
deleteFirst :: (a -> Bool) -> [a] -> [a]
deleteFirst fn [] = error "ExtendedPrelude.deleteFirst - not found"
deleteFirst fn (a:as) =
if fn a then as else a:deleteFirst fn as
deleteFirstOpt :: (a -> Bool) -> [a] -> [a]
deleteFirstOpt fn as = case deleteAndFindFirstOpt fn as of
Nothing -> as
Just (_,as) -> as
deleteAndFindFirst :: (a -> Bool) -> [a] -> (a,[a])
deleteAndFindFirst fn []
= error "ExtendedPrelude.deleteAndFindFirst - not found"
deleteAndFindFirst fn (a:as) =
if fn a then (a,as) else
let
(a1,as1) = deleteAndFindFirst fn as
in
(a1,a:as1)
deleteAndFindFirstOpt :: (a -> Bool) -> [a] -> Maybe (a,[a])
deleteAndFindFirstOpt fn [] = Nothing
deleteAndFindFirstOpt fn (a:as) =
if fn a then Just (a,as) else
fmap
(\ (a1,as1) -> (a1,a:as1))
(deleteAndFindFirstOpt fn as)
divideList :: (a -> Either b c) -> [a] -> ([b],[c])
divideList fn [] = ([],[])
divideList fn (a:as) =
let
(bs,cs) = divideList fn as
in
case fn a of
Left b -> (b:bs,cs)
Right c -> (bs,c:cs)
insertOrdLt :: Ord a => a -> [a] -> [a]
insertOrdLt x l = insertOrd (<=) x l
insertOrdGt :: Ord a => a -> [a] -> [a]
insertOrdGt x l = insertOrd (>=) x l
insertOrd :: (a -> a -> Bool) -> a -> [a] -> [a]
insertOrd p x [] = [x]
insertOrd p x ll@(e:l) =
if p x e
then
x : ll
else
e : (insertOrd p x l)
insertOrdAlternate :: (a -> a -> Ordering) -> a -> (a -> a) -> [a] -> [a]
insertOrdAlternate p x merge [] = [x]
insertOrdAlternate p x merge (ll@(e:l)) =
case p x e of
LT -> x : ll
EQ -> merge e : l
GT -> e : insertOrdAlternate p x merge l
bottom :: a
bottom = error "Attempted to evaluate ExtendedPrelude.bottom"
splitByChar :: Char -> String -> [String]
splitByChar ch s = split s
where
split s = case splitTo s of
Nothing -> [s]
Just (s1,s2) -> s1 : split s2
splitTo [] = Nothing
splitTo (c:cs) = if c == ch then Just ([],cs) else
fmap
(\ (cs1,cs2) -> (c:cs1,cs2))
(splitTo cs)
unsplitByChar :: Char -> [String] -> String
unsplitByChar ch [] = error "unsplitByChar not defined for empty list"
unsplitByChar ch l = foldr1 (\w s -> w ++ ch:s) l
unsplitByChar0 :: Char -> [String] -> String
unsplitByChar0 ch [] = ""
unsplitByChar0 ch l = unsplitByChar ch l
splitToChar :: Char -> String -> Maybe (String,String)
splitToChar c = sTC
where
sTC [] = Nothing
sTC (x:xs) =
if x == c then Just ([],xs) else
fmap
(\ (xs1,xs2) -> (x:xs1,xs2))
(sTC xs)
splitToElem :: (a -> Bool) -> [a] -> Maybe ([a],[a])
splitToElem fn = sTC
where
sTC [] = Nothing
sTC (x:xs) =
if fn x then Just ([],xs) else
fmap
(\ (xs1,xs2) -> (x:xs1,xs2))
(sTC xs)
splitToElemGeneral :: (a -> Bool) -> [a] -> Maybe ([a],a,[a])
splitToElemGeneral fn = sTC
where
sTC [] = Nothing
sTC (x:xs) =
if fn x then Just ([],x,xs) else
fmap
(\ (xs1,x1,xs2) -> (x:xs1,x1,xs2))
(sTC xs)
chop :: Int -> [a] -> Maybe [a]
chop n list =
let
toTake = length list n
in
if toTake >=0 then Just (take toTake list) else Nothing
pairList :: a -> [b] -> [(a,b)]
pairList a bs = fmap (\ b -> (a,b)) bs
lastOpt :: [a] -> Maybe a
lastOpt [] = Nothing
lastOpt [a] = Just a
lastOpt (_:rest) = lastOpt rest
isPrefix :: Eq a => [a] -> [a] -> Maybe [a]
isPrefix [] s = Just s
isPrefix (c1 : c1s) (c2 : c2s) | c1 == c2
= isPrefix c1s c2s
isPrefix _ _ = Nothing
treeFold ::
(ancestorInfo -> state -> node -> (ancestorInfo,state,[node]))
-> ancestorInfo -> state -> node
-> state
treeFold visitNode initialAncestor initialState node =
let
(newAncestor,newState,children)
= visitNode initialAncestor initialState node
in
foldl
(\ state node -> treeFold visitNode newAncestor state node)
newState
children
treeFoldM :: Monad m =>
(ancestorInfo -> state -> node -> m (ancestorInfo,state,[node]))
-> ancestorInfo -> state -> node
-> m state
treeFoldM visitNode initialAncestor initialState node =
do
(newAncestor,newState,children)
<- visitNode initialAncestor initialState node
foldM
(\ state node -> treeFoldM visitNode newAncestor state node)
newState
children
mapEq :: Eq a => (b -> a) -> (b -> b -> Bool)
mapEq toA b1 b2 = (toA b1) == (toA b2)
mapOrd :: Ord a => (b -> a) -> (b -> b -> Ordering)
mapOrd toA b1 b2 = compare (toA b1) (toA b2)
type BreakFn = (forall other . String -> other)
addFallOut :: (BreakFn -> IO a) -> IO (Either String a)
addFallOut getAct =
do
(id,tryFn) <- newFallOut
tryFn (getAct (mkBreakFn id))
addFallOutWE :: (BreakFn -> IO a) -> IO (WithError a)
addFallOutWE toAct =
do
result <- addFallOut toAct
return (toWithError result)
simpleFallOut :: BreakFn
simpleFallOut = mkBreakFn simpleFallOutId
addSimpleFallOut :: IO a -> IO (Either String a)
simpleFallOutId :: ObjectID
(simpleFallOutId,addSimpleFallOut) = mkSimpleFallOut
mkSimpleFallOut = unsafePerformIO newFallOut
data FallOutExcep = FallOutExcep {
fallOutId :: ObjectID,
mess :: String
} deriving (Typeable)
mkBreakFn :: ObjectID -> BreakFn
mkBreakFn id mess = throw $ toDyn (FallOutExcep {fallOutId = id,mess = mess})
newFallOut :: IO (ObjectID,IO a -> IO (Either String a))
newFallOut =
do
id <- newObject
let
tryFn act = tryJust (isOurFallOut id) act
return (id,tryFn)
isOurFallOut :: ObjectID -> Dyn -> Maybe String
isOurFallOut oId dyn =
case fromDynamic dyn of
Nothing -> Nothing
Just fallOutExcep -> if fallOutId fallOutExcep /= oId
then
Nothing
else
Just (mess fallOutExcep)
data GeneralBreakFn a = GeneralBreakFn (forall b . a -> b)
data GeneralCatchFn a = GeneralCatchFn (forall c . IO c -> IO (Either a c))
addGeneralFallOut :: Typeable a => IO (GeneralBreakFn a,GeneralCatchFn a)
addGeneralFallOut =
do
(objectId,catchFn) <- newGeneralFallOut
let
breakFn a = throw $ toDyn (GeneralFallOutExcep {
generalFallOutId = objectId,a=a})
return (GeneralBreakFn breakFn,catchFn)
data GeneralFallOutExcep a = GeneralFallOutExcep {
generalFallOutId :: ObjectID,
a :: a
} deriving (Typeable)
newGeneralFallOut :: Typeable a => IO (ObjectID,GeneralCatchFn a)
newGeneralFallOut =
do
id <- newObject
let
tryFn act =
tryJust
(\ dyn ->
case fromDynamic dyn of
Nothing -> Nothing
Just generalFallOutExcep ->
if generalFallOutId generalFallOutExcep /= id
then
Nothing
else
Just (a generalFallOutExcep)
)
act
return (id,GeneralCatchFn tryFn)
ourExcepToMess :: Dyn -> Maybe String
ourExcepToMess dyn =
case fromDynamic dyn of
Just fallOut -> Just ("Fall-out exception "
++ show (fallOutId fallOut) ++ ": " ++ mess fallOut)
Nothing -> Just ("Mysterious dynamic exception " ++ show dyn)
showException2 :: Dyn -> String
showException2 exception =
fromMaybe (show exception) (ourExcepToMess exception)
catchOurExceps :: IO a -> IO (Either String a)
catchOurExceps act =
tryJust ourExcepToMess act
catchAllExceps :: IO a -> IO (Either String a)
catchAllExceps act =
do
result <- Control.Exception.try act
return (case result of
Left excep -> Left (showException2 excep)
Right a -> Right a
)
errorOurExceps :: IO a -> IO a
errorOurExceps act =
do
eOrA <- catchOurExceps act
case eOrA of
Left mess -> error mess
Right a -> return a
breakOtherExceps :: BreakFn -> IO a -> IO a
breakOtherExceps break act =
catchJust
(\ excep -> if isJust (ourExcepToMess excep)
then
Nothing
else
Just (break ("Haskell Exception: " ++ show excep))
)
act
id
newtype Full a = Full a
class EqIO v where
eqIO :: v -> v -> IO Bool
class EqIO v => OrdIO v where
compareIO :: v -> v -> IO Ordering
uniqOrd :: Ord a => [a] -> [a]
uniqOrd = Set.toList . Set.fromList
uniqOrdByKey :: Ord b => (a -> b) -> [a] -> [a]
uniqOrdByKey (getKey :: a -> b) (as :: [a]) =
let
fm :: Map.Map b a
fm = Map.fromList
(fmap
(\ a -> (getKey a,a))
as
)
in
fmap snd (Map.toList fm)
uniqOrdByKeyOrder :: Ord b => (a -> b) -> [a] -> [a]
uniqOrdByKeyOrder (getKey :: a -> b) =
let
u :: Set.Set b -> [a] -> [a]
u visited [] = []
u visited (a:as) =
if Set.member key visited
then
u visited as
else
a : u (Set.insert key visited) as
where
key = getKey a
in
u Set.empty
uniqOrdOrder :: Ord a => [a] -> [a]
uniqOrdOrder list = mkList Set.empty list
where
mkList _ [] = []
mkList set (a : as) =
if Set.member a set
then
mkList set as
else
a : mkList (Set.insert a set) as
findDuplicate :: Ord a => (b -> a) -> [b] -> Maybe b
findDuplicate toA bs = fd Set.empty bs
where
fd _ [] = Nothing
fd aSet0 (b:bs) =
let
a = toA b
in
if Set.member a aSet0
then
Just b
else
fd (Set.insert a aSet0) bs
allSame :: (a -> Bool) -> [a] -> Maybe Bool
allSame fn [] = Nothing
allSame fn (a : as) =
if fn a
then
if all fn as
then
Just True
else
Nothing
else
if any fn as
then
Nothing
else
Just False
allEq :: Eq a => [a] -> Bool
allEq [] = True
allEq (a:as) = all (== a) as
generalisedMerge :: (Monad m)
=> [a]
-> [b]
-> (a -> b -> Ordering)
-> (Maybe a -> Maybe b -> m (Maybe a,Maybe c))
-> m ([a],[c])
generalisedMerge as bs (compareFn :: a -> b -> Ordering)
(mergeFn :: Maybe a -> Maybe b -> m (Maybe a,Maybe c)) =
let
mkAC :: [m (Maybe a,Maybe c)] -> m ([a],[c])
mkAC mList =
do
(results :: [(Maybe a,Maybe c)]) <- sequence mList
return (mapMaybe fst results,mapMaybe snd results)
gm :: [a] -> [b] -> [m (Maybe a,Maybe c)]
gm as [] = fmap (\ a -> mergeFn (Just a) Nothing) as
gm [] bs = fmap (\ b -> mergeFn Nothing (Just b)) bs
gm (as0 @ (a:as1)) (bs0 @ (b:bs1)) = case compareFn a b of
LT -> mergeFn (Just a) Nothing : gm as1 bs0
GT -> mergeFn Nothing (Just b) : gm as0 bs1
EQ -> mergeFn (Just a) (Just b) : gm as1 bs1
in
mkAC (gm as bs)