{-# LANGUAGE CPP #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings         #-}
{-# LANGUAGE ScopedTypeVariables       #-}
{-# LANGUAGE TupleSections             #-}
{-# LANGUAGE ConstraintKinds           #-}
{-# LANGUAGE TypeOperators             #-}
{-# LANGUAGE BangPatterns              #-}
{-# LANGUAGE ImplicitParams            #-} -- ignore hlint

module Language.Fixpoint.Misc where

-- import           System.IO.Unsafe            (unsafePerformIO)
import           Control.Exception                (bracket_)
import           Data.Hashable
-- import           Data.IORef
import           Control.Arrow                    (second)
import           Control.Monad                    (when, forM_, filterM)
import qualified Data.HashMap.Strict              as M
import qualified Data.List                        as L
import qualified Data.HashSet                     as S
import           Data.Tuple                       (swap)
import           Data.Maybe
import           Data.Array                       hiding (indices)
import           Data.Function                    (on)
import qualified Data.Graph                       as G
import qualified Data.Tree                        as T

import           Data.Unique
import           Debug.Trace                      (trace)
import           System.Console.ANSI
import           System.Console.CmdArgs.Verbosity (whenLoud)
import           System.Process                   (system)
import           System.Directory                 (createDirectoryIfMissing)
import           System.FilePath                  (takeDirectory)
import           Text.PrettyPrint.HughesPJ.Compat
import           System.IO                        (stdout, hFlush )
import           System.Exit                      (ExitCode)
import           Control.Concurrent.Async

import Prelude hiding (undefined)
import GHC.Stack

type (|->) a b = M.HashMap a b

firstMaybe :: (a -> Maybe b) -> [a] -> Maybe b
firstMaybe :: (a -> Maybe b) -> [a] -> Maybe b
firstMaybe a -> Maybe b
f = [b] -> Maybe b
forall a. [a] -> Maybe a
listToMaybe ([b] -> Maybe b) -> ([a] -> [b]) -> [a] -> Maybe b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Maybe b) -> [a] -> [b]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe a -> Maybe b
f


asyncMapM :: (a -> IO b) -> [a] -> IO [b]
asyncMapM :: (a -> IO b) -> [a] -> IO [b]
asyncMapM a -> IO b
f [a]
xs = (a -> IO (Async b)) -> [a] -> IO [Async b]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (IO b -> IO (Async b)
forall a. IO a -> IO (Async a)
async (IO b -> IO (Async b)) -> (a -> IO b) -> a -> IO (Async b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> IO b
f) [a]
xs IO [Async b] -> ([Async b] -> IO [b]) -> IO [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Async b -> IO b) -> [Async b] -> IO [b]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Async b -> IO b
forall a. Async a -> IO a
wait

traceShow     ::  Show a => String -> a -> a
traceShow :: String -> a -> a
traceShow String
s a
x = String -> a -> a
forall a. String -> a -> a
trace (String
"\nTrace: [" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"] : " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x)  a
x

hashMapToAscList :: Ord a => M.HashMap a b -> [(a, b)]
hashMapToAscList :: HashMap a b -> [(a, b)]
hashMapToAscList = ((a, b) -> (a, b) -> Ordering) -> [(a, b)] -> [(a, b)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
L.sortBy (a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (a -> a -> Ordering)
-> ((a, b) -> a) -> (a, b) -> (a, b) -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (a, b) -> a
forall a b. (a, b) -> a
fst) ([(a, b)] -> [(a, b)])
-> (HashMap a b -> [(a, b)]) -> HashMap a b -> [(a, b)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap a b -> [(a, b)]
forall k v. HashMap k v -> [(k, v)]
M.toList

findNearest :: (Ord i, Num i) => i -> [(i, a)] -> Maybe a 
findNearest :: i -> [(i, a)] -> Maybe a
findNearest i
key [(i, a)]
kvs = [(i, a)] -> Maybe a
forall k v. Ord k => [(k, v)] -> Maybe v
argMin [ (i -> i
forall a. Num a => a -> a
abs (i
key i -> i -> i
forall a. Num a => a -> a -> a
- i
k), a
v) | (i
k, a
v) <- [(i, a)]
kvs ]

argMin :: (Ord k) => [(k, v)] -> Maybe v 
argMin :: [(k, v)] -> Maybe v
argMin = ((k, v) -> v) -> Maybe (k, v) -> Maybe v
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (k, v) -> v
forall a b. (a, b) -> b
snd (Maybe (k, v) -> Maybe v)
-> ([(k, v)] -> Maybe (k, v)) -> [(k, v)] -> Maybe v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(k, v)] -> Maybe (k, v)
forall a. [a] -> Maybe a
headMb ([(k, v)] -> Maybe (k, v))
-> ([(k, v)] -> [(k, v)]) -> [(k, v)] -> Maybe (k, v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((k, v) -> (k, v) -> Ordering) -> [(k, v)] -> [(k, v)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
L.sortBy (k -> k -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (k -> k -> Ordering)
-> ((k, v) -> k) -> (k, v) -> (k, v) -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (k, v) -> k
forall a b. (a, b) -> a
fst)

headMb :: [a] -> Maybe a 
headMb :: [a] -> Maybe a
headMb []    = Maybe a
forall a. Maybe a
Nothing 
headMb (a
x:[a]
_) = a -> Maybe a
forall a. a -> Maybe a
Just a
x
---------------------------------------------------------------
-- | Unique Int -----------------------------------------------
---------------------------------------------------------------

getUniqueInt :: IO Int
getUniqueInt :: IO Int
getUniqueInt = do
  Int
n1 <- Unique -> Int
hashUnique (Unique -> Int) -> IO Unique -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Unique
newUnique
  Int
n2 <- Unique -> Int
hashUnique (Unique -> Int) -> IO Unique -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Unique
newUnique
  Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
n1 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
n2)

---------------------------------------------------------------
-- | Edit Distance --------------------------------------------
---------------------------------------------------------------

editDistance :: Eq a => [a] -> [a] -> Int
editDistance :: [a] -> [a] -> Int
editDistance [a]
xs [a]
ys = Array (Int, Int) Int
table Array (Int, Int) Int -> (Int, Int) -> Int
forall i e. Ix i => Array i e -> i -> e
! (Int
m, Int
n)
    where
    (Int
m,Int
n) = ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs, [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
ys)
    x :: Array Int a
x     = (Int, Int) -> [(Int, a)] -> Array Int a
forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array (Int
1,Int
m) ([Int] -> [a] -> [(Int, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] [a]
xs)
    y :: Array Int a
y     = (Int, Int) -> [(Int, a)] -> Array Int a
forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array (Int
1,Int
n) ([Int] -> [a] -> [(Int, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] [a]
ys)

    table :: Array (Int,Int) Int
    table :: Array (Int, Int) Int
table = ((Int, Int), (Int, Int))
-> [((Int, Int), Int)] -> Array (Int, Int) Int
forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array ((Int, Int), (Int, Int))
forall a b. (Num a, Num b) => ((a, b), (Int, Int))
bnds [((Int, Int)
ij, (Int, Int) -> Int
dist (Int, Int)
ij) | (Int, Int)
ij <- ((Int, Int), (Int, Int)) -> [(Int, Int)]
forall a. Ix a => (a, a) -> [a]
range ((Int, Int), (Int, Int))
forall a b. (Num a, Num b) => ((a, b), (Int, Int))
bnds]
    bnds :: ((a, b), (Int, Int))
bnds  = ((a
0,b
0),(Int
m,Int
n))

    dist :: (Int, Int) -> Int
dist (Int
0,Int
j) = Int
j
    dist (Int
i,Int
0) = Int
i
    dist (Int
i,Int
j) = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [Array (Int, Int) Int
table Array (Int, Int) Int -> (Int, Int) -> Int
forall i e. Ix i => Array i e -> i -> e
! (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1,Int
j) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Array (Int, Int) Int
table Array (Int, Int) Int -> (Int, Int) -> Int
forall i e. Ix i => Array i e -> i -> e
! (Int
i,Int
jInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1,
        if Array Int a
x Array Int a -> Int -> a
forall i e. Ix i => Array i e -> i -> e
! Int
i a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== Array Int a
y Array Int a -> Int -> a
forall i e. Ix i => Array i e -> i -> e
! Int
j then Array (Int, Int) Int
table Array (Int, Int) Int -> (Int, Int) -> Int
forall i e. Ix i => Array i e -> i -> e
! (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1,Int
jInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) else Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Array (Int, Int) Int
table Array (Int, Int) Int -> (Int, Int) -> Int
forall i e. Ix i => Array i e -> i -> e
! (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1,Int
jInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)]

-----------------------------------------------------------------------------------
------------ Support for Colored Logging ------------------------------------------
-----------------------------------------------------------------------------------

data Moods = Ok | Loud | Sad | Happy | Angry | Wary

moodColor :: Moods -> Color
moodColor :: Moods -> Color
moodColor Moods
Ok    = Color
Black
moodColor Moods
Loud  = Color
Blue
moodColor Moods
Sad   = Color
Magenta
moodColor Moods
Happy = Color
Green
moodColor Moods
Angry = Color
Red
moodColor Moods
Wary  = Color
Yellow

wrapStars :: String -> String
wrapStars :: String -> String
wrapStars String
msg = String
"\n**** " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
74 Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
msg) Char
'*'

withColor :: Color -> IO () -> IO ()
-- withColor _ act = act
withColor :: Color -> IO () -> IO ()
withColor Color
c IO ()
act
   = do [SGR] -> IO ()
setSGR [ ConsoleIntensity -> SGR
SetConsoleIntensity ConsoleIntensity
BoldIntensity, ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
c]
        IO ()
act
        [SGR] -> IO ()
setSGR [ SGR
Reset]

colorStrLn :: Moods -> String -> IO ()
colorStrLn :: Moods -> String -> IO ()
colorStrLn Moods
c       = Color -> IO () -> IO ()
withColor (Moods -> Color
moodColor Moods
c) (IO () -> IO ()) -> (String -> IO ()) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStrLn

colorPhaseLn :: Moods -> String -> String -> IO ()
colorPhaseLn :: Moods -> String -> String -> IO ()
colorPhaseLn Moods
c String
msg = Moods -> String -> IO ()
colorStrLn Moods
c (String -> IO ()) -> (String -> String) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
wrapStars (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  (String
msg String -> String -> String
forall a. [a] -> [a] -> [a]
++)

startPhase :: Moods -> String -> IO ()
startPhase :: Moods -> String -> IO ()
startPhase Moods
c String
msg   = Moods -> String -> String -> IO ()
colorPhaseLn Moods
c String
"START: " String
msg IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Moods -> String -> IO ()
colorStrLn Moods
Ok String
" "

doneLine   :: Moods -> String -> IO ()
doneLine :: Moods -> String -> IO ()
doneLine   Moods
c String
msg   = Moods -> String -> String -> IO ()
colorPhaseLn Moods
c String
"DONE:  " String
msg IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Moods -> String -> IO ()
colorStrLn Moods
Ok String
" "

donePhase :: Moods -> String -> IO ()
donePhase :: Moods -> String -> IO ()
donePhase Moods
c String
str
  = case String -> [String]
lines String
str of
      (String
l:[String]
ls) -> Moods -> String -> IO ()
doneLine Moods
c String
l IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [String] -> (String -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [String]
ls (Moods -> String -> String -> IO ()
colorPhaseLn Moods
c String
"") IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
stdout
      [String]
_      -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

putBlankLn :: IO ()
putBlankLn :: IO ()
putBlankLn = String -> IO ()
putStrLn String
"" IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
stdout

--------------------------------------------------------------------------------
wrap :: [a] -> [a] -> [a] -> [a]
wrap :: [a] -> [a] -> [a] -> [a]
wrap [a]
l [a]
r [a]
s = [a]
l [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
s [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
r

repeats :: Int -> [a] -> [a]
repeats :: Int -> [a] -> [a]
repeats Int
n  = [[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[a]] -> [a]) -> ([a] -> [[a]]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [a] -> [[a]]
forall a. Int -> a -> [a]
replicate Int
n


errorP :: String -> String -> a
errorP :: String -> String -> a
errorP String
p String
s = String -> a
forall a. HasCallStack => String -> a
error (String
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s)   

errorstar :: (?callStack :: CallStack) => String -> a
errorstar :: String -> a
errorstar  = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> (String -> String) -> String -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String -> String
forall a. [a] -> [a] -> [a] -> [a]
wrap (String
stars String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n") (String
stars String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n")
  where
    stars :: String
stars = Int -> String -> String
forall a. Int -> [a] -> [a]
repeats Int
3 (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
wrapStars String
"ERROR"

fst3 ::  (a, b, c) -> a
fst3 :: (a, b, c) -> a
fst3 (a
x,b
_,c
_) = a
x

snd3 ::  (a, b, c) -> b
snd3 :: (a, b, c) -> b
snd3 (a
_,b
x,c
_) = b
x

thd3 ::  (a, b, c) -> c
thd3 :: (a, b, c) -> c
thd3 (a
_,b
_,c
x) = c
x

secondM :: Functor f => (b -> f c) -> (a, b) -> f (a, c)
secondM :: (b -> f c) -> (a, b) -> f (a, c)
secondM b -> f c
act (a
x, b
y) = (a
x,) (c -> (a, c)) -> f c -> f (a, c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> b -> f c
act b
y

mlookup    :: (?callStack :: CallStack, Eq k, Show k, Hashable k) => M.HashMap k v -> k -> v
safeLookup :: (?callStack :: CallStack, Eq k, Hashable k) => String -> k -> M.HashMap k v -> v
mfromJust  :: (?callStack :: CallStack) => String -> Maybe a -> a

mlookup :: HashMap k v -> k -> v
mlookup HashMap k v
m k
k = v -> Maybe v -> v
forall a. a -> Maybe a -> a
fromMaybe v
forall a. a
err (Maybe v -> v) -> Maybe v -> v
forall a b. (a -> b) -> a -> b
$ k -> HashMap k v -> Maybe v
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup k
k HashMap k v
m
  where
    err :: a
err     = String -> a
forall a. HasCallStack => String -> a
errorstar (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"mlookup: unknown key " String -> String -> String
forall a. [a] -> [a] -> [a]
++ k -> String
forall a. Show a => a -> String
show k
k

safeLookup :: String -> k -> HashMap k v -> v
safeLookup String
msg k
k HashMap k v
m   = v -> Maybe v -> v
forall a. a -> Maybe a -> a
fromMaybe (String -> v
forall a. HasCallStack => String -> a
errorstar String
msg) (k -> HashMap k v -> Maybe v
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup k
k HashMap k v
m)
mfromJust :: String -> Maybe a -> a
mfromJust String
_ (Just a
x) = a
x
mfromJust String
s Maybe a
Nothing  = String -> a
forall a. HasCallStack => String -> a
errorstar (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"mfromJust: Nothing " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s

inserts ::  (Eq k, Hashable k) => k -> v -> M.HashMap k [v] -> M.HashMap k [v]
inserts :: k -> v -> HashMap k [v] -> HashMap k [v]
inserts k
k v
v HashMap k [v]
m = k -> [v] -> HashMap k [v] -> HashMap k [v]
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
M.insert k
k (v
v v -> [v] -> [v]
forall a. a -> [a] -> [a]
: [v] -> k -> HashMap k [v] -> [v]
forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
M.lookupDefault [] k
k HashMap k [v]
m) HashMap k [v]
m

removes ::  (Eq k, Hashable k, Eq v) => k -> v -> M.HashMap k [v] -> M.HashMap k [v]
removes :: k -> v -> HashMap k [v] -> HashMap k [v]
removes k
k v
v HashMap k [v]
m = k -> [v] -> HashMap k [v] -> HashMap k [v]
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
M.insert k
k (v -> [v] -> [v]
forall a. Eq a => a -> [a] -> [a]
L.delete v
v ([v] -> k -> HashMap k [v] -> [v]
forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
M.lookupDefault [] k
k HashMap k [v]
m)) HashMap k [v]
m

count :: (Eq k, Hashable k) => [k] -> [(k, Int)]
count :: [k] -> [(k, Int)]
count = HashMap k Int -> [(k, Int)]
forall k v. HashMap k v -> [(k, v)]
M.toList (HashMap k Int -> [(k, Int)])
-> ([k] -> HashMap k Int) -> [k] -> [(k, Int)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Int] -> Int) -> HashMap k [Int] -> HashMap k Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (HashMap k [Int] -> HashMap k Int)
-> ([k] -> HashMap k [Int]) -> [k] -> HashMap k Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(k, Int)] -> HashMap k [Int]
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k [v]
group ([(k, Int)] -> HashMap k [Int])
-> ([k] -> [(k, Int)]) -> [k] -> HashMap k [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (k -> (k, Int)) -> [k] -> [(k, Int)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (, Int
1)

group :: (Eq k, Hashable k) => [(k, v)] -> M.HashMap k [v]
group :: [(k, v)] -> HashMap k [v]
group = HashMap k [v] -> [(k, v)] -> HashMap k [v]
forall k v.
(Eq k, Hashable k) =>
HashMap k [v] -> [(k, v)] -> HashMap k [v]
groupBase HashMap k [v]
forall k v. HashMap k v
M.empty

groupBase :: (Eq k, Hashable k) => M.HashMap k [v] -> [(k, v)] -> M.HashMap k [v]
groupBase :: HashMap k [v] -> [(k, v)] -> HashMap k [v]
groupBase = (HashMap k [v] -> (k, v) -> HashMap k [v])
-> HashMap k [v] -> [(k, v)] -> HashMap k [v]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl' (\HashMap k [v]
m (k
k, v
v) -> k -> v -> HashMap k [v] -> HashMap k [v]
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k [v] -> HashMap k [v]
inserts k
k v
v HashMap k [v]
m)

groupList :: (Eq k, Hashable k) => [(k, v)] -> [(k, [v])]
groupList :: [(k, v)] -> [(k, [v])]
groupList = HashMap k [v] -> [(k, [v])]
forall k v. HashMap k v -> [(k, v)]
M.toList (HashMap k [v] -> [(k, [v])])
-> ([(k, v)] -> HashMap k [v]) -> [(k, v)] -> [(k, [v])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(k, v)] -> HashMap k [v]
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k [v]
group

groupMap   :: (Eq k, Hashable k) => (a -> k) -> [a] -> M.HashMap k [a]
groupMap :: (a -> k) -> [a] -> HashMap k [a]
groupMap a -> k
f = (HashMap k [a] -> a -> HashMap k [a])
-> HashMap k [a] -> [a] -> HashMap k [a]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl' (\HashMap k [a]
m a
x -> k -> a -> HashMap k [a] -> HashMap k [a]
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k [v] -> HashMap k [v]
inserts (a -> k
f a
x) a
x HashMap k [a]
m) HashMap k [a]
forall k v. HashMap k v
M.empty

allMap :: (Eq k, Hashable k) => (v -> Bool) -> M.HashMap k v -> Bool
allMap :: (v -> Bool) -> HashMap k v -> Bool
allMap v -> Bool
p = (Bool -> v -> Bool) -> Bool -> HashMap k v -> Bool
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl' (\Bool
a v
v -> Bool
a Bool -> Bool -> Bool
&& v -> Bool
p v
v) Bool
True

hashNub :: (Eq k, Hashable k) => [k] -> [k]
hashNub :: [k] -> [k]
hashNub = HashMap k () -> [k]
forall k v. HashMap k v -> [k]
M.keys (HashMap k () -> [k]) -> ([k] -> HashMap k ()) -> [k] -> [k]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(k, ())] -> HashMap k ()
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
M.fromList ([(k, ())] -> HashMap k ())
-> ([k] -> [(k, ())]) -> [k] -> HashMap k ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (k -> (k, ())) -> [k] -> [(k, ())]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (, ())

sortNub :: (Ord a) => [a] -> [a]
sortNub :: [a] -> [a]
sortNub = [a] -> [a]
forall a. Eq a => [a] -> [a]
nubOrd ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [a]
forall a. Ord a => [a] -> [a]
L.sort

nubOrd :: (Eq a) => [a] -> [a]
nubOrd :: [a] -> [a]
nubOrd (a
x:t :: [a]
t@(a
y:[a]
_))
  | a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y    = [a] -> [a]
forall a. Eq a => [a] -> [a]
nubOrd [a]
t
  | Bool
otherwise = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a]
forall a. Eq a => [a] -> [a]
nubOrd [a]
t
nubOrd [a]
xs     = [a]
xs

hashNubWith :: (Eq b, Hashable b) => (a -> b) -> [a] -> [a]
hashNubWith :: (a -> b) -> [a] -> [a]
hashNubWith a -> b
f [a]
xs = HashMap b a -> [a]
forall k v. HashMap k v -> [v]
M.elems (HashMap b a -> [a]) -> HashMap b a -> [a]
forall a b. (a -> b) -> a -> b
$ [(b, a)] -> HashMap b a
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
M.fromList [ (a -> b
f a
x, a
x) | a
x <- [a]
xs ]

mFromList :: (Eq k, Hashable k) => [(k, v)] -> M.HashMap k v
mFromList :: [(k, v)] -> HashMap k v
mFromList = [(k, v)] -> HashMap k v
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
M.fromList 

duplicates :: (Eq k, Hashable k) => [k] -> [k]
duplicates :: [k] -> [k]
duplicates [k]
xs = [ k
x | (k
x, Int
n) <- [k] -> [(k, Int)]
forall k. (Eq k, Hashable k) => [k] -> [(k, Int)]
count [k]
xs, Int
1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n ]

safeZip :: (?callStack :: CallStack) => String -> [a] -> [b] -> [(a,b)]
safeZipWith :: (?callStack :: CallStack) => String -> (a -> b -> c) -> [a] -> [b] -> [c]

safeZip :: String -> [a] -> [b] -> [(a, b)]
safeZip String
msg [a]
xs [b]
ys
  | Int
nxs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
nys
  = [a] -> [b] -> [(a, b)]
forall a b. [a] -> [b] -> [(a, b)]
zip [a]
xs [b]
ys
  | Bool
otherwise
  = String -> [(a, b)]
forall a. HasCallStack => String -> a
errorstar (String -> [(a, b)]) -> String -> [(a, b)]
forall a b. (a -> b) -> a -> b
$ String
"safeZip called on non-eq-sized lists (nxs = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
nxs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", nys = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
nys String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") : " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg
  where
    nxs :: Int
nxs = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs
    nys :: Int
nys = [b] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [b]
ys

safeZipWith :: String -> (a -> b -> c) -> [a] -> [b] -> [c]
safeZipWith String
msg a -> b -> c
f [a]
xs [b]
ys
  | Int
nxs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
nys
  = (a -> b -> c) -> [a] -> [b] -> [c]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith a -> b -> c
f [a]
xs [b]
ys
  | Bool
otherwise
  = String -> [c]
forall a. HasCallStack => String -> a
errorstar (String -> [c]) -> String -> [c]
forall a b. (a -> b) -> a -> b
$ String
"safeZipWith called on non-eq-sized lists (nxs = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
nxs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", nys = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
nys String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") : " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg
    where nxs :: Int
nxs = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs
          nys :: Int
nys = [b] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [b]
ys


{-@ type ListNE a = {v:[a] | 0 < len v} @-}
type ListNE a = [a]

safeHead   :: (?callStack :: CallStack) => String -> ListNE a -> a
safeLast   :: (?callStack :: CallStack) => String -> ListNE a -> a
safeInit   :: (?callStack :: CallStack) => String -> ListNE a -> [a]
safeUncons :: (?callStack :: CallStack) => String -> ListNE a -> (a, [a])
safeUnsnoc :: (?callStack :: CallStack) => String -> ListNE a -> ([a], a)
safeFromList :: (?callStack :: CallStack, Eq k, Hashable k, Show k) => String -> [(k, v)] -> M.HashMap k v

safeFromList :: String -> [(k, v)] -> HashMap k v
safeFromList String
msg [(k, v)]
kvs = HashMap k v -> ([k] -> HashMap k v) -> [k] -> HashMap k v
forall b a. b -> ([a] -> b) -> [a] -> b
applyNonNull ([(k, v)] -> HashMap k v
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
M.fromList [(k, v)]
kvs) [k] -> HashMap k v
forall a c. Show a => a -> c
err [k]
dups
  where
    -- dups             = duplicates . fmap fst
    dups :: [k]
dups             = [ k
x | (k
x, Int
n) <- [k] -> [(k, Int)]
forall k. (Eq k, Hashable k) => [k] -> [(k, Int)]
count ((k, v) -> k
forall a b. (a, b) -> a
fst ((k, v) -> k) -> [(k, v)] -> [k]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(k, v)]
kvs), Int
1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n ]
    err :: a -> c
err              = String -> c
forall a. HasCallStack => String -> a
errorstar (String -> c) -> (a -> String) -> a -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String -> String
wrap String
"safeFromList with duplicates" String
msg (String -> String) -> (a -> String) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show
    wrap :: String -> String -> String -> String
wrap String
m1 String
m2 String
s     = String
m1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
m2 

safeHead :: String -> ListNE a -> a
safeHead String
_   (a
x:ListNE a
_) = a
x
safeHead String
msg ListNE a
_     = String -> a
forall a. HasCallStack => String -> a
errorstar (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"safeHead with empty list " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg

safeLast :: String -> ListNE a -> a
safeLast String
_ xs :: ListNE a
xs@(a
_:ListNE a
_) = ListNE a -> a
forall a. [a] -> a
last ListNE a
xs
safeLast String
msg ListNE a
_      = String -> a
forall a. HasCallStack => String -> a
errorstar (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"safeLast with empty list " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg

safeInit :: String -> ListNE a -> ListNE a
safeInit String
_ xs :: ListNE a
xs@(a
_:ListNE a
_) = ListNE a -> ListNE a
forall a. [a] -> [a]
init ListNE a
xs
safeInit String
msg ListNE a
_      = String -> ListNE a
forall a. HasCallStack => String -> a
errorstar (String -> ListNE a) -> String -> ListNE a
forall a b. (a -> b) -> a -> b
$ String
"safeInit with empty list " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg

safeUncons :: String -> ListNE a -> (a, ListNE a)
safeUncons String
_ (a
x:ListNE a
xs) = (a
x, ListNE a
xs)
safeUncons String
msg ListNE a
_    = String -> (a, ListNE a)
forall a. HasCallStack => String -> a
errorstar (String -> (a, ListNE a)) -> String -> (a, ListNE a)
forall a b. (a -> b) -> a -> b
$ String
"safeUncons with empty list " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg

safeUnsnoc :: String -> ListNE a -> (ListNE a, a)
safeUnsnoc String
msg = (a, ListNE a) -> (ListNE a, a)
forall a b. (a, b) -> (b, a)
swap ((a, ListNE a) -> (ListNE a, a))
-> (ListNE a -> (a, ListNE a)) -> ListNE a -> (ListNE a, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ListNE a -> ListNE a) -> (a, ListNE a) -> (a, ListNE a)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ListNE a -> ListNE a
forall a. [a] -> [a]
reverse ((a, ListNE a) -> (a, ListNE a))
-> (ListNE a -> (a, ListNE a)) -> ListNE a -> (a, ListNE a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ListNE a -> (a, ListNE a)
forall a. HasCallStack => String -> ListNE a -> (a, ListNE a)
safeUncons String
msg (ListNE a -> (a, ListNE a))
-> (ListNE a -> ListNE a) -> ListNE a -> (a, ListNE a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ListNE a -> ListNE a
forall a. [a] -> [a]
reverse

executeShellCommand :: String -> String -> IO ExitCode
executeShellCommand :: String -> String -> IO ExitCode
executeShellCommand String
phase String
cmd
  = do String -> IO ()
writeLoud (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"EXEC: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cmd
       IO () -> IO () -> IO ExitCode -> IO ExitCode
forall a b c. IO a -> IO b -> IO c -> IO c
bracket_ (Moods -> String -> IO ()
startPhase Moods
Loud String
phase) (Moods -> String -> IO ()
donePhase Moods
Loud String
phase) (IO ExitCode -> IO ExitCode) -> IO ExitCode -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ String -> IO ExitCode
system String
cmd

applyNonNull :: b -> ([a] -> b) -> [a] -> b
applyNonNull :: b -> ([a] -> b) -> [a] -> b
applyNonNull b
def [a] -> b
_ [] = b
def
applyNonNull b
_   [a] -> b
f [a]
xs = [a] -> b
f [a]
xs

arrow, dcolon :: Doc
arrow :: Doc
arrow              = String -> Doc
text String
"->"
dcolon :: Doc
dcolon             = Doc
colon Doc -> Doc -> Doc
<-> Doc
colon

intersperse :: Doc -> [Doc] -> Doc
intersperse :: Doc -> [Doc] -> Doc
intersperse Doc
d [Doc]
ds   = [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
punctuate Doc
d [Doc]
ds

tshow :: (Show a) => a -> Doc
tshow :: a -> Doc
tshow              = String -> Doc
text (String -> Doc) -> (a -> String) -> a -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show

-- | If loud, write a string to stdout
writeLoud :: String -> IO ()
writeLoud :: String -> IO ()
writeLoud String
s = IO () -> IO ()
whenLoud (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
s IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
stdout

ensurePath :: FilePath -> IO ()
ensurePath :: String -> IO ()
ensurePath = Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (String -> IO ()) -> (String -> String) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
takeDirectory

singleton :: a -> [a]
singleton :: a -> [a]
singleton a
x = [a
x]

pair :: a -> a -> [a]
pair :: a -> a -> [a]
pair a
x1 a
x2 = [a
x1, a
x2]

triple :: a -> a -> a -> [a]
triple :: a -> a -> a -> [a]
triple a
x1 a
x2 a
x3 = [a
x1, a
x2, a
x3]


fM :: (Monad m) => (a -> b) -> a -> m b
fM :: (a -> b) -> a -> m b
fM a -> b
f = b -> m b
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> m b) -> (a -> b) -> a -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f

whenM :: (Monad m) => m Bool -> m () -> m ()
whenM :: m Bool -> m () -> m ()
whenM m Bool
cond m ()
act = do
  Bool
b <- m Bool
cond
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
b m ()
act

ifM :: (Monad m) => m Bool -> m a -> m a -> m a 
ifM :: m Bool -> m a -> m a -> m a
ifM m Bool
c m a
t m a
e = do 
  Bool
b <- m Bool
c 
  if Bool
b then m a
t else m a
e 

mapEither :: (a -> Either b c) -> [a] -> ([b], [c])
mapEither :: (a -> Either b c) -> [a] -> ([b], [c])
mapEither a -> Either b c
_ []     = ([], [])
mapEither a -> Either b c
f (a
x:[a]
xs) = case a -> Either b c
f a
x of
                       Left b
y  -> (b
yb -> [b] -> [b]
forall a. a -> [a] -> [a]
:[b]
ys, [c]
zs)
                       Right c
z -> ([b]
ys, c
zc -> [c] -> [c]
forall a. a -> [a] -> [a]
:[c]
zs)
                     where
                       ([b]
ys, [c]
zs) = (a -> Either b c) -> [a] -> ([b], [c])
forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
mapEither a -> Either b c
f [a]
xs

isRight :: Either a b -> Bool 
isRight :: Either a b -> Bool
isRight (Right b
_) = Bool
True 
isRight Either a b
_         = Bool
False

componentsWith :: (Ord c) => (a -> [(b, c, [c])]) -> a -> [[b]]
componentsWith :: (a -> [(b, c, [c])]) -> a -> [[b]]
componentsWith a -> [(b, c, [c])]
eF a
x = (Int -> b) -> [Int] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map ((b, c, [c]) -> b
forall a b c. (a, b, c) -> a
fst3 ((b, c, [c]) -> b) -> (Int -> (b, c, [c])) -> Int -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> (b, c, [c])
f) ([Int] -> [b]) -> [[Int]] -> [[b]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Int]]
vss
  where
    (Graph
g,Int -> (b, c, [c])
f,c -> Maybe Int
_)         = [(b, c, [c])] -> (Graph, Int -> (b, c, [c]), c -> Maybe Int)
forall key node.
Ord key =>
[(node, key, [key])]
-> (Graph, Int -> (node, key, [key]), key -> Maybe Int)
G.graphFromEdges ([(b, c, [c])] -> (Graph, Int -> (b, c, [c]), c -> Maybe Int))
-> (a -> [(b, c, [c])])
-> a
-> (Graph, Int -> (b, c, [c]), c -> Maybe Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [(b, c, [c])]
eF (a -> (Graph, Int -> (b, c, [c]), c -> Maybe Int))
-> a -> (Graph, Int -> (b, c, [c]), c -> Maybe Int)
forall a b. (a -> b) -> a -> b
$ a
x
    vss :: [[Int]]
vss             = Tree Int -> [Int]
forall a. Tree a -> [a]
T.flatten (Tree Int -> [Int]) -> [Tree Int] -> [[Int]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Graph -> [Tree Int]
G.components Graph
g

topoSortWith :: (Ord v) => (a -> (v, [v])) -> [a] -> [a]
topoSortWith :: (a -> (v, [v])) -> [a] -> [a]
topoSortWith a -> (v, [v])
vF [a]
xs = (a, v, [v]) -> a
forall a b c. (a, b, c) -> a
fst3 ((a, v, [v]) -> a) -> (Int -> (a, v, [v])) -> Int -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> (a, v, [v])
f (Int -> a) -> [Int] -> [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Graph -> [Int]
G.topSort Graph
g
  where
    (Graph
g, Int -> (a, v, [v])
f, v -> Maybe Int
_)      = [(a, v, [v])] -> (Graph, Int -> (a, v, [v]), v -> Maybe Int)
forall key node.
Ord key =>
[(node, key, [key])]
-> (Graph, Int -> (node, key, [key]), key -> Maybe Int)
G.graphFromEdges [(a, v, [v])]
es
    es :: [(a, v, [v])]
es             = [ (a
x, v
ux, [v]
vxs) | a
x <- [a]
xs, let (v
ux, [v]
vxs) = a -> (v, [v])
vF a
x ]

-- |
-- >>> let em = M.fromList [ (1, [2, 3]), (2, [1, 3]), (3, []   ) ]
-- >>> let ef = \v -> (v, M.lookupDefault [] v em)
-- >>> sccsWith ef [1,2,3]  
-- [[3],[1,2]] 

sccsWith :: (Ord v) => (a -> (v, [v])) -> [a] -> [[a]]
sccsWith :: (a -> (v, [v])) -> [a] -> [[a]]
sccsWith a -> (v, [v])
vF [a]
xs     = (Int -> a) -> [Int] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map ((a, v, [v]) -> a
forall a b c. (a, b, c) -> a
fst3 ((a, v, [v]) -> a) -> (Int -> (a, v, [v])) -> Int -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> (a, v, [v])
f) ([Int] -> [a]) -> [[Int]] -> [[a]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Tree Int -> [Int]
forall a. Tree a -> [a]
T.flatten (Tree Int -> [Int]) -> [Tree Int] -> [[Int]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Graph -> [Tree Int]
G.scc Graph
g)
  where
    (Graph
g, Int -> (a, v, [v])
f, v -> Maybe Int
_)      = [(a, v, [v])] -> (Graph, Int -> (a, v, [v]), v -> Maybe Int)
forall key node.
Ord key =>
[(node, key, [key])]
-> (Graph, Int -> (node, key, [key]), key -> Maybe Int)
G.graphFromEdges [(a, v, [v])]
es
    es :: [(a, v, [v])]
es             = [ (a
x, v
ux, [v]
vxs) | a
x <- [a]
xs, let (v
ux, [v]
vxs) = a -> (v, [v])
vF a
x ]


-- >>> exTopo
-- >>> [1,2,4,6,5,3]
exTopo  :: [Int]
exTopo :: [Int]
exTopo  = (Int -> (Int, [Int])) -> [Int] -> [Int]
forall v a. Ord v => (a -> (v, [v])) -> [a] -> [a]
topoSortWith Int -> (Int, [Int])
forall a a. (Eq a, Num a, Num a) => a -> (a, [a])
f [Int
1,Int
2,Int
3,Int
4,Int
5,Int
6]
  where
    f :: a -> (a, [a])
f a
1 = (a
1, [a
2, a
3])
    f a
2 = (a
2, [a
3, a
4])
    f a
3 = (a
3, []    )
    f a
4 = (a
4, [a
5, a
6])
    f a
5 = (a
5, []    )
    f a
6 = (a
6, [a
3]   )
    f a
n = (a
n, []    )


type EqHash a = (Eq a, Ord a, Hashable a)

-- >>> coalesce [[1], [2,1], [5], [5, 6], [5, 7], [9, 6], [10], [10,100]]
-- [[1,2],[5,7,6,9],[10,100]]

coalesce :: (EqHash v) => [ListNE v] -> [ListNE v]
coalesce :: [ListNE v] -> [ListNE v]
coalesce = ([ListNE v] -> [(v, v, ListNE v)]) -> [ListNE v] -> [ListNE v]
forall c a b. Ord c => (a -> [(b, c, [c])]) -> a -> [[b]]
componentsWith [ListNE v] -> [(v, v, ListNE v)]
forall v. EqHash v => [ListNE v] -> [(v, v, ListNE v)]
coalesceEdges

coalesceEdges :: (EqHash v) => [ListNE v] -> [(v, v, [v])]
coalesceEdges :: [ListNE v] -> [(v, v, ListNE v)]
coalesceEdges [ListNE v]
vss = [ (v
u, v
u, ListNE v
vs) | (v
u, ListNE v
vs) <- [(v, v)] -> [(v, ListNE v)]
forall k v. (Eq k, Hashable k) => [(k, v)] -> [(k, [v])]
groupList ([(v, v)]
uvs [(v, v)] -> [(v, v)] -> [(v, v)]
forall a. [a] -> [a] -> [a]
++ [(v, v)]
vus) ]
  where
    vus :: [(v, v)]
vus           = (v, v) -> (v, v)
forall a b. (a, b) -> (b, a)
swap ((v, v) -> (v, v)) -> [(v, v)] -> [(v, v)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(v, v)]
uvs
    uvs :: [(v, v)]
uvs           = [ (v
u, v
v) | (v
u : ListNE v
vs) <- [ListNE v]
vss, v
v <- ListNE v
vs ]

{-
exitColorStrLn :: Moods -> String -> IO ()
exitColorStrLn c s = do
  writeIORef pbRef Nothing --(Just pr)
  putStrLn "\n"
  colorStrLn c s
-}

mapFst :: (a -> c) -> (a, b) -> (c, b)
mapFst :: (a -> c) -> (a, b) -> (c, b)
mapFst a -> c
f (a
x, b
y) = (a -> c
f a
x, b
y)

mapSnd :: (b -> c) -> (a, b) -> (a, c)
mapSnd :: (b -> c) -> (a, b) -> (a, c)
mapSnd b -> c
f (a
x, b
y) = (a
x, b -> c
f b
y)


{-@ allCombinations :: xss:[[a]] -> [{v:[a]| len v == len xss}] @-}
allCombinations :: [[a]] -> [[a]]
allCombinations :: [[a]] -> [[a]]
allCombinations [[a]]
xs = ([[a]] -> Bool) -> [[a]] -> [[a]]
forall p. (p -> Bool) -> p -> p
assert ([Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> ([[a]] -> [Bool]) -> [[a]] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([a] -> Bool) -> [[a]] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map ((([[a]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[a]]
xs) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== ) (Int -> Bool) -> ([a] -> Int) -> [a] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length)) ([[a]] -> [[a]]) -> [[a]] -> [[a]]
forall a b. (a -> b) -> a -> b
$ [[a]] -> [[a]]
forall a. [[a]] -> [[a]]
go [[a]]
xs
  where
   go :: [[a]] -> [[a]]
go []          = [[]]
   go [[]]        = []
   go ([]:[[a]]
_)      = []
   go ((a
x:[a]
xs):[[a]]
ys) = ((a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ([a] -> [a]) -> [[a]] -> [[a]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[a]] -> [[a]]
go [[a]]
ys) [[a]] -> [[a]] -> [[a]]
forall a. [a] -> [a] -> [a]
++ [[a]] -> [[a]]
go ([a]
xs[a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
:[[a]]
ys)

   assert :: (p -> Bool) -> p -> p
assert p -> Bool
b p
x = if p -> Bool
b p
x then p
x else String -> p
forall a. HasCallStack => String -> a
errorstar String
"allCombinations: assertion violation"

powerset :: [a] -> [[a]]
powerset :: [a] -> [[a]]
powerset [a]
xs = (a -> [Bool]) -> [a] -> [[a]]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM ([Bool] -> a -> [Bool]
forall a b. a -> b -> a
const [Bool
False, Bool
True]) [a]
xs

(=>>) :: Monad m => m b -> (b -> m a) -> m b
=>> :: m b -> (b -> m a) -> m b
(=>>) m b
m b -> m a
f = m b
m m b -> (b -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\b
x -> b -> m a
f b
x m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> b -> m b
forall (m :: * -> *) a. Monad m => a -> m a
return b
x)

(<<=) :: Monad m => (b -> m a) -> m b -> m b
<<= :: (b -> m a) -> m b -> m b
(<<=) = (m b -> (b -> m a) -> m b) -> (b -> m a) -> m b -> m b
forall a b c. (a -> b -> c) -> b -> a -> c
flip m b -> (b -> m a) -> m b
forall (m :: * -> *) b a. Monad m => m b -> (b -> m a) -> m b
(=>>)

(<$$>) ::  (Monad m) => (a -> m b) -> [a] -> m [b]
a -> m b
_ <$$> :: (a -> m b) -> [a] -> m [b]
<$$> []           = [b] -> m [b]
forall (m :: * -> *) a. Monad m => a -> m a
return []
a -> m b
f <$$> [a
x1]         = b -> [b]
forall a. a -> [a]
singleton (b -> [b]) -> m b -> m [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> m b
f a
x1
a -> m b
f <$$> [a
x1, a
x2]     = b -> b -> [b]
forall a. a -> a -> [a]
pair      (b -> b -> [b]) -> m b -> m (b -> [b])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> m b
f a
x1 m (b -> [b]) -> m b -> m [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> a -> m b
f a
x2
a -> m b
f <$$> [a
x1, a
x2, a
x3] = b -> b -> b -> [b]
forall a. a -> a -> a -> [a]
triple    (b -> b -> b -> [b]) -> m b -> m (b -> b -> [b])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> m b
f a
x1 m (b -> b -> [b]) -> m b -> m (b -> [b])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> a -> m b
f a
x2 m (b -> [b]) -> m b -> m [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> a -> m b
f a
x3
a -> m b
f <$$> [a]
xs           = (a -> m b) -> [a] -> m [b]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
revMapM a -> m b
f ({- trace msg -} [a]
xs)
  where
    _msg :: String
_msg            = String
"<$$> on " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs)

revMapM  :: (Monad m) => (a -> m b) -> [a] -> m [b]
revMapM :: (a -> m b) -> [a] -> m [b]
revMapM a -> m b
f          = [b] -> [a] -> m [b]
go []
  where
    go :: [b] -> [a] -> m [b]
go ![b]
acc []     = [b] -> m [b]
forall (m :: * -> *) a. Monad m => a -> m a
return ([b] -> [b]
forall a. [a] -> [a]
reverse [b]
acc)
    go ![b]
acc (a
x:[a]
xs) = do {!b
y <- a -> m b
f a
x; [b] -> [a] -> m [b]
go (b
yb -> [b] -> [b]
forall a. a -> [a] -> [a]
:[b]
acc) [a]
xs}

-- Null if first is a subset of second
nubDiff :: (Eq a, Hashable a) => [a] -> [a] -> S.HashSet a 
nubDiff :: [a] -> [a] -> HashSet a
nubDiff [a]
a [a]
b = HashSet a
a' HashSet a -> HashSet a -> HashSet a
forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
`S.difference` HashSet a
b'
  where
    a' :: HashSet a
a' = [a] -> HashSet a
forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList [a]
a
    b' :: HashSet a
b' = [a] -> HashSet a
forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList [a]
b


fold1M :: (Monad m) => (a -> a -> m a) -> [a] -> m a 
fold1M :: (a -> a -> m a) -> [a] -> m a
fold1M a -> a -> m a
_ []         = String -> m a
forall a. HasCallStack => String -> a
errorstar (String -> m a) -> String -> m a
forall a b. (a -> b) -> a -> b
$ String
"fold1M with empty list"
fold1M a -> a -> m a
_ [a
x]        = a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x 
fold1M a -> a -> m a
f (a
x1:a
x2:[a]
xs) = do { a
x <- a -> a -> m a
f a
x1 a
x2; (a -> a -> m a) -> [a] -> m a
forall (m :: * -> *) a. Monad m => (a -> a -> m a) -> [a] -> m a
fold1M a -> a -> m a
f (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs) }