{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE NoMonoPatBinds #-}

-- |
-- Description : What the Prelude Forgot
--
-- Basic string-manipulation and other functions they forgot to put in
-- the standard prelude.
module Util.ExtendedPrelude (
   -- * Trimming spaces from Strings and putting them back again.
   trimTrailing,
   trimLeading,
   trimSpaces,
   padToLength,

   -- * Miscellaneous functions
   monadDot,
   simpleSplit,
   findJust,
   insertOrdLt,
   insertOrdGt,
   insertOrd,
   insertOrdAlternate,
   bottom,

   readCheck,
      -- :: (Read a) => String -> Maybe a
      -- returns Just a if we can read a, and the rest is just spaces.

   chop, -- :: Int -> [a] -> Maybe [a]
      -- removes last elements from a list
   pairList, -- :: a -> [b] -> [(a,b)]
      -- pair of elements of a list.
   lastOpt, -- :: [a] -> Maybe a
      -- gets the last element of a list, safely.

   isPrefix,
      -- :: Eq a => [a] -> [a] -> Just [a]
      -- returns remainder if the first list is a prefix of the second one.

   -- Indicates that this type allows an IO-style map.
   HasCoMapIO(..),
   HasMapIO(..),
   HasMapMonadic(..),
   mapPartialM,

   splitByChar,

   -- * Miscellaneous string and list operations
   unsplitByChar,
   unsplitByChar0,
   splitToChar,
   splitToElem,
   splitToElemGeneral,
   deleteFirst,
   deleteFirstOpt,
   deleteAndFindFirst,
   deleteAndFindFirstOpt,
   divideList,

   -- | Folding on trees
   treeFold,
   treeFoldM,

   mapEq, -- used for instancing Eq
   mapOrd, -- used for instancing Ord.

   -- * Exception-driven error mechanism.
   BreakFn,
   addFallOut,
   addFallOutWE,

   addSimpleFallOut,
   simpleFallOut,
   mkBreakFn,
   newFallOut,
   isOurFallOut, -- :: ObjectID -> Exception -> Maybe String

   addGeneralFallOut,
   GeneralBreakFn(..),GeneralCatchFn(..),
   catchOurExceps, -- :: IO a -> IO (Either String a)
   catchAllExceps, -- :: IO a -> IO (Either String a)
   errorOurExceps, -- :: IO a -> IO a
   ourExcepToMess, -- :: Exception -> Maybe String
   breakOtherExceps, -- :: BreakFn -> IO a -> IO a
   showException2, -- :: Exception -> String

   -- * Other miscellaneous functions
   EqIO(..),OrdIO(..),
   Full(..),

   uniqOrd,
   uniqOrdOrder,

   uniqOrdByKey, -- :: Ord b => (a -> b) -> [a] -> [a]
   uniqOrdByKeyOrder, -- :: Ord b => (a -> b) -> [a] -> [a]
   -- Remove duplicate elements from a list where the key function is supplied.
   allSame,
   allEq, -- :: Eq a => [a] -> Bool
   findDuplicate, -- :: Ord a => (b -> a) -> [b] -> Maybe b

   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

-- ---------------------------------------------------------------------------
-- Character operations
-- ---------------------------------------------------------------------------

-- | Remove trailing spaces (We try to avoid reconstructing the string,
-- on the assumption that there aren't often spaces)
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)

-- | Remove leading spaces
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

-- | Remove trailing and leading spaces
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

-- | Pad a string if necessary to the given length with leading spaces.
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

-- | returns Just a if we can read a, and the rest is just spaces.
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


-- ---------------------------------------------------------------------------
-- Monad Operations
-- ---------------------------------------------------------------------------

-- | The "." operator lifted to monads.   So like ., the arguments
-- are given in the reverse order to that in which they should
-- be executed.
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

-- ---------------------------------------------------------------------------
-- Things to do with maps
-- ---------------------------------------------------------------------------

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] #-}

-- ---------------------------------------------------------------------------
-- List Operations
-- ---------------------------------------------------------------------------

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)


-- ---------------------------------------------------------------------------
-- Ordered List Operations
-- ---------------------------------------------------------------------------

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 is similar to insertOrd except (1) it takes an Ordering
-- argument; (2) if it finds an argument that matches, it applies the
-- given function to generate a new element, rather than inserting another.
-- The new generated element should be EQ to the old one.
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
-- ---------------------------------------------------------------------------

bottom :: a
bottom :: a
bottom = String -> a
forall a. HasCallStack => String -> a
error String
"Attempted to evaluate ExtendedPrelude.bottom"


-- ---------------------------------------------------------------------------
-- Splitting a string up into a list of strings and unsplitting back
-- by a single character.
-- Examples:
--    splitByChar '.' "a.b.." = ["a","b","",""]
--    splitByChar '.' "" = [""]
-- unsplitByChar is the inverse function.
-- unsplitByChar0 allows the empty list.
-- ---------------------------------------------------------------------------

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

