-- | Non-Futhark-specific utilities.  If you find yourself writing
-- general functions on generic data structures, consider putting them
-- here.
--
-- Sometimes it is also preferable to copy a small function rather
-- than introducing a large dependency.  In this case, make sure to
-- note where you got it from (and make sure that the license is
-- compatible).
module Futhark.Util
  ( nubOrd,
    nubByOrd,
    mapAccumLM,
    maxinum,
    chunk,
    chunks,
    chunkLike,
    dropAt,
    takeLast,
    dropLast,
    mapEither,
    partitionMaybe,
    maybeNth,
    maybeHead,
    lookupWithIndex,
    splitFromEnd,
    splitAt3,
    focusNth,
    focusMaybe,
    hashText,
    showText,
    unixEnvironment,
    isEnvVarAtLeast,
    startupTime,
    fancyTerminal,
    hFancyTerminal,
    runProgramWithExitCode,
    directoryContents,
    fromPOSIX,
    toPOSIX,
    trim,
    pmapIO,
    interactWithFileSafely,
    convFloat,
    UserText,
    EncodedText,
    zEncodeText,
    atMostChars,
    invertMap,
    cartesian,
    traverseFold,
    fixPoint,
    concatMapM,
    topologicalSort,
  )
where

import Control.Concurrent
import Control.Exception
import Control.Monad
import Control.Monad.State
import Crypto.Hash.MD5 as MD5
import Data.Bifunctor
import Data.ByteString qualified as BS
import Data.ByteString.Base16 qualified as Base16
import Data.Char
import Data.Either
import Data.Foldable (fold, toList)
import Data.Function ((&))
import Data.IntMap qualified as IM
import Data.List (findIndex, foldl', genericDrop, genericSplitAt, sortBy)
import Data.List.NonEmpty qualified as NE
import Data.Map qualified as M
import Data.Maybe
import Data.Set qualified as S
import Data.Text qualified as T
import Data.Text.Encoding qualified as T
import Data.Text.Encoding.Error qualified as T
import Data.Time.Clock (UTCTime, getCurrentTime)
import Data.Tuple (swap)
import Numeric
import System.Directory.Tree qualified as Dir
import System.Environment
import System.Exit
import System.FilePath qualified as Native
import System.FilePath.Posix qualified as Posix
import System.IO (Handle, hIsTerminalDevice, stdout)
import System.IO.Error (isDoesNotExistError)
import System.IO.Unsafe
import System.Process.ByteString
import Text.Read (readMaybe)

-- | Like @nub@, but without the quadratic runtime.
nubOrd :: (Ord a) => [a] -> [a]
nubOrd :: forall a. Ord a => [a] -> [a]
nubOrd = (a -> a -> Ordering) -> [a] -> [a]
forall a. (a -> a -> Ordering) -> [a] -> [a]
nubByOrd a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare

-- | Like @nubBy@, but without the quadratic runtime.
nubByOrd :: (a -> a -> Ordering) -> [a] -> [a]
nubByOrd :: forall a. (a -> a -> Ordering) -> [a] -> [a]
nubByOrd a -> a -> Ordering
cmp = (NonEmpty a -> a) -> [NonEmpty a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map NonEmpty a -> a
forall a. NonEmpty a -> a
NE.head ([NonEmpty a] -> [a]) -> ([a] -> [NonEmpty a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> a -> Bool) -> [a] -> [NonEmpty a]
forall (f :: * -> *) a.
Foldable f =>
(a -> a -> Bool) -> f a -> [NonEmpty a]
NE.groupBy a -> a -> Bool
eq ([a] -> [NonEmpty a]) -> ([a] -> [a]) -> [a] -> [NonEmpty a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> a -> Ordering) -> [a] -> [a]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy a -> a -> Ordering
cmp
  where
    eq :: a -> a -> Bool
eq a
x a
y = a -> a -> Ordering
cmp a
x a
y Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
EQ

-- | Like 'Data.Traversable.mapAccumL', but monadic and generalised to
-- any 'Traversable'.
mapAccumLM ::
  (Monad m, Traversable t) =>
  (acc -> x -> m (acc, y)) ->
  acc ->
  t x ->
  m (acc, t y)
mapAccumLM :: forall (m :: * -> *) (t :: * -> *) acc x y.
(Monad m, Traversable t) =>
(acc -> x -> m (acc, y)) -> acc -> t x -> m (acc, t y)
mapAccumLM acc -> x -> m (acc, y)
op acc
initial t x
l = do
  (t y
l', acc
acc) <- StateT acc m (t y) -> acc -> m (t y, acc)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT ((x -> StateT acc m y) -> t x -> StateT acc m (t y)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> t a -> f (t b)
traverse x -> StateT acc m y
forall {t :: (* -> *) -> * -> *}.
(MonadState acc (t m), MonadTrans t) =>
x -> t m y
f t x
l) acc
initial
  (acc, t y) -> m (acc, t y)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (acc
acc, t y
l')
  where
    f :: x -> t m y
f x
x = do
      acc
acc <- t m acc
forall s (m :: * -> *). MonadState s m => m s
get
      (acc
acc', y
y) <- m (acc, y) -> t m (acc, y)
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (acc, y) -> t m (acc, y)) -> m (acc, y) -> t m (acc, y)
forall a b. (a -> b) -> a -> b
$ acc -> x -> m (acc, y)
op acc
acc x
x
      acc -> t m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put acc
acc'
      y -> t m y
forall a. a -> t m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure y
y

-- | @chunk n a@ splits @a@ into @n@-size-chunks.  If the length of
-- @a@ is not divisible by @n@, the last chunk will have fewer than
-- @n@ elements (but it will never be empty).
chunk :: Int -> [a] -> [[a]]
chunk :: forall a. Int -> [a] -> [[a]]
chunk Int
_ [] = []
chunk Int
n [a]
xs =
  let ([a]
bef, [a]
aft) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n [a]
xs
   in [a]
bef [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: Int -> [a] -> [[a]]
forall a. Int -> [a] -> [[a]]
chunk Int
n [a]
aft

-- | @chunks ns a@ splits @a@ into chunks determined by the elements
-- of @ns@.  It must hold that @sum ns == length a@, or the resulting
-- list may contain too few chunks, or not all elements of @a@.
chunks :: [Int] -> [a] -> [[a]]
chunks :: forall a. [Int] -> [a] -> [[a]]
chunks [] [a]
_ = []
chunks (Int
n : [Int]
ns) [a]
xs =
  let ([a]
bef, [a]
aft) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n [a]
xs
   in [a]
bef [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [Int] -> [a] -> [[a]]
forall a. [Int] -> [a] -> [[a]]
chunks [Int]
ns [a]
aft

-- | @chunkLike xss ys@ chunks the elements of @ys@ to match the
-- elements of @xss@.  The sum of the lengths of the sublists of @xss@
-- must match the length of @ys@.
chunkLike :: [[a]] -> [b] -> [[b]]
chunkLike :: forall a b. [[a]] -> [b] -> [[b]]
chunkLike [[a]]
as = [Int] -> [b] -> [[b]]
forall a. [Int] -> [a] -> [[a]]
chunks (([a] -> Int) -> [[a]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[a]]
as)

-- | Like 'maximum', but returns zero for an empty list.
maxinum :: (Num a, Ord a, Foldable f) => f a -> a
maxinum :: forall a (f :: * -> *). (Num a, Ord a, Foldable f) => f a -> a
maxinum = (a -> a -> a) -> a -> f a -> a
forall b a. (b -> a -> b) -> b -> f a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' a -> a -> a
forall a. Ord a => a -> a -> a
max a
0

-- | @dropAt i n@ drops @n@ elements starting at element @i@.
dropAt :: Int -> Int -> [a] -> [a]
dropAt :: forall a. Int -> Int -> [a] -> [a]
dropAt Int
i Int
n [a]
xs = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
i [a]
xs [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n) [a]
xs

-- | @takeLast n l@ takes the last @n@ elements of @l@.
takeLast :: Int -> [a] -> [a]
takeLast :: forall a. Int -> [a] -> [a]
takeLast Int
n = [a] -> [a]
forall a. [a] -> [a]
reverse ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
n ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [a]
forall a. [a] -> [a]
reverse

-- | @dropLast n l@ drops the last @n@ elements of @l@.
dropLast :: Int -> [a] -> [a]
dropLast :: forall a. Int -> [a] -> [a]
dropLast Int
n = [a] -> [a]
forall a. [a] -> [a]
reverse ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
n ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [a]
forall a. [a] -> [a]
reverse

-- | A combination of 'map' and 'partitionEithers'.
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
f [a]
l = [Either b c] -> ([b], [c])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either b c] -> ([b], [c])) -> [Either b c] -> ([b], [c])
forall a b. (a -> b) -> a -> b
$ (a -> Either b c) -> [a] -> [Either b c]
forall a b. (a -> b) -> [a] -> [b]
map a -> Either b c
f [a]
l

-- | A combination of 'Data.List.partition' and 'mapMaybe'
partitionMaybe :: (a -> Maybe b) -> [a] -> ([b], [a])
partitionMaybe :: forall a b. (a -> Maybe b) -> [a] -> ([b], [a])
partitionMaybe a -> Maybe b
f = ([b], [a]) -> [a] -> ([b], [a])
helper ([], [])
  where
    helper :: ([b], [a]) -> [a] -> ([b], [a])
helper ([b]
acc1, [a]
acc2) [] = ([b] -> [b]
forall a. [a] -> [a]
reverse [b]
acc1, [a] -> [a]
forall a. [a] -> [a]
reverse [a]
acc2)
    helper ([b]
acc1, [a]
acc2) (a
x : [a]
xs) =
      case a -> Maybe b
f a
x of
        Just b
x' -> ([b], [a]) -> [a] -> ([b], [a])
helper (b
x' b -> [b] -> [b]
forall a. a -> [a] -> [a]
: [b]
acc1, [a]
acc2) [a]
xs
        Maybe b
Nothing -> ([b], [a]) -> [a] -> ([b], [a])
helper ([b]
acc1, a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
acc2) [a]
xs

-- | Return the list element at the given index, if the index is valid.
maybeNth :: (Integral int) => int -> [a] -> Maybe a
maybeNth :: forall int a. Integral int => int -> [a] -> Maybe a
maybeNth int
i [a]
l
  | int
i int -> int -> Bool
forall a. Ord a => a -> a -> Bool
>= int
0, a
v : [a]
_ <- int -> [a] -> [a]
forall i a. Integral i => i -> [a] -> [a]
genericDrop int
i [a]
l = a -> Maybe a
forall a. a -> Maybe a
Just a
v
  | Bool
otherwise = Maybe a
forall a. Maybe a
Nothing

-- | Return the first element of the list, if it exists.
maybeHead :: [a] -> Maybe a
maybeHead :: forall a. [a] -> Maybe a
maybeHead [] = Maybe a
forall a. Maybe a
Nothing
maybeHead (a
x : [a]
_) = a -> Maybe a
forall a. a -> Maybe a
Just a
x

-- | Lookup a value, returning also the index at which it appears.
lookupWithIndex :: (Eq a) => a -> [(a, b)] -> Maybe (Int, b)
lookupWithIndex :: forall a b. Eq a => a -> [(a, b)] -> Maybe (Int, b)
lookupWithIndex a
needle [(a, b)]
haystack =
  a -> [(a, (Int, b))] -> Maybe (Int, b)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
needle ([(a, (Int, b))] -> Maybe (Int, b))
-> [(a, (Int, b))] -> Maybe (Int, b)
forall a b. (a -> b) -> a -> b
$ [a] -> [(Int, b)] -> [(a, (Int, b))]
forall a b. [a] -> [b] -> [(a, b)]
zip (((a, b) -> a) -> [(a, b)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a, b) -> a
forall a b. (a, b) -> a
fst [(a, b)]
haystack) ([Int] -> [b] -> [(Int, b)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] (((a, b) -> b) -> [(a, b)] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (a, b) -> b
forall a b. (a, b) -> b
snd [(a, b)]
haystack))

-- | Like 'splitAt', but from the end.
splitFromEnd :: Int -> [a] -> ([a], [a])
splitFromEnd :: forall a. Int -> [a] -> ([a], [a])
splitFromEnd Int
i [a]
l = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt ([a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
l Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i) [a]
l

-- | Like 'splitAt', but produces three lists.
splitAt3 :: Int -> Int -> [a] -> ([a], [a], [a])
splitAt3 :: forall a. Int -> Int -> [a] -> ([a], [a], [a])
splitAt3 Int
n Int
m [a]
l =
  let ([a]
xs, [a]
l') = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n [a]
l
      ([a]
ys, [a]
zs) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
m [a]
l'
   in ([a]
xs, [a]
ys, [a]
zs)

-- | Return the list element at the given index, if the index is
-- valid, along with the elements before and after.
focusNth :: (Integral int) => int -> [a] -> Maybe ([a], a, [a])
focusNth :: forall int a. Integral int => int -> [a] -> Maybe ([a], a, [a])
focusNth int
i [a]
xs
  | ([a]
bef, a
x : [a]
aft) <- int -> [a] -> ([a], [a])
forall i a. Integral i => i -> [a] -> ([a], [a])
genericSplitAt int
i [a]
xs = ([a], a, [a]) -> Maybe ([a], a, [a])
forall a. a -> Maybe a
Just ([a]
bef, a
x, [a]
aft)
  | Bool
otherwise = Maybe ([a], a, [a])
forall a. Maybe a
Nothing

-- | Return the first list element that satisifes a predicate, along with the
-- elements before and after.
focusMaybe :: (a -> Maybe b) -> [a] -> Maybe ([a], b, [a])
focusMaybe :: forall a b. (a -> Maybe b) -> [a] -> Maybe ([a], b, [a])
focusMaybe a -> Maybe b
f [a]
xs = do
  Int
idx <- (a -> Bool) -> [a] -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex (Maybe b -> Bool
forall a. Maybe a -> Bool
isJust (Maybe b -> Bool) -> (a -> Maybe b) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe b
f) [a]
xs
  ([a]
before, a
focus, [a]
after) <- Int -> [a] -> Maybe ([a], a, [a])
forall int a. Integral int => int -> [a] -> Maybe ([a], a, [a])
focusNth Int
idx [a]
xs
  b
res <- a -> Maybe b
f a
focus
  ([a], b, [a]) -> Maybe ([a], b, [a])
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([a]
before, b
res, [a]
after)

-- | Compute a hash of a text that is stable across OS versions.
-- Returns the hash as a text as well, ready for human consumption.
hashText :: T.Text -> T.Text
hashText :: Text -> Text
hashText =
  OnDecodeError -> ByteString -> Text
T.decodeUtf8With OnDecodeError
T.lenientDecode (ByteString -> Text) -> (Text -> ByteString) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Base16.encode (ByteString -> ByteString)
-> (Text -> ByteString) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
MD5.hash (ByteString -> ByteString)
-> (Text -> ByteString) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8

-- | Like 'show', but produces text.
showText :: (Show a) => a -> T.Text
showText :: forall a. Show a => a -> Text
showText = String -> Text
T.pack (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show

{-# NOINLINE unixEnvironment #-}

-- | The Unix environment when the Futhark compiler started.
unixEnvironment :: [(String, String)]
unixEnvironment :: [(String, String)]
unixEnvironment = IO [(String, String)] -> [(String, String)]
forall a. IO a -> a
unsafePerformIO IO [(String, String)]
getEnvironment

-- | True if the environment variable, viewed as an integer, has at
-- least this numeric value.  Returns False if variable is unset or
-- not numeric.
isEnvVarAtLeast :: String -> Int -> Bool
isEnvVarAtLeast :: String -> Int -> Bool
isEnvVarAtLeast String
s Int
x =
  case String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe Int) -> Maybe String -> Maybe Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
s [(String, String)]
unixEnvironment of
    Just Int
y -> Int
y Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
x
    Maybe Int
_ -> Bool
False

{-# NOINLINE startupTime #-}

-- | The time at which the process started - or more accurately, the
-- first time this binding was forced.
startupTime :: UTCTime
startupTime :: UTCTime
startupTime = IO UTCTime -> UTCTime
forall a. IO a -> a
unsafePerformIO IO UTCTime
getCurrentTime

{-# NOINLINE fancyTerminal #-}

-- | Are we running in a terminal capable of fancy commands and
-- visualisation?
fancyTerminal :: Bool
fancyTerminal :: Bool
fancyTerminal = IO Bool -> Bool
forall a. IO a -> a
unsafePerformIO (IO Bool -> Bool) -> IO Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Handle -> IO Bool
hFancyTerminal Handle
stdout

-- | Is this handle connected to a terminal capable of fancy commands
-- and visualisation?
hFancyTerminal :: Handle -> IO Bool
hFancyTerminal :: Handle -> IO Bool
hFancyTerminal Handle
h = do
  Bool
isTTY <- Handle -> IO Bool
hIsTerminalDevice Handle
h
  Bool
isDumb <- (String -> Maybe String
forall a. a -> Maybe a
Just String
"dumb" ==) (Maybe String -> Bool) -> IO (Maybe String) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
"TERM"
  Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Bool
isTTY Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isDumb

-- | Like 'readProcessWithExitCode', but also wraps exceptions when
-- the indicated binary cannot be launched, or some other exception is
-- thrown.  Also does shenanigans to handle improperly encoded outputs.
runProgramWithExitCode ::
  FilePath ->
  [String] ->
  BS.ByteString ->
  IO (Either IOException (ExitCode, String, String))
runProgramWithExitCode :: String
-> [String]
-> ByteString
-> IO (Either IOException (ExitCode, String, String))
runProgramWithExitCode String
exe [String]
args ByteString
inp =
  ((ExitCode, String, String)
-> Either IOException (ExitCode, String, String)
forall a b. b -> Either a b
Right ((ExitCode, String, String)
 -> Either IOException (ExitCode, String, String))
-> ((ExitCode, ByteString, ByteString)
    -> (ExitCode, String, String))
-> (ExitCode, ByteString, ByteString)
-> Either IOException (ExitCode, String, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ExitCode, ByteString, ByteString) -> (ExitCode, String, String)
forall {a}. (a, ByteString, ByteString) -> (a, String, String)
postprocess ((ExitCode, ByteString, ByteString)
 -> Either IOException (ExitCode, String, String))
-> IO (ExitCode, ByteString, ByteString)
-> IO (Either IOException (ExitCode, String, String))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> [String] -> ByteString -> IO (ExitCode, ByteString, ByteString)
readProcessWithExitCode String
exe [String]
args ByteString
inp)
    IO (Either IOException (ExitCode, String, String))
-> (IOException
    -> IO (Either IOException (ExitCode, String, String)))
-> IO (Either IOException (ExitCode, String, String))
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \IOException
e -> Either IOException (ExitCode, String, String)
-> IO (Either IOException (ExitCode, String, String))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IOException -> Either IOException (ExitCode, String, String)
forall a b. a -> Either a b
Left IOException
e)
  where
    decode :: ByteString -> String
decode = Text -> String
T.unpack (Text -> String) -> (ByteString -> Text) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OnDecodeError -> ByteString -> Text
T.decodeUtf8With OnDecodeError
T.lenientDecode
    postprocess :: (a, ByteString, ByteString) -> (a, String, String)
postprocess (a
code, ByteString
out, ByteString
err) =
      (a
code, ByteString -> String
decode ByteString
out, ByteString -> String
decode ByteString
err)

-- | Every non-directory file contained in a directory tree.
directoryContents :: FilePath -> IO [FilePath]
directoryContents :: String -> IO [String]
directoryContents String
dir = do
  String
_ Dir.:/ DirTree String
tree <- (String -> IO String) -> String -> IO (AnchoredDirTree String)
forall a. (String -> IO a) -> String -> IO (AnchoredDirTree a)
Dir.readDirectoryWith String -> IO String
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
dir
  case DirTree String -> [DirTree String]
forall a. DirTree a -> [DirTree a]
Dir.failures DirTree String
tree of
    Dir.Failed String
_ IOException
err : [DirTree String]
_ -> IOException -> IO [String]
forall a e. Exception e => e -> a
throw IOException
err
    [DirTree String]
_ -> [String] -> IO [String]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ (DirTree String -> Maybe String) -> [DirTree String] -> [String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe DirTree String -> Maybe String
forall {a}. DirTree a -> Maybe a
isFile ([DirTree String] -> [String]) -> [DirTree String] -> [String]
forall a b. (a -> b) -> a -> b
$ DirTree String -> [DirTree String]
forall a. DirTree a -> [DirTree a]
Dir.flattenDir DirTree String
tree
  where
    isFile :: DirTree a -> Maybe a
isFile (Dir.File String
_ a
path) = a -> Maybe a
forall a. a -> Maybe a
Just a
path
    isFile DirTree a
_ = Maybe a
forall a. Maybe a
Nothing

-- | Turn a POSIX filepath into a filepath for the native system.
toPOSIX :: Native.FilePath -> Posix.FilePath
toPOSIX :: String -> String
toPOSIX = [String] -> String
Posix.joinPath ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
Native.splitDirectories

-- | Some bad operating systems do not use forward slash as
-- directory separator - this is where we convert Futhark includes
-- (which always use forward slash) to native paths.
fromPOSIX :: Posix.FilePath -> Native.FilePath
fromPOSIX :: String -> String
fromPOSIX = [String] -> String
Native.joinPath ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
Posix.splitDirectories

-- | Remove leading and trailing whitespace from a string.  Not an
-- efficient implementation!
trim :: String -> String
trim :: String -> String
trim = String -> String
forall a. [a] -> [a]
reverse (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. [a] -> [a]
reverse (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace

-- | Run various 'IO' actions concurrently, possibly with a bound on
-- the number of threads.  The list must be finite.  The ordering of
-- the result list is not deterministic - add your own sorting if
-- needed.  If any of the actions throw an exception, then that
-- exception is propagated to this function.
pmapIO :: Maybe Int -> (a -> IO b) -> [a] -> IO [b]
pmapIO :: forall a b. Maybe Int -> (a -> IO b) -> [a] -> IO [b]
pmapIO Maybe Int
concurrency a -> IO b
f [a]
elems = do
  MVar [a]
tasks <- [a] -> IO (MVar [a])
forall a. a -> IO (MVar a)
newMVar [a]
elems
  MVar (Either SomeException b)
results <- IO (MVar (Either SomeException b))
forall a. IO (MVar a)
newEmptyMVar
  Int
num_threads <- IO Int -> (Int -> IO Int) -> Maybe Int -> IO Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO Int
getNumCapabilities Int -> IO Int
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Int
concurrency
  Int -> IO ThreadId -> IO ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
num_threads (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ MVar [a] -> MVar (Either SomeException b) -> IO ()
forall {a}. Exception a => MVar [a] -> MVar (Either a b) -> IO ()
worker MVar [a]
tasks MVar (Either SomeException b)
results
  Int -> IO b -> IO [b]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM ([a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
elems) (IO b -> IO [b]) -> IO b -> IO [b]
forall a b. (a -> b) -> a -> b
$ MVar (Either SomeException b) -> IO b
forall {b}. MVar (Either SomeException b) -> IO b
getResult MVar (Either SomeException b)
results
  where
    worker :: MVar [a] -> MVar (Either a b) -> IO ()
worker MVar [a]
tasks MVar (Either a b)
results = do
      Maybe a
task <- MVar [a] -> ([a] -> IO ([a], Maybe a)) -> IO (Maybe a)
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar [a]
tasks [a] -> IO ([a], Maybe a)
forall {f :: * -> *} {a}. Applicative f => [a] -> f ([a], Maybe a)
getTask
      case Maybe a
task of
        Maybe a
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just a
x -> do
          Either a b
y <- (b -> Either a b
forall a b. b -> Either a b
Right (b -> Either a b) -> IO b -> IO (Either a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> IO b
f a
x) IO (Either a b) -> (a -> IO (Either a b)) -> IO (Either a b)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (Either a b -> IO (Either a b)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either a b -> IO (Either a b))
-> (a -> Either a b) -> a -> IO (Either a b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either a b
forall a b. a -> Either a b
Left)
          MVar (Either a b) -> Either a b -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Either a b)
results Either a b
y
          MVar [a] -> MVar (Either a b) -> IO ()
worker MVar [a]
tasks MVar (Either a b)
results

    getTask :: [a] -> f ([a], Maybe a)
getTask [] = ([a], Maybe a) -> f ([a], Maybe a)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], Maybe a
forall a. Maybe a
Nothing)
    getTask (a
task : [a]
tasks) = ([a], Maybe a) -> f ([a], Maybe a)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([a]
tasks, a -> Maybe a
forall a. a -> Maybe a
Just a
task)

    getResult :: MVar (Either SomeException b) -> IO b
getResult MVar (Either SomeException b)
results = do
      Either SomeException b
res <- MVar (Either SomeException b) -> IO (Either SomeException b)
forall a. MVar a -> IO a
takeMVar MVar (Either SomeException b)
results
      case Either SomeException b
res of
        Left SomeException
err -> SomeException -> IO b
forall a e. Exception e => e -> a
throw (SomeException
err :: SomeException)
        Right b
v -> b -> IO b
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
v

-- | Do some operation on a file, returning 'Nothing' if the file does
-- not exist, and 'Left' if some other error occurs.
interactWithFileSafely :: IO a -> IO (Maybe (Either String a))
interactWithFileSafely :: forall a. IO a -> IO (Maybe (Either String a))
interactWithFileSafely IO a
m =
  (Either String a -> Maybe (Either String a)
forall a. a -> Maybe a
Just (Either String a -> Maybe (Either String a))
-> (a -> Either String a) -> a -> Maybe (Either String a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either String a
forall a b. b -> Either a b
Right (a -> Maybe (Either String a))
-> IO a -> IO (Maybe (Either String a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a
m) IO (Maybe (Either String a))
-> (IOException -> IO (Maybe (Either String a)))
-> IO (Maybe (Either String a))
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` IOException -> IO (Maybe (Either String a))
forall {f :: * -> *} {b}.
Applicative f =>
IOException -> f (Maybe (Either String b))
couldNotRead
  where
    couldNotRead :: IOException -> f (Maybe (Either String b))
couldNotRead IOException
e
      | IOException -> Bool
isDoesNotExistError IOException
e =
          Maybe (Either String b) -> f (Maybe (Either String b))
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Either String b)
forall a. Maybe a
Nothing
      | Bool
otherwise =
          Maybe (Either String b) -> f (Maybe (Either String b))
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Either String b) -> f (Maybe (Either String b)))
-> Maybe (Either String b) -> f (Maybe (Either String b))
forall a b. (a -> b) -> a -> b
$ Either String b -> Maybe (Either String b)
forall a. a -> Maybe a
Just (Either String b -> Maybe (Either String b))
-> Either String b -> Maybe (Either String b)
forall a b. (a -> b) -> a -> b
$ String -> Either String b
forall a b. a -> Either a b
Left (String -> Either String b) -> String -> Either String b
forall a b. (a -> b) -> a -> b
$ IOException -> String
forall a. Show a => a -> String
show IOException
e

-- | Convert between different floating-point types, preserving
-- infinities and NaNs.
convFloat :: (RealFloat from, RealFloat to) => from -> to
convFloat :: forall from to. (RealFloat from, RealFloat to) => from -> to
convFloat from
v
  | from -> Bool
forall a. RealFloat a => a -> Bool
isInfinite from
v, from
v from -> from -> Bool
forall a. Ord a => a -> a -> Bool
> from
0 = to
1 to -> to -> to
forall a. Fractional a => a -> a -> a
/ to
0
  | from -> Bool
forall a. RealFloat a => a -> Bool
isInfinite from
v, from
v from -> from -> Bool
forall a. Ord a => a -> a -> Bool
< from
0 = -to
1 to -> to -> to
forall a. Fractional a => a -> a -> a
/ to
0
  | from -> Bool
forall a. RealFloat a => a -> Bool
isNaN from
v = to
0 to -> to -> to
forall a. Fractional a => a -> a -> a
/ to
0
  | Bool
otherwise = Rational -> to
forall a. Fractional a => Rational -> a
fromRational (Rational -> to) -> Rational -> to
forall a b. (a -> b) -> a -> b
$ from -> Rational
forall a. Real a => a -> Rational
toRational from
v

-- Z-encoding from https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/SymbolNames
--
-- Slightly simplified as we do not need it to deal with tuples and
-- the like.
--
-- (c) The University of Glasgow, 1997-2006

-- | As the user typed it.
type UserString = String

-- | Encoded form.
type EncodedString = String

-- | As 'zEncodeText', but for strings.
zEncodeString :: UserString -> EncodedString
zEncodeString :: String -> String
zEncodeString String
"" = String
""
zEncodeString (Char
c : String
cs) = Char -> String
encodeDigitChar Char
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Char -> String) -> String -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> String
encodeChar String
cs

-- | As the user typed it.
type UserText = T.Text

-- | Encoded form.
type EncodedText = T.Text

-- | Z-encode a text using a slightly simplified variant of GHC
-- Z-encoding.  The encoded string is a valid identifier in most
-- programming languages.
zEncodeText :: UserText -> EncodedText
zEncodeText :: Text -> Text
zEncodeText = String -> Text
T.pack (String -> Text) -> (Text -> String) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
zEncodeString (String -> String) -> (Text -> String) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack

unencodedChar :: Char -> Bool -- True for chars that don't need encoding
unencodedChar :: Char -> Bool
unencodedChar Char
'Z' = Bool
False
unencodedChar Char
'z' = Bool
False
unencodedChar Char
'_' = Bool
True
unencodedChar Char
c =
  Char -> Bool
isAsciiLower Char
c
    Bool -> Bool -> Bool
|| Char -> Bool
isAsciiUpper Char
c
    Bool -> Bool -> Bool
|| Char -> Bool
isDigit Char
c

-- If a digit is at the start of a symbol then we need to encode it.
-- Otherwise names like 9pH-0.1 give linker errors.
encodeDigitChar :: Char -> EncodedString
encodeDigitChar :: Char -> String
encodeDigitChar Char
c
  | Char -> Bool
isDigit Char
c = Char -> String
encodeAsUnicodeCharar Char
c
  | Bool
otherwise = Char -> String
encodeChar Char
c

encodeChar :: Char -> EncodedString
encodeChar :: Char -> String
encodeChar Char
c | Char -> Bool
unencodedChar Char
c = [Char
c] -- Common case first

-- Constructors
encodeChar Char
'(' = String
"ZL" -- Needed for things like (,), and (->)
encodeChar Char
')' = String
"ZR" -- For symmetry with (
encodeChar Char
'[' = String
"ZM"
encodeChar Char
']' = String
"ZN"
encodeChar Char
':' = String
"ZC"
encodeChar Char
'Z' = String
"ZZ"
-- Variables
encodeChar Char
'z' = String
"zz"
encodeChar Char
'&' = String
"za"
encodeChar Char
'|' = String
"zb"
encodeChar Char
'^' = String
"zc"
encodeChar Char
'$' = String
"zd"
encodeChar Char
'=' = String
"ze"
encodeChar Char
'>' = String
"zg"
encodeChar Char
'#' = String
"zh"
encodeChar Char
'.' = String
"zi"
encodeChar Char
'<' = String
"zl"
encodeChar Char
'-' = String
"zm"
encodeChar Char
'!' = String
"zn"
encodeChar Char
'+' = String
"zp"
encodeChar Char
'\'' = String
"zq"
encodeChar Char
'\\' = String
"zr"
encodeChar Char
'/' = String
"zs"
encodeChar Char
'*' = String
"zt"
encodeChar Char
'_' = String
"zu"
encodeChar Char
'%' = String
"zv"
encodeChar Char
c = Char -> String
encodeAsUnicodeCharar Char
c

encodeAsUnicodeCharar :: Char -> EncodedString
encodeAsUnicodeCharar :: Char -> String
encodeAsUnicodeCharar Char
c =
  Char
'z'
    Char -> String -> String
forall a. a -> [a] -> [a]
: if Bool -> (Char -> Bool) -> Maybe Char -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False Char -> Bool
isDigit (Maybe Char -> Bool) -> Maybe Char -> Bool
forall a b. (a -> b) -> a -> b
$ String -> Maybe Char
forall a. [a] -> Maybe a
maybeHead String
hex_str
      then String
hex_str
      else Char
'0' Char -> String -> String
forall a. a -> [a] -> [a]
: String
hex_str
  where
    hex_str :: String
hex_str = Int -> String -> String
forall a. Integral a => a -> String -> String
showHex (Char -> Int
ord Char
c) String
"U"

-- | Truncate to at most this many characters, making the last three
-- characters "..." if truncation is necessary.
atMostChars :: Int -> T.Text -> T.Text
atMostChars :: Int -> Text -> Text
atMostChars Int
n Text
s
  | Text -> Int
T.length Text
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
n = Int -> Text -> Text
T.take (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
3) Text
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"..."
  | Bool
otherwise = Text
s

-- | Invert a map, handling duplicate values (now keys) by
-- constructing a set of corresponding values.
invertMap :: (Ord v, Ord k) => M.Map k v -> M.Map v (S.Set k)
invertMap :: forall v k. (Ord v, Ord k) => Map k v -> Map v (Set k)
invertMap Map k v
m =
  ((k, v) -> Map v (Set k) -> Map v (Set k))
-> Map v (Set k) -> [(k, v)] -> Map v (Set k)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
    ((v -> Set k -> Map v (Set k) -> Map v (Set k))
-> (v, Set k) -> Map v (Set k) -> Map v (Set k)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Set k -> Set k -> Set k)
-> v -> Set k -> Map v (Set k) -> Map v (Set k)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith Set k -> Set k -> Set k
forall a. Semigroup a => a -> a -> a
(<>)) ((v, Set k) -> Map v (Set k) -> Map v (Set k))
-> ((k, v) -> (v, Set k))
-> (k, v)
-> Map v (Set k)
-> Map v (Set k)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set k, v) -> (v, Set k)
forall a b. (a, b) -> (b, a)
swap ((Set k, v) -> (v, Set k))
-> ((k, v) -> (Set k, v)) -> (k, v) -> (v, Set k)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (k -> Set k) -> (k, v) -> (Set k, v)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first k -> Set k
forall a. a -> Set a
S.singleton)
    Map v (Set k)
forall a. Monoid a => a
mempty
    (Map k v -> [(k, v)]
forall k a. Map k a -> [(k, a)]
M.toList Map k v
m)

-- | Compute the cartesian product of two foldable collections, using the given
-- combinator function.
cartesian :: (Monoid m, Foldable t) => (a -> a -> m) -> t a -> t a -> m
cartesian :: forall m (t :: * -> *) a.
(Monoid m, Foldable t) =>
(a -> a -> m) -> t a -> t a -> m
cartesian a -> a -> m
f t a
xs t a
ys =
  [(a
x, a
y) | a
x <- t a -> [a]
forall a. t a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList t a
xs, a
y <- t a -> [a]
forall a. t a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList t a
ys]
    [(a, a)] -> ([(a, a)] -> m) -> m
forall a b. a -> (a -> b) -> b
& ((a, a) -> m) -> [(a, a)] -> m
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((a -> a -> m) -> (a, a) -> m
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry a -> a -> m
f)

-- | Applicatively fold a traversable.
traverseFold :: (Monoid m, Traversable t, Applicative f) => (a -> f m) -> t a -> f m
traverseFold :: forall m (t :: * -> *) (f :: * -> *) a.
(Monoid m, Traversable t, Applicative f) =>
(a -> f m) -> t a -> f m
traverseFold a -> f m
f = (t m -> m) -> f (t m) -> f m
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap t m -> m
forall m. Monoid m => t m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (f (t m) -> f m) -> (t a -> f (t m)) -> t a -> f m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> f m) -> t a -> f (t m)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> t a -> f (t b)
traverse a -> f m
f

-- | Perform fixpoint iteration.
fixPoint :: (Eq a) => (a -> a) -> a -> a
fixPoint :: forall a. Eq a => (a -> a) -> a -> a
fixPoint a -> a
f a
x =
  let x' :: a
x' = a -> a
f a
x
   in if a
x' a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
x then a
x else (a -> a) -> a -> a
forall a. Eq a => (a -> a) -> a -> a
fixPoint a -> a
f a
x'

-- | Like 'concatMap', but monoidal and monadic.
concatMapM :: (Monad m, Monoid b) => (a -> m b) -> [a] -> m b
concatMapM :: forall (m :: * -> *) b a.
(Monad m, Monoid b) =>
(a -> m b) -> [a] -> m b
concatMapM a -> m b
f [a]
xs = [b] -> b
forall a. Monoid a => [a] -> a
mconcat ([b] -> b) -> m [b] -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> m b) -> [a] -> m [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 a -> m b
f [a]
xs

-- | Topological sorting of an array with an adjancency function, if
-- there is a cycle, it causes an error. @dep a b@ means @a -> b@,
-- and the returned array guarantee that for i < j:
--
-- @not ( dep (ret !! j) (ret !! i) )@.
topologicalSort :: (a -> a -> Bool) -> [a] -> [a]
topologicalSort :: forall a. (a -> a -> Bool) -> [a] -> [a]
topologicalSort a -> a -> Bool
dep [a]
nodes =
  ([a], IntMap Bool) -> [a]
forall a b. (a, b) -> a
fst (([a], IntMap Bool) -> [a]) -> ([a], IntMap Bool) -> [a]
forall a b. (a -> b) -> a -> b
$ State ([a], IntMap Bool) ()
-> ([a], IntMap Bool) -> ([a], IntMap Bool)
forall s a. State s a -> s -> s
execState (((a, Int) -> State ([a], IntMap Bool) ())
-> [(a, Int)] -> State ([a], IntMap Bool) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Int -> State ([a], IntMap Bool) ()
forall {m :: * -> *}.
MonadState ([a], IntMap Bool) m =>
Int -> m ()
sorting (Int -> State ([a], IntMap Bool) ())
-> ((a, Int) -> Int) -> (a, Int) -> State ([a], IntMap Bool) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, Int) -> Int
forall a b. (a, b) -> b
snd) [(a, Int)]
nodes_idx) ([a]
forall a. Monoid a => a
mempty, IntMap Bool
forall a. Monoid a => a
mempty)
  where
    nodes_idx :: [(a, Int)]
nodes_idx = [a] -> [Int] -> [(a, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [a]
nodes [Int
0 ..]
    depends_of :: a -> (a, a) -> Maybe a
depends_of a
a (a
b, a
i) =
      if a
a a -> a -> Bool
`dep` a
b
        then a -> Maybe a
forall a. a -> Maybe a
Just a
i
        else Maybe a
forall a. Maybe a
Nothing

    -- Using an IntMap Bool
    -- when reading a lookup:
    -- \* Nothing : never explored
    -- \* Just True : being explored
    -- \* Just False : explored
    sorting :: Int -> m ()
sorting Int
i = do
      Maybe Bool
status <- (([a], IntMap Bool) -> Maybe Bool) -> m (Maybe Bool)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((([a], IntMap Bool) -> Maybe Bool) -> m (Maybe Bool))
-> (([a], IntMap Bool) -> Maybe Bool) -> m (Maybe Bool)
forall a b. (a -> b) -> a -> b
$ Int -> IntMap Bool -> Maybe Bool
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
i (IntMap Bool -> Maybe Bool)
-> (([a], IntMap Bool) -> IntMap Bool)
-> ([a], IntMap Bool)
-> Maybe Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([a], IntMap Bool) -> IntMap Bool
forall a b. (a, b) -> b
snd
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Bool
status Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> m ()
forall a. HasCallStack => String -> a
error String
"topological sorting has encountered a cycle"
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Maybe Bool
status Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        let node :: a
node = [a]
nodes [a] -> Int -> a
forall a. HasCallStack => [a] -> Int -> a
!! Int
i
        (([a], IntMap Bool) -> ([a], IntMap Bool)) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((([a], IntMap Bool) -> ([a], IntMap Bool)) -> m ())
-> (([a], IntMap Bool) -> ([a], IntMap Bool)) -> m ()
forall a b. (a -> b) -> a -> b
$ (IntMap Bool -> IntMap Bool)
-> ([a], IntMap Bool) -> ([a], IntMap Bool)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((IntMap Bool -> IntMap Bool)
 -> ([a], IntMap Bool) -> ([a], IntMap Bool))
-> (IntMap Bool -> IntMap Bool)
-> ([a], IntMap Bool)
-> ([a], IntMap Bool)
forall a b. (a -> b) -> a -> b
$ Int -> Bool -> IntMap Bool -> IntMap Bool
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
i Bool
True
        (Int -> m ()) -> [Int] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Int -> m ()
sorting ([Int] -> m ()) -> [Int] -> m ()
forall a b. (a -> b) -> a -> b
$ ((a, Int) -> Maybe Int) -> [(a, Int)] -> [Int]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (a -> (a, Int) -> Maybe Int
forall {a}. a -> (a, a) -> Maybe a
depends_of a
node) [(a, Int)]
nodes_idx
        (([a], IntMap Bool) -> ([a], IntMap Bool)) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((([a], IntMap Bool) -> ([a], IntMap Bool)) -> m ())
-> (([a], IntMap Bool) -> ([a], IntMap Bool)) -> m ()
forall a b. (a -> b) -> a -> b
$ ([a] -> [a])
-> (IntMap Bool -> IntMap Bool)
-> ([a], IntMap Bool)
-> ([a], IntMap Bool)
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (a
node :) (Int -> Bool -> IntMap Bool -> IntMap Bool
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
i Bool
False)