{-# 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

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 = forall a. [a] -> Maybe a
listToMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a. IO a -> IO (Async a)
async forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> IO b
f) [a]
xs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM 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 = forall a. [Char] -> a -> a
trace ([Char]
"\nTrace: [" forall a. [a] -> [a] -> [a]
++ [Char]
s forall a. [a] -> [a] -> [a]
++ [Char]
"] : " forall a. [a] -> [a] -> [a]
++ 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 = forall a. (a -> a -> Ordering) -> [a] -> [a]
L.sortBy (forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a b. (a, b) -> a
fst) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall k v. Ord k => [(k, v)] -> Maybe v
argMin [ (forall a. Num a => a -> a
abs (i
key 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe a
headMb forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Ordering) -> [a] -> [a]
L.sortBy (forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a b. (a, b) -> a
fst)

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

getUniqueInt :: IO Int
getUniqueInt :: IO Int
getUniqueInt = do
  Int
n1 <- Unique -> Int
hashUnique forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Unique
newUnique
  Int
n2 <- Unique -> Int
hashUnique forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Unique
newUnique
  forall (m :: * -> *) a. Monad m => a -> m a
return (Int
n1 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 forall i e. Ix i => Array i e -> i -> e
! (Int
m, Int
n)
    where
    (Int
m,Int
n) = (forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs, forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
ys)
    x :: Array Int a
x     = forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array (Int
1,Int
m) (forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] [a]
xs)
    y :: Array Int a
y     = forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array (Int
1,Int
n) (forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] [a]
ys)

    table :: Array (Int,Int) Int
    table :: Array (Int, Int) Int
table = forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array 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 <- forall a. Ix a => (a, a) -> [a]
range 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) = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [Array (Int, Int) Int
table forall i e. Ix i => Array i e -> i -> e
! (Int
iforall a. Num a => a -> a -> a
-Int
1,Int
j) forall a. Num a => a -> a -> a
+ Int
1, Array (Int, Int) Int
table forall i e. Ix i => Array i e -> i -> e
! (Int
i,Int
jforall a. Num a => a -> a -> a
-Int
1) forall a. Num a => a -> a -> a
+ Int
1,
        if Array Int a
x forall i e. Ix i => Array i e -> i -> e
! Int
i forall a. Eq a => a -> a -> Bool
== Array Int a
y forall i e. Ix i => Array i e -> i -> e
! Int
j then Array (Int, Int) Int
table forall i e. Ix i => Array i e -> i -> e
! (Int
iforall a. Num a => a -> a -> a
-Int
1,Int
jforall a. Num a => a -> a -> a
-Int
1) else Int
1 forall a. Num a => a -> a -> a
+ Array (Int, Int) Int
table forall i e. Ix i => Array i e -> i -> e
! (Int
iforall a. Num a => a -> a -> a
-Int
1,Int
jforall 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**** " forall a. [a] -> [a] -> [a]
++ [Char]
msg forall a. [a] -> [a] -> [a]
++ [Char]
" " forall a. [a] -> [a] -> [a]
++ forall a. Int -> a -> [a]
replicate (Int
74 forall a. Num a => a -> a -> a
- 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) 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
wrapStars forall b c a. (b -> c) -> (a -> b) -> a -> c
.  ([Char]
msg 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 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 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 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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]
"") forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
stdout
      [[Char]]
_      -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

putBlankLn :: IO ()
putBlankLn :: IO ()
putBlankLn = [Char] -> IO ()
putStrLn [Char]
"" 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 forall a. [a] -> [a] -> [a]
++ [a]
s forall a. [a] -> [a] -> [a]
++ [a]
r

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


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

errorstar :: (?callStack :: CallStack) => String -> a
errorstar :: forall a. HasCallStack => [Char] -> a
errorstar  = forall a. HasCallStack => [Char] -> a
error forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a] -> [a] -> [a]
wrap ([Char]
stars forall a. [a] -> [a] -> [a]
++ [Char]
"\n") ([Char]
stars forall a. [a] -> [a] -> [a]
++ [Char]
"\n")
  where
    stars :: [Char]
stars = forall a. Int -> [a] -> [a]
repeats Int
3 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,) 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 = forall a. a -> Maybe a -> a
fromMaybe forall {a}. a
err forall a b. (a -> b) -> a -> b
$ 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     = forall a. HasCallStack => [Char] -> a
errorstar forall a b. (a -> b) -> a -> b
$ [Char]
"mlookup: unknown key " forall a. [a] -> [a] -> [a]
++ 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   = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => [Char] -> a
errorstar [Char]
msg) (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  = forall a. HasCallStack => [Char] -> a
errorstar forall a b. (a -> b) -> a -> b
$ [Char]
"mfromJust: Nothing " 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 = forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v
M.insertWith (forall a b. a -> b -> a
const (v
vforall 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 = forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v
M.insertWith (forall a b. a -> b -> a
const (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 = forall k v. HashMap k v -> [(k, v)]
M.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k [v]
group forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall k v.
(Eq k, Hashable k) =>
HashMap k [v] -> [(k, v)] -> HashMap k [v]
groupBase 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 = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl' (\HashMap k [v]
m (k
k, v
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 = forall k v. HashMap k v -> [(k, v)]
M.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl' (\HashMap k [a]
m a
x -> 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) 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 = 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 = forall a. Set a -> [a]
Set.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> Set a
Set.fromList

sortNub :: (Ord a) => [a] -> [a]
sortNub :: forall k. Ord k => [k] -> [k]
sortNub = forall a. Eq a => [a] -> [a]
nubOrd forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall a. Eq a => [a] -> [a]
nubOrd forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a. Eq a => a -> a -> Bool
== a
y    = forall a. Eq a => [a] -> [a]
nubOrd [a]
t
  | Bool
otherwise = a
x forall 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 = forall k a. Map k a -> [a]
Map.elems forall a b. (a -> b) -> a -> b
$ 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 = 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) <- forall k. (Eq k, Hashable k) => [k] -> [(k, Int)]
count [k]
xs, Int
1 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 forall a. Eq a => a -> a -> Bool
== Int
nys
  = forall a b. [a] -> [b] -> [(a, b)]
zip [a]
xs [b]
ys
  | Bool
otherwise
  = forall a. HasCallStack => [Char] -> a
errorstar forall a b. (a -> b) -> a -> b
$ [Char]
"safeZip called on non-eq-sized lists (nxs = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
nxs forall a. [a] -> [a] -> [a]
++ [Char]
", nys = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
nys forall a. [a] -> [a] -> [a]
++ [Char]
") : " forall a. [a] -> [a] -> [a]
++ [Char]
msg
  where
    nxs :: Int
nxs = forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs
    nys :: Int
nys = 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 forall a. Eq a => a -> a -> Bool
== Int
nys
  = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith a -> b -> c
f [a]
xs [b]
ys
  | Bool
otherwise
  = forall a. HasCallStack => [Char] -> a
errorstar forall a b. (a -> b) -> a -> b
$ [Char]
"safeZipWith called on non-eq-sized lists (nxs = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
nxs forall a. [a] -> [a] -> [a]
++ [Char]
", nys = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
nys forall a. [a] -> [a] -> [a]
++ [Char]
") : " forall a. [a] -> [a] -> [a]
++ [Char]
msg
    where nxs :: Int
nxs = forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs
          nys :: Int
nys = 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 = forall b a. b -> ([a] -> b) -> [a] -> b
applyNonNull (forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
M.fromList [(k, v)]
kvs) forall {a} {c}. Show a => a -> c
err [k]
dups
  where
    -- dups             = duplicates . fmap fst
    dups :: [k]
dups             = [ k
x | (k
x, Int
n) <- forall k. (Eq k, Hashable k) => [k] -> [(k, Int)]
count (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(k, v)]
kvs), Int
1 forall a. Ord a => a -> a -> Bool
< Int
n ]
    err :: a -> c
err              = forall a. HasCallStack => [Char] -> a
errorstar forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char] -> [Char] -> [Char]
wrapMsg [Char]
"safeFromList with duplicates" [Char]
msg forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show
    wrapMsg :: [Char] -> [Char] -> [Char] -> [Char]
wrapMsg [Char]
m1 [Char]
m2 [Char]
s     = [Char]
m1 forall a. [a] -> [a] -> [a]
++ [Char]
" " forall a. [a] -> [a] -> [a]
++ [Char]
s forall a. [a] -> [a] -> [a]
++ [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]
_     = forall a. HasCallStack => [Char] -> a
errorstar forall a b. (a -> b) -> a -> b
$ [Char]
"safeHead with empty list " forall a. [a] -> [a] -> [a]
++ [Char]
msg

safeLast :: forall a. HasCallStack => [Char] -> ListNE a -> a
safeLast [Char]
_ xs :: ListNE a
xs@(a
_:ListNE a
_) = forall a. [a] -> a
last ListNE a
xs
safeLast [Char]
msg ListNE a
_      = forall a. HasCallStack => [Char] -> a
errorstar forall a b. (a -> b) -> a -> b
$ [Char]
"safeLast with empty list " 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
_) = forall a. [a] -> [a]
init ListNE a
xs
safeInit [Char]
msg ListNE a
_      = forall a. HasCallStack => [Char] -> a
errorstar forall a b. (a -> b) -> a -> b
$ [Char]
"safeInit with empty list " 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]
_    = forall a. HasCallStack => [Char] -> a
errorstar forall a b. (a -> b) -> a -> b
$ [Char]
"safeUncons with empty list " forall a. [a] -> [a] -> [a]
++ [Char]
msg

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

