{-# LANGUAGE CPP #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings         #-}
{-# LANGUAGE ScopedTypeVariables       #-}
{-# LANGUAGE TupleSections             #-}
{-# LANGUAGE ConstraintKinds           #-}
{-# LANGUAGE TypeOperators             #-}
{-# 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 qualified Data.Map                         as Map
import qualified Data.Set                         as Set
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

infixl 9 ==>
(==>) :: Bool -> Bool -> Bool
Bool
p ==> :: Bool -> Bool -> Bool
==> Bool
q = Bool -> Bool
not Bool
p Bool -> Bool -> Bool
|| Bool
q

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

firstMaybe :: (a -> Maybe b) -> [a] -> Maybe b
firstMaybe :: forall a b. (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 :: forall a b. (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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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 a b. IO a -> (a -> 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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Async b -> IO b
forall a. Async a -> IO a
wait

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

hashMapToAscList :: Ord a => M.HashMap a b -> [(a, b)]
hashMapToAscList :: forall a b. Ord a => 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 :: forall i a. (Ord i, Num i) => 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 :: forall k v. Ord k => [(k, v)] -> Maybe v
argMin = ((k, v) -> v) -> Maybe (k, v) -> Maybe v
forall a b. (a -> b) -> Maybe a -> Maybe b
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 :: forall a. [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 a. a -> IO a
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 --------------------------------------------
---------------------------------------------------------------

{-# SCC editDistance #-}
editDistance :: Eq a => [a] -> [a] -> Int
editDistance :: forall a. Eq a => [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 a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs, [a] -> Int
forall a. [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 a. Ord a => [a] -> a
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 :: [Char] -> [Char]
wrapStars [Char]
msg = [Char]
"\n**** " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
msg [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate (Int
74 Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
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 -> [Char] -> IO ()
colorStrLn Moods
c       = Color -> IO () -> IO ()
withColor (Moods -> Color
moodColor Moods
c) (IO () -> IO ()) -> ([Char] -> IO ()) -> [Char] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IO ()
putStrLn

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

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

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

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

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

--------------------------------------------------------------------------------
wrap :: [a] -> [a] -> [a] -> [a]
wrap :: forall a. [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 :: forall a. 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 :: forall a. [Char] -> [Char] -> a
errorP [Char]
p [Char]
s = [Char] -> a
forall a. HasCallStack => [Char] -> a
error ([Char]
p [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s)

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

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

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

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

secondM :: Functor f => (b -> f c) -> (a, b) -> f (a, c)
secondM :: forall (f :: * -> *) b c a.
Functor f =>
(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 :: forall k v.
(HasCallStack, Eq k, Show k, Hashable k) =>
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     = [Char] -> a
forall a. HasCallStack => [Char] -> a
errorstar ([Char] -> a) -> [Char] -> a
forall a b. (a -> b) -> a -> b
$ [Char]
"mlookup: unknown key " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ k -> [Char]
forall a. Show a => a -> [Char]
show k
k

safeLookup :: forall k v.
(HasCallStack, Eq k, Hashable k) =>
[Char] -> k -> HashMap k v -> v
safeLookup [Char]
msg k
k HashMap k v
m   = v -> Maybe v -> v
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> v
forall a. HasCallStack => [Char] -> a
errorstar [Char]
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 :: forall a. HasCallStack => [Char] -> Maybe a -> a
mfromJust [Char]
_ (Just a
x) = a
x
mfromJust [Char]
s Maybe a
Nothing  = [Char] -> a
forall a. HasCallStack => [Char] -> a
errorstar ([Char] -> a) -> [Char] -> a
forall a b. (a -> b) -> a -> b
$ [Char]
"mfromJust: Nothing " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s

inserts ::  (Eq k, Hashable k) => k -> v -> M.HashMap k [v] -> M.HashMap k [v]
inserts :: forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k [v] -> HashMap k [v]
inserts k
k v
v HashMap k [v]
m = ([v] -> [v] -> [v]) -> k -> [v] -> HashMap k [v] -> HashMap k [v]
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v
M.insertWith (([v] -> [v]) -> [v] -> [v] -> [v]
forall a b. a -> b -> a
const (v
vv -> [v] -> [v]
forall a. a -> [a] -> [a]
:)) k
k [v
v] HashMap k [v]
m

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

count :: (Eq k, Hashable k) => [k] -> [(k, Int)]
count :: forall k. (Eq k, Hashable k) => [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 a b. (a -> b) -> HashMap k a -> HashMap k b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Int] -> Int
forall a. Num a => [a] -> a
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 a b. (a -> b) -> [a] -> [b]
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 :: forall k v. (Eq k, Hashable k) => [(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 :: forall k v.
(Eq k, Hashable k) =>
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 b a. (b -> a -> b) -> b -> [a] -> b
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 :: forall k v. (Eq k, Hashable k) => [(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 :: forall k a. (Eq k, Hashable k) => (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 b a. (b -> a -> b) -> b -> [a] -> b
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 :: forall k v.
(Eq k, Hashable k) =>
(v -> Bool) -> HashMap k v -> Bool
allMap v -> Bool
p = (Bool -> v -> Bool) -> Bool -> HashMap k v -> Bool
forall b a. (b -> a -> b) -> b -> HashMap k a -> b
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

setNub :: Ord k => [k] -> [k]
setNub :: forall k. Ord k => [k] -> [k]
setNub = Set k -> [k]
forall a. Set a -> [a]
Set.toList (Set k -> [k]) -> ([k] -> Set k) -> [k] -> [k]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [k] -> Set k
forall a. Ord a => [a] -> Set a
Set.fromList

sortNub :: (Ord a) => [a] -> [a]
sortNub :: forall k. Ord k => [k] -> [k]
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 k. Ord k => [k] -> [k]
L.sort

sortNubBy :: (Eq a) => (a -> a -> Ordering) -> [a] -> [a]
sortNubBy :: forall a. Eq a => (a -> a -> Ordering) -> [a] -> [a]
sortNubBy a -> a -> Ordering
f = [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 -> Ordering) -> [a] -> [a]
forall a. (a -> a -> Ordering) -> [a] -> [a]
L.sortBy a -> a -> Ordering
f

nubOrd :: (Eq a) => [a] -> [a]
nubOrd :: forall a. Eq a => [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 :: Ord b => (a -> b) -> [a] -> [a]
hashNubWith :: forall b a. Ord b => (a -> b) -> [a] -> [a]
hashNubWith a -> b
f [a]
xs = Map b a -> [a]
forall k a. Map k a -> [a]
Map.elems (Map b a -> [a]) -> Map b a -> [a]
forall a b. (a -> b) -> a -> b
$ [(b, a)] -> Map b a
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (a -> b
f a
x, a
x) | a
x <- [a]
xs ]

mFromList :: (Eq k, Hashable k) => [(k, v)] -> M.HashMap k v
mFromList :: forall k v. (Eq k, Hashable k) => [(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 :: forall k. (Eq k, Hashable k) => [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 :: forall a b. HasCallStack => [Char] -> [a] -> [b] -> [(a, b)]
safeZip [Char]
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
  = [Char] -> [(a, b)]
forall a. HasCallStack => [Char] -> a
errorstar ([Char] -> [(a, b)]) -> [Char] -> [(a, b)]
forall a b. (a -> b) -> a -> b
$ [Char]
"safeZip called on non-eq-sized lists (nxs = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
nxs [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", nys = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
nys [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
") : " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
msg
  where
    nxs :: Int
nxs = [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs
    nys :: Int
nys = [b] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [b]
ys

safeZipWith :: forall a b c.
HasCallStack =>
[Char] -> (a -> b -> c) -> [a] -> [b] -> [c]
safeZipWith [Char]
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
  = [Char] -> [c]
forall a. HasCallStack => [Char] -> a
errorstar ([Char] -> [c]) -> [Char] -> [c]
forall a b. (a -> b) -> a -> b
$ [Char]
"safeZipWith called on non-eq-sized lists (nxs = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
nxs [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", nys = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
nys [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
") : " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
msg
    where nxs :: Int
nxs = [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs
          nys :: Int
nys = [b] -> Int
forall a. [a] -> 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 :: forall k v.
(HasCallStack, Eq k, Hashable k, Show k) =>
[Char] -> [(k, v)] -> HashMap k v
safeFromList [Char]
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              = [Char] -> c
forall a. HasCallStack => [Char] -> a
errorstar ([Char] -> c) -> (a -> [Char]) -> a -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char] -> [Char] -> [Char]
wrapMsg [Char]
"safeFromList with duplicates" [Char]
msg ([Char] -> [Char]) -> (a -> [Char]) -> a -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [Char]
forall a. Show a => a -> [Char]
show
    wrapMsg :: [Char] -> [Char] -> [Char] -> [Char]
wrapMsg [Char]
m1 [Char]
m2 [Char]
s     = [Char]
m1 [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
m2

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

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

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

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

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

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

applyNonNull :: b -> ([a] -> b) -> [a] -> b
applyNonNull :: forall b a. 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              = [Char] -> Doc
text [Char]
"->"
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 :: forall a. Show a => a -> Doc
tshow              = [Char] -> Doc
text ([Char] -> Doc) -> (a -> [Char]) -> a -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [Char]
forall a. Show a => a -> [Char]
show

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

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

fM :: (Monad m) => (a -> b) -> a -> m b
fM :: forall (m :: * -> *) a b. Monad m => (a -> b) -> a -> m b
fM a -> b
f = b -> m b
forall a. a -> m a
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 :: forall (m :: * -> *). Monad m => 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 :: forall (m :: * -> *) a. Monad m => 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

dbgFalse :: Bool
dbgFalse :: Bool
dbgFalse = Int
1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> (Int
2 :: Int)

componentsWith :: (Ord c) => (a -> [(b, c, [c])]) -> a -> [[b]]
componentsWith :: forall c a b. Ord c => (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 :: forall v a. Ord v => (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 :: forall v a. Ord v => (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 :: forall v. EqHash v => [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 :: forall v. EqHash v => [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 ]

{-@ allCombinations :: xss:[[a]] -> [{v:[a]| len v == len xss}] @-}
allCombinations :: [[a]] -> [[a]]
allCombinations :: forall a. [[a]] -> [[a]]
allCombinations [[a]]
xs = ([[a]] -> Bool) -> [[a]] -> [[a]]
forall {t}. (t -> Bool) -> t -> t
assert (([a] -> Bool) -> [[a]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (([[a]] -> Int
forall a. [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 a. [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 :: (t -> Bool) -> t -> t
assert t -> Bool
b t
x = if t -> Bool
b t
x then t
x else [Char] -> t
forall a. HasCallStack => [Char] -> a
errorstar [Char]
"allCombinations: assertion violation"

powerset :: [a] -> [[a]]
powerset :: forall a. [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

-- Null if first is a subset of second
nubDiff :: (Eq a, Hashable a) => [a] -> [a] -> S.HashSet a
nubDiff :: forall a. (Eq a, Hashable a) => [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 :: forall (m :: * -> *) a. Monad m => (a -> a -> m a) -> [a] -> m a
fold1M a -> a -> m a
_ []         = [Char] -> m a
forall a. HasCallStack => [Char] -> a
errorstar [Char]
"fold1M with empty list"
fold1M a -> a -> m a
_ [a
x]        = a -> m a
forall a. 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) }