-- ------------------------------------------------------------------------
-- Splitting to and after a character
-- ------------------------------------------------------------------------

-- | We split at the first occurrence of the character, returning the
-- string before and after.
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)

-- ------------------------------------------------------------------------
-- Like splitToChar, but with an arbitrary predicate.
-- ------------------------------------------------------------------------

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)

-- ------------------------------------------------------------------------
-- Like splitToElem, but also return the matching element
-- ------------------------------------------------------------------------

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)

-- ------------------------------------------------------------------------
-- Removing the last n elements from a list
-- ------------------------------------------------------------------------

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

-- ------------------------------------------------------------------------
-- Pair off elements of a list
-- ------------------------------------------------------------------------

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

-- ------------------------------------------------------------------------
-- Get the last element (safely)
-- ------------------------------------------------------------------------

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


-- ------------------------------------------------------------------------
-- Prefix functions
-- ------------------------------------------------------------------------



-- | returns remainder if the first list is a prefix of the second one.
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

-- ------------------------------------------------------------------------
-- Folding a Tree
-- ------------------------------------------------------------------------

-- | node is the tree's node type.
-- state is folded through every node of the tree (and is the result).
-- We search the tree in depth-first order, applying visitNode at each
--   node to update the state.
-- The ancestorInfo information comes from the ancestors of the node.  EG
-- if we are visiting node N1 which came from N2 the ancestorInfo given to
-- visitNode for N1 will be that computed from visitNode for N2.
-- For the root node, it will be initialAncestor
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

-- | Like treeFold, but using monads.
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

-- ------------------------------------------------------------------------
-- Functions which make it easy to create new instances of Eq and Ord.
-- ------------------------------------------------------------------------

-- | Produce an equality function for b
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)

-- | Produce a compare function for b
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)

-- ------------------------------------------------------------------------
-- Adding fall-out actions to IO actions
-- ------------------------------------------------------------------------

-- | A function indicating we want to escape from the current computation.
type BreakFn = (forall other . String -> other)

-- |  Intended use, EG
--    addFallOut (\ break ->
--       do
--          -- blah blah (normal IO a stuff) --
--          when (break condition)
--             (break "You can't do that there ere")
--          -- more blah blah, not executed if there's an break --
--          return (value of type a)
--       )
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))

-- | Like addFallOut, but returns a WithError object instead.
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 -- not a fallout.
            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
                  -- don't handle this; it's from another
                  -- addFallOut
               else
                  String -> Maybe String
forall a. a -> Maybe a
Just (FallOutExcep -> String
mess FallOutExcep
fallOutExcep)


-- ------------------------------------------------------------------------
-- More general try/catch function.
-- ------------------------------------------------------------------------

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
                           -- not a fallout, or not the right type of a.
                        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
                              -- don't handle this; it's from another
                              -- addGeneralFallOut
                           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)

-- ------------------------------------------------------------------------
-- General catch function for our exceptions.
-- ------------------------------------------------------------------------

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




-- ------------------------------------------------------------------------
-- Miscellanous equality types
-- ------------------------------------------------------------------------

-- | indicates that an Ord or Eq instance really does need to
-- take everything into account.
newtype Full a = Full a

-- ------------------------------------------------------------------------
-- Where equality and comparing requires IO.
-- ------------------------------------------------------------------------

class EqIO v where
   eqIO :: v -> v -> IO Bool

class EqIO v => OrdIO v where
   compareIO :: v -> v -> IO Ordering

-- ------------------------------------------------------------------------
-- Eq/Ord operations
-- ------------------------------------------------------------------------


-- | Remove duplicate elements from a list.
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

-- | Remove duplicate elements from a list where the key function is supplied.
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)

-- | Remove duplicate elements from a list where the key function is supplied.
-- The list order is preserved and of the duplicates, it is the first in the
-- list which is not deleted.
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

-- | Like uniqOrd, except that we specify the output order of the list.
-- The resulting list is that obtained by deleting all duplicate elements
-- in the list, except the first, for example [1,2,3,2,1,4] will go to
-- [1,2,3,4].
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

-- | If there are two elements of the list with the same (a), return one,
-- otherwise Nothing.
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

-- | Return Just True if all the elements give True, Just False if all False,
-- Nothing otherwise (or list is empty).
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

-- | If all the elements are equal, return True
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

-- ------------------------------------------------------------------------
-- Generalised Merge
-- ------------------------------------------------------------------------

-- | A merge function for combining an input list with some new data,
-- where both are pre-sorted.
generalisedMerge :: (Monad m)
   => [a] -- ^ input list
   -> [b] -- ^ list to combine with input list
   -> (a -> b -> Ordering)
          -- ^ comparison function.  a and b should be already sorted
          -- consistently with this comparison function, and it is assumed
          -- that each list is EQ to at most one of the other.
   -> (Maybe a -> Maybe b -> m (Maybe a,Maybe c))
          -- ^ Merge function applied to each element of a and b, where
          -- we pair EQ elements together.
   -> m ([a],[c])
          -- ^ Output of merge function concatenated.
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)