executeShellCommand :: String -> String -> IO ExitCode
executeShellCommand :: [Char] -> [Char] -> IO ExitCode
executeShellCommand [Char]
phase [Char]
cmd
  = do [Char] -> IO ()
writeLoud forall a b. (a -> b) -> a -> b
$ [Char]
"EXEC: " forall a. [a] -> [a] -> [a]
++ [Char]
cmd
       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) 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 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
s 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 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 = forall (m :: * -> *) a. Monad m => a -> m a
return 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
  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

mapEither :: (a -> Either b c) -> [a] -> ([b], [c])
mapEither :: forall a b c. (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
yforall a. a -> [a] -> [a]
:[b]
ys, [c]
zs)
                       Right c
z -> ([b]
ys, c
zforall a. a -> [a] -> [a]
:[c]
zs)
                     where
                       ([b]
ys, [c]
zs) = 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 :: forall a b. 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 :: forall c a b. Ord c => (a -> [(b, c, [c])]) -> a -> [[b]]
componentsWith a -> [(b, c, [c])]
eF a
x = forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a, b, c) -> a
fst3 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> (b, c, [c])
f) 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
_)         = forall key node.
Ord key =>
[(node, key, [key])]
-> (Graph, Int -> (node, key, [key]), key -> Maybe Int)
G.graphFromEdges forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [(b, c, [c])]
eF forall a b. (a -> b) -> a -> b
$ a
x
    vss :: [[Int]]
