{-# LANGUAGE Trustworthy #-}

-- | 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,
    pairs,
    unpairs,
    dropAt,
    takeLast,
    dropLast,
    mapEither,
    maybeNth,
    maybeHead,
    splitFromEnd,
    splitAt3,
    focusNth,
    hashText,
    unixEnvironment,
    isEnvVarAtLeast,
    startupTime,
    fancyTerminal,
    runProgramWithExitCode,
    directoryContents,
    roundFloat,
    ceilFloat,
    floorFloat,
    roundDouble,
    ceilDouble,
    floorDouble,
    lgamma,
    lgammaf,
    tgamma,
    tgammaf,
    erf,
    erff,
    erfc,
    erfcf,
    cbrt,
    cbrtf,
    hypot,
    hypotf,
    fromPOSIX,
    toPOSIX,
    trim,
    pmapIO,
    interactWithFileSafely,
    convFloat,
    UserString,
    EncodedString,
    zEncodeString,
    atMostChars,
    invertMap,
    traverseFold,
    fixPoint,
  )
where

import Control.Arrow (first)
import Control.Concurrent
import Control.Exception
import Control.Monad
import Crypto.Hash.MD5 as MD5
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base16 as Base16
import Data.Char
import Data.Either
import Data.Foldable (fold)
import Data.Function ((&))
import Data.List (foldl', genericDrop, genericSplitAt, sortBy)
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as M
import Data.Maybe
import qualified Data.Set as S
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Encoding.Error as T
import Data.Time.Clock (UTCTime, getCurrentTime)
import Data.Tuple (swap)
import Numeric
import qualified System.Directory.Tree as Dir
import System.Environment
import System.Exit
import qualified System.FilePath as Native
import qualified System.FilePath.Posix as Posix
import System.IO (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 = forall a. (a -> a -> Ordering) -> [a] -> [a]
nubByOrd 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 = forall a b. (a -> b) -> [a] -> [b]
map forall a. NonEmpty a -> a
NE.head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a.
Foldable f =>
(a -> a -> Bool) -> f a -> [NonEmpty a]
NE.groupBy a -> a -> Bool
eq forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a. Eq a => a -> a -> Bool
== Ordering
EQ

-- | Like 'Data.Traversable.mapAccumL', but monadic.
mapAccumLM ::
  Monad m =>
  (acc -> x -> m (acc, y)) ->
  acc ->
  [x] ->
  m (acc, [y])
mapAccumLM :: forall (m :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM acc -> x -> m (acc, y)
_ acc
acc [] = forall (f :: * -> *) a. Applicative f => a -> f a
pure (acc
acc, [])
mapAccumLM acc -> x -> m (acc, y)
f acc
acc (x
x : [x]
xs) = do
  (acc
acc', y
x') <- acc -> x -> m (acc, y)
f acc
acc x
x
  (acc
acc'', [y]
xs') <- forall (m :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM acc -> x -> m (acc, y)
f acc
acc' [x]
xs
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (acc
acc'', y
x' forall a. a -> [a] -> [a]
: [y]
xs')

-- | @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) = forall a. Int -> [a] -> ([a], [a])
splitAt Int
n [a]
xs
   in [a]
bef forall a. a -> [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) = forall a. Int -> [a] -> ([a], [a])
splitAt Int
n [a]
xs
   in [a]
bef forall a. a -> [a] -> [a]
: forall a. [Int] -> [a] -> [[a]]
chunks [Int]
ns [a]
aft

-- | @pairs l@ chunks the list into pairs of consecutive elements,
-- ignoring any excess element.  Example: @pairs [a,b,c,d] ==
-- [(a,b),(c,d)]@.
pairs :: [a] -> [(a, a)]
pairs :: forall a. [a] -> [(a, a)]
pairs (a
a : a
b : [a]
l) = (a
a, a
b) forall a. a -> [a] -> [a]
: forall a. [a] -> [(a, a)]
pairs [a]
l
pairs [a]
_ = []

-- | The opposite of 'pairs': @unpairs [(a,b),(c,d)] = [a,b,c,d]@.
unpairs :: [(a, a)] -> [a]
unpairs :: forall a. [(a, a)] -> [a]
unpairs [] = []
unpairs ((a
a, a
b) : [(a, a)]
l) = a
a forall a. a -> [a] -> [a]
: a
b forall a. a -> [a] -> [a]
: forall a. [(a, a)] -> [a]
unpairs [(a, a)]
l

-- | 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 = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' 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 = forall a. Int -> [a] -> [a]
take Int
i [a]
xs forall a. [a] -> [a] -> [a]
++ forall a. Int -> [a] -> [a]
drop (Int
i 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 = forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
take Int
n forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
drop Int
n forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall a b. [Either a b] -> ([a], [b])
partitionEithers forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map a -> Either b c
f [a]
l

-- | 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 forall a. Ord a => a -> a -> Bool
>= int
0, a
v : [a]
_ <- forall i a. Integral i => i -> [a] -> [a]
genericDrop int
i [a]
l = forall a. a -> Maybe a
Just a
v
  | Bool
otherwise = 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 [] = forall a. Maybe a
Nothing
maybeHead (a
x : [a]
_) = forall a. a -> Maybe a
Just a
x

-- | Like 'splitAt', but from the end.
splitFromEnd :: Int -> [a] -> ([a], [a])
splitFromEnd :: forall a. Int -> [a] -> ([a], [a])
splitFromEnd Int
i [a]
l = forall a. Int -> [a] -> ([a], [a])
splitAt (forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
l 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') = forall a. Int -> [a] -> ([a], [a])
splitAt Int
n [a]
l
      ([a]
ys, [a]
zs) = 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) <- forall i a. Integral i => i -> [a] -> ([a], [a])
genericSplitAt int
i [a]
xs = forall a. a -> Maybe a
Just ([a]
bef, a
x, [a]
aft)
  | Bool
otherwise = forall a. Maybe a
Nothing

-- | 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Base16.encode forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
MD5.hash forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8

{-# NOINLINE unixEnvironment #-}

-- | The Unix environment when the Futhark compiler started.
unixEnvironment :: [(String, String)]
unixEnvironment :: [(String, String)]
unixEnvironment = 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 forall a. Read a => String -> Maybe a
readMaybe forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
s [(String, String)]
unixEnvironment of
    Just Int
y -> Int
y 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 = 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 = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
  Bool
isTTY <- Handle -> IO Bool
hIsTerminalDevice Handle
stdout
  Bool
isDumb <- (forall a. a -> Maybe a
Just String
"dumb" forall a. Eq a => a -> a -> Bool
==) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
"TERM"
  forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 =
  (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. (a, ByteString, ByteString) -> (a, String, String)
postprocess 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)
    forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \IOException
e -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left IOException
e)
  where
    decode :: ByteString -> String
decode = Text -> String
T.unpack 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 <- forall a. (String -> IO a) -> String -> IO (AnchoredDirTree a)
Dir.readDirectoryWith forall (f :: * -> *) a. Applicative f => a -> f a
pure String
dir
  case forall a. DirTree a -> [DirTree a]
Dir.failures DirTree String
tree of
    Dir.Failed String
_ IOException
err : [DirTree String]
_ -> forall a e. Exception e => e -> a
throw IOException
err
    [DirTree String]
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {a}. DirTree a -> Maybe a
isFile forall a b. (a -> b) -> a -> b
$ forall a. DirTree a -> [DirTree a]
Dir.flattenDir DirTree String
tree
  where
    isFile :: DirTree a -> Maybe a
isFile (Dir.File String
_ a
path) = forall a. a -> Maybe a
Just a
path
    isFile DirTree a
_ = forall a. Maybe a
Nothing

foreign import ccall "nearbyint" c_nearbyint :: Double -> Double

foreign import ccall "nearbyintf" c_nearbyintf :: Float -> Float

foreign import ccall "ceil" c_ceil :: Double -> Double

foreign import ccall "ceilf" c_ceilf :: Float -> Float

foreign import ccall "floor" c_floor :: Double -> Double

foreign import ccall "floorf" c_floorf :: Float -> Float

-- | Round a single-precision floating point number correctly.
roundFloat :: Float -> Float
roundFloat :: Float -> Float
roundFloat = Float -> Float
c_nearbyintf

-- | Round a single-precision floating point number upwards correctly.
ceilFloat :: Float -> Float
ceilFloat :: Float -> Float
ceilFloat = Float -> Float
c_ceilf

-- | Round a single-precision floating point number downwards correctly.
floorFloat :: Float -> Float
floorFloat :: Float -> Float
floorFloat = Float -> Float
c_floorf

-- | Round a double-precision floating point number correctly.
roundDouble :: Double -> Double
roundDouble :: Double -> Double
roundDouble = Double -> Double
c_nearbyint

-- | Round a double-precision floating point number upwards correctly.
ceilDouble :: Double -> Double
ceilDouble :: Double -> Double
ceilDouble = Double -> Double
c_ceil

-- | Round a double-precision floating point number downwards correctly.
floorDouble :: Double -> Double
floorDouble :: Double -> Double
floorDouble = Double -> Double
c_floor

foreign import ccall "lgamma" c_lgamma :: Double -> Double

foreign import ccall "lgammaf" c_lgammaf :: Float -> Float

foreign import ccall "tgamma" c_tgamma :: Double -> Double

foreign import ccall "tgammaf" c_tgammaf :: Float -> Float

-- | The system-level @lgamma()@ function.
lgamma :: Double -> Double
lgamma :: Double -> Double
lgamma = Double -> Double
c_lgamma

-- | The system-level @lgammaf()@ function.
lgammaf :: Float -> Float
lgammaf :: Float -> Float
lgammaf = Float -> Float
c_lgammaf

-- | The system-level @tgamma()@ function.
tgamma :: Double -> Double
tgamma :: Double -> Double
tgamma = Double -> Double
c_tgamma

-- | The system-level @tgammaf()@ function.
tgammaf :: Float -> Float
tgammaf :: Float -> Float
tgammaf = Float -> Float
c_tgammaf

foreign import ccall "hypot" c_hypot :: Double -> Double -> Double

foreign import ccall "hypotf" c_hypotf :: Float -> Float -> Float

-- | The system-level @hypot@ function.
hypot :: Double -> Double -> Double
hypot :: Double -> Double -> Double
hypot = Double -> Double -> Double
c_hypot

-- | The system-level @hypotf@ function.
hypotf :: Float -> Float -> Float
hypotf :: Float -> Float -> Float
hypotf = Float -> Float -> Float
c_hypotf

foreign import ccall "erf" c_erf :: Double -> Double

foreign import ccall "erff" c_erff :: Float -> Float

foreign import ccall "erfc" c_erfc :: Double -> Double

foreign import ccall "erfcf" c_erfcf :: Float -> Float

-- | The system-level @erf()@ function.
erf :: Double -> Double
erf :: Double -> Double
erf = Double -> Double
c_erf

-- | The system-level @erff()@ function.
erff :: Float -> Float
erff :: Float -> Float
erff = Float -> Float
c_erff

-- | The system-level @erfc()@ function.
erfc :: Double -> Double
erfc :: Double -> Double
erfc = Double -> Double
c_erfc

-- | The system-level @erfcf()@ function.
erfcf :: Float -> Float
erfcf :: Float -> Float
erfcf = Float -> Float
c_erfcf

foreign import ccall "cbrt" c_cbrt :: Double -> Double

foreign import ccall "cbrtf" c_cbrtf :: Float -> Float

-- | The system-level @cbrt@ function.
cbrt :: Double -> Double
cbrt :: Double -> Double
cbrt = Double -> Double
c_cbrt

-- | The system-level @cbrtf@ function.
cbrtf :: Float -> Float
cbrtf :: Float -> Float
cbrtf = Float -> Float
c_cbrtf

-- | Turn a POSIX filepath into a filepath for the native system.
toPOSIX :: Native.FilePath -> Posix.FilePath
toPOSIX :: String -> String
toPOSIX = [String] -> String
Posix.joinPath 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 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 = forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 <- forall a. a -> IO (MVar a)
newMVar [a]
elems
  MVar (Either SomeException b)
results <- forall a. IO (MVar a)
newEmptyMVar
  Int
num_threads <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO Int
getNumCapabilities forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Int
concurrency
  forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
num_threads forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ forall {a}. Exception a => MVar [a] -> MVar (Either a b) -> IO ()
worker MVar [a]
tasks MVar (Either SomeException b)
results
  forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
elems) forall a b. (a -> b) -> a -> 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 <- forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar [a]
tasks forall {f :: * -> *} {a}. Applicative f => [a] -> f ([a], Maybe a)
getTask
      case Maybe a
task of
        Maybe a
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just a
x -> do
          Either a b
y <- (forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> IO b
f a
x) forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left)
          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 [] = forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], forall a. Maybe a
Nothing)
    getTask (a
task : [a]
tasks) = forall (f :: * -> *) a. Applicative f => a -> f a
pure ([a]
tasks, 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 <- forall a. MVar a -> IO a
takeMVar MVar (Either SomeException b)
results
      case Either SomeException b
res of
        Left SomeException
err -> forall a e. Exception e => e -> a
throw (SomeException
err :: SomeException)
        Right b
v -> 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 =
  (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a
m) forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` 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 =
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
      | Bool
otherwise =
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ 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
  | forall a. RealFloat a => a -> Bool
isInfinite from
v, from
v forall a. Ord a => a -> a -> Bool
> from
0 = to
1 forall a. Fractional a => a -> a -> a
/ to
0
  | forall a. RealFloat a => a -> Bool
isInfinite from
v, from
v forall a. Ord a => a -> a -> Bool
< from
0 = -to
1 forall a. Fractional a => a -> a -> a
/ to
0
  | forall a. RealFloat a => a -> Bool
isNaN from
v = to
0 forall a. Fractional a => a -> a -> a
/ to
0
  | Bool
otherwise = forall a. Fractional a => Rational -> a
fromRational forall a b. (a -> b) -> a -> b
$ 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

-- | Z-encode a string using a slightly simplified variant of GHC
-- Z-encoding.  The encoded string is a valid identifier in most
-- programming languages.
zEncodeString :: UserString -> EncodedString
zEncodeString :: String -> String
zEncodeString String
"" = String
""
zEncodeString (Char
c : String
cs) = Char -> String
encodeDigitChar Char
c forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> String
encodeChar String
cs

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'
    forall a. a -> [a] -> [a]
: if Char -> Bool
isDigit (forall a. [a] -> a
head String
hex_str)
      then String
hex_str
      else Char
'0' forall a. a -> [a] -> [a]
: String
hex_str
  where
    hex_str :: String
hex_str = forall a. (Integral a, Show 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 -> String -> String
atMostChars :: Int -> String -> String
atMostChars Int
n String
s
  | forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s forall a. Ord a => a -> a -> Bool
> Int
n = forall a. Int -> [a] -> [a]
take (Int
n forall a. Num a => a -> a -> a
- Int
3) String
s forall a. [a] -> [a] -> [a]
++ String
"..."
  | Bool
otherwise = String
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 =
  forall k a. Map k a -> [(k, a)]
M.toList Map k v
m
    forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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 (b, d) (c, d)
first forall a. a -> Set a
S.singleton)
    forall a b. a -> (a -> b) -> b
& forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith forall a. Semigroup a => a -> a -> a
(<>)) forall a. Monoid a => a
mempty

-- | 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, 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' forall a. Eq a => a -> a -> Bool
== a
x then a
x else forall a. Eq a => (a -> a) -> a -> a
fixPoint a -> a
f a
x'