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