vss             = forall a. Tree a -> [a]
T.flatten forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Graph -> Forest 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 = forall a b c. (a, b, c) -> a
fst3 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> (a, v, [v])
f 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
_)      = 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     = forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a, b, c) -> a
fst3 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> (a, v, [v])
f) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. Tree a -> [a]
T.flatten forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Graph -> Forest Int
G.scc Graph
g)
  where
    (Graph
g, Int -> (a, v, [v])
f, 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  = forall v a. Ord v => (a -> (v, [v])) -> [a] -> [a]
topoSortWith 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 = forall c a b. Ord c => (a -> [(b, c, [c])]) -> a -> [[b]]
componentsWith 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) <- forall k v. (Eq k, Hashable k) => [(k, v)] -> [(k, [v])]
groupList ([(v, v)]
uvs forall a. [a] -> [a] -> [a]
++ [(v, v)]
vus) ]
  where
    vus :: [(v, v)]
vus           = forall a b. (a, b) -> (b, a)
swap 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 :: forall a c b. (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 :: forall b c a. (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 :: forall a. [[a]] -> [[a]]
allCombinations [[a]]
xs = forall {t}. (t -> Bool) -> t -> t
assert (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((forall (t :: * -> *) a. Foldable t => t a -> Int
length [[a]]
xs forall a. Eq a => a -> a -> Bool
== ) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Int
length)) forall a b. (a -> b) -> a -> b
$ forall a. [[a]] -> [[a]]
go [[a]]
xs
  where
   go :: [[a]] -> [[a]]
go []           = [[]]
   go [[]]         = []
   go ([]:[[a]]
_)       = []
   go ((a
x:[a]
xs'):[[a]]
ys) = ((a
xforall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[a]] -> [[a]]
go [[a]]
ys) forall a. [a] -> [a] -> [a]
++ [[a]] -> [[a]]
go ([a]
xs'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 forall a. HasCallStack => [Char] -> a
errorstar [Char]
"allCombinations: assertion violation"

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

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

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

-- 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' forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
`S.difference` HashSet a
b'
  where
    a' :: HashSet a
a' = forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList [a]
a
    b' :: HashSet a
b' = 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
_ []         = forall a. HasCallStack => [Char] -> a
errorstar [Char]
"fold1M with empty list"
fold1M a -> a -> m a
_ [a
x]        = 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; forall (m :: * -> *) a. Monad m => (a -> a -> m a) -> [a] -> m a
fold1M a -> a -> m a
f (a
xforall a. a -> [a] -> [a]
:[a]
xs) }