module UVMHS.Core.IO
  ( module UVMHS.Core.IO 
  , module System.IO.Error
  , module System.Exit
  ) where

import UVMHS.Core.Init
import UVMHS.Core.Classes
import UVMHS.Core.Data
import UVMHS.Core.Monads ()
import UVMHS.Core.Time
import UVMHS.Core.FilePath

import System.Exit     (ExitCode)
import System.IO.Error (IOError)

import qualified Control.Exception     as HS
import qualified Data.ByteString       as BS
import qualified Data.IORef            as IORef
import qualified Data.Text.Encoding    as Text
import qualified GHC.IO.Handle         as IO
import qualified GHC.Stats             as Stat
import qualified Prelude               as HS
import qualified System.Directory      as Dir
import qualified System.Directory      as HS
import qualified System.Environment    as Env
import qualified System.Exit           as Exit
import qualified System.Exit           as HS
import qualified System.IO             as IO
import qualified System.IO.Error       as HS
import qualified System.IO.Unsafe      as IO
import qualified System.Mem            as Mem
import qualified System.Process        as Proc

infix 1 ↢

----------------
-- REFERENCES --
----------------

type 𝑅 = IORef.IORef

ref ∷ a → IO (𝑅 a)
ref :: forall a. a -> IO (𝑅 a)
ref = a -> IO (IORef a)
forall a. a -> IO (𝑅 a)
IORef.newIORef

deref ∷ 𝑅 a → IO a
deref :: forall a. 𝑅 a -> IO a
deref = IORef a -> IO a
forall a. 𝑅 a -> IO a
IORef.readIORef

(↢) ∷ 𝑅 a → a → IO ()
↢ :: forall a. 𝑅 a -> a -> IO ()
(↢) = IORef a -> a -> IO ()
forall a. 𝑅 a -> a -> IO ()
IORef.writeIORef
---------------
-- Unsafe IO --
---------------

io_UNSAFE ∷ IO a → a
io_UNSAFE :: forall a. IO a -> a
io_UNSAFE = IO a -> a
forall a. IO a -> a
IO.unsafePerformIO

----------
-- INIT --
----------

initUVMHS ∷ IO ()
initUVMHS :: IO ()
initUVMHS = do
  Handle -> TextEncoding -> IO ()
IO.hSetEncoding Handle
IO.stdin  TextEncoding
IO.utf8
  Handle -> TextEncoding -> IO ()
IO.hSetEncoding Handle
IO.stdout TextEncoding
IO.utf8
  Handle -> TextEncoding -> IO ()
IO.hSetEncoding Handle
IO.stderr TextEncoding
IO.utf8

------------------
-- Standard Out --
------------------

owrite ∷ 𝕊 → IO ()
owrite :: 𝕊 -> IO ()
owrite = ByteString -> IO ()
BS.putStr (ByteString -> IO ()) -> (𝕊 -> ByteString) -> 𝕊 -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
∘ 𝕊 -> ByteString
Text.encodeUtf8

out ∷ 𝕊 → IO ()
out :: 𝕊 -> IO ()
out 𝕊
s = [IO ()] -> IO ()
forall (m :: * -> *) t. (Monad m, ToIter (m ()) t) => t -> m ()
exec [𝕊 -> IO ()
owrite 𝕊
s,𝕊 -> IO ()
owrite 𝕊
"\n"]

outs ∷ (ToIter 𝕊 t) ⇒ t → IO ()
outs :: forall t. ToIter 𝕊 t => t -> IO ()
outs t
ss = t -> (𝕊 -> IO ()) -> IO ()
forall (m :: * -> *) a t.
(Monad m, ToIter a t) =>
t -> (a -> m ()) -> m ()
eachOn t
ss 𝕊 -> IO ()
out

oflush ∷ IO ()
oflush :: IO ()
oflush = Handle -> IO ()
IO.hFlush Handle
IO.stdout

shout ∷ (Show a) ⇒ a → IO ()
shout :: forall a. Show a => a -> IO ()
shout = 𝕊 -> IO ()
out (𝕊 -> IO ()) -> (a -> 𝕊) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
∘ a -> 𝕊
forall a. Show a => a -> 𝕊
show𝕊

trace ∷ 𝕊 → ()
trace :: 𝕊 -> ()
trace 𝕊
s = IO () -> ()
forall a. IO a -> a
io_UNSAFE (IO () -> ()) -> IO () -> ()
forall a b. (a -> b) -> a -> b
$ do
  𝕊 -> IO ()
out 𝕊
s
  IO ()
oflush
  () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Return m => a -> m a
return ()

traceM ∷ (Monad m) ⇒ 𝕊 → m ()
traceM :: forall (m :: * -> *). Monad m => 𝕊 -> m ()
traceM 𝕊
msg =
  let ()
_ = 𝕊 -> ()
trace 𝕊
msg 
  in m ()
forall (m :: * -> *). Return m => m ()
skip

------------------
-- Standard Err --
------------------

ewrite ∷ 𝕊 → IO ()
ewrite :: 𝕊 -> IO ()
ewrite = Handle -> ByteString -> IO ()
BS.hPutStr Handle
IO.stderr (ByteString -> IO ()) -> (𝕊 -> ByteString) -> 𝕊 -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
∘ 𝕊 -> ByteString
Text.encodeUtf8

err ∷ 𝕊 → IO ()
err :: 𝕊 -> IO ()
err 𝕊
s = [IO ()] -> IO ()
forall (m :: * -> *) t. (Monad m, ToIter (m ()) t) => t -> m ()
exec [𝕊 -> IO ()
ewrite 𝕊
s,𝕊 -> IO ()
ewrite 𝕊
"\n"]

eflush ∷ IO ()
eflush :: IO ()
eflush = Handle -> IO ()
IO.hFlush Handle
IO.stderr

redirectErrToOut ∷ IO ()
redirectErrToOut :: IO ()
redirectErrToOut = Handle -> Handle -> IO ()
IO.hDuplicateTo Handle
IO.stdout Handle
IO.stderr

-----------------
-- Standard In --
-----------------

iread ∷ IO 𝕊
iread :: IO 𝕊
iread = ByteString -> 𝕊
Text.decodeUtf8 (ByteString -> 𝕊) -> IO ByteString -> IO 𝕊
forall (t :: * -> *) a b. Functor t => (a -> b) -> t a -> t b
^$ IO ByteString
BS.getContents

iargs ∷ IO (𝐿 𝕊)
iargs :: IO (𝐿 𝕊)
iargs = ([String] -> 𝐿 𝕊) -> IO [String] -> IO (𝐿 𝕊)
forall a b. (a -> b) -> IO a -> IO b
forall (t :: * -> *) a b. Functor t => (a -> b) -> t a -> t b
map ([𝕊] -> 𝐿 𝕊
forall a t. ToIter a t => t -> 𝐿 a
list ([𝕊] -> 𝐿 𝕊) -> ([String] -> [𝕊]) -> [String] -> 𝐿 𝕊
forall b c a. (b -> c) -> (a -> b) -> a -> c
∘ (String -> 𝕊) -> [String] -> [𝕊]
forall a b. (a -> b) -> [a] -> [b]
forall (t :: * -> *) a b. Functor t => (a -> b) -> t a -> t b
map String -> 𝕊
forall t. ToIter ℂ t => t -> 𝕊
string) IO [String]
Env.getArgs

ilocalArgs ∷ 𝐿 𝕊 → IO a → IO a
ilocalArgs :: forall a. 𝐿 𝕊 -> IO a -> IO a
ilocalArgs 𝐿 𝕊
args = [String] -> IO a -> IO a
forall a. [String] -> IO a -> IO a
Env.withArgs ([String] -> IO a -> IO a) -> [String] -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ 𝐼 String -> [String]
forall a t. ToIter a t => t -> [a]
lazyList (𝐼 String -> [String]) -> 𝐼 String -> [String]
forall a b. (a -> b) -> a -> b
$ (𝕊 -> String) -> 𝐼 𝕊 -> 𝐼 String
forall a b. (a -> b) -> 𝐼 a -> 𝐼 b
forall (t :: * -> *) a b. Functor t => (a -> b) -> t a -> t b
map 𝕊 -> String
tohsChars (𝐼 𝕊 -> 𝐼 String) -> 𝐼 𝕊 -> 𝐼 String
forall a b. (a -> b) -> a -> b
$ 𝐿 𝕊 -> 𝐼 𝕊
forall a t. ToIter a t => t -> 𝐼 a
iter 𝐿 𝕊
args

------------
-- Errors --
------------

abortIOCode ∷ ℤ64 → IO a
abortIOCode :: forall a. ℤ64 -> IO a
abortIOCode ℤ64
i = ExitCode -> IO a
forall a. ExitCode -> IO a
HS.exitWith (ExitCode -> IO a) -> ExitCode -> IO a
forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
HS.ExitFailure (Int -> ExitCode) -> Int -> ExitCode
forall a b. (a -> b) -> a -> b
$ ℤ64 -> Int
forall a b. CHS a b => a -> b
tohs ℤ64
i

abortIO ∷ IO a
abortIO :: forall a. IO a
abortIO = ℤ64 -> IO a
forall a. ℤ64 -> IO a
abortIOCode (ℤ64 -> IO a) -> ℤ64 -> IO a
forall a b. (a -> b) -> a -> b
$ ℕ -> ℤ64
𝕫64 ℕ
1

exitIO ∷ IO a
exitIO :: forall a. IO a
exitIO = ExitCode -> IO a
forall a. ExitCode -> IO a
HS.exitWith (ExitCode -> IO a) -> ExitCode -> IO a
forall a b. (a -> b) -> a -> b
$ ExitCode
HS.ExitSuccess

failIO ∷ 𝕊 → IO a
failIO :: forall a. 𝕊 -> IO a
failIO = String -> IO a
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
HS.fail (String -> IO a) -> (𝕊 -> String) -> 𝕊 -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
∘ 𝕊 -> String
tohsChars

throwIO ∷ IOError → IO a
throwIO :: forall a. IOError -> IO a
throwIO = IOError -> IO a
forall a. IOError -> IO a
HS.ioError

catchIO ∷ IO a → (IOError → IO a) → IO a
catchIO :: forall a. IO a -> (IOError -> IO a) -> IO a
catchIO = IO a -> (IOError -> IO a) -> IO a
forall a. IO a -> (IOError -> IO a) -> IO a
HS.catchIOError

cleanExit ∷ IO a → IO a
cleanExit :: forall a. IO a -> IO a
cleanExit IO a
xM = IO a -> (ExitCode -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
HS.catch IO a
xM (\ (ExitCode
c ∷ ExitCode) → ExitCode -> IO ()
forall a. Show a => a -> IO ()
shout ExitCode
c IO () -> IO a -> IO a
forall (m :: * -> *) a b. Bind m => m a -> m b -> m b
≫ IO a
forall a. IO a
exitIO)

-----------
-- Files --
-----------

fread ∷ ℙ → IO 𝕊
fread :: ℙ -> IO 𝕊
fread = ByteString -> 𝕊
Text.decodeUtf8 (ByteString -> 𝕊) -> (String -> IO ByteString) -> String -> IO 𝕊
forall (t :: * -> *) b c a.
Functor t =>
(b -> c) -> (a -> t b) -> a -> t c
^∘ String -> IO ByteString
BS.readFile (String -> IO 𝕊) -> (𝕊 -> String) -> 𝕊 -> IO 𝕊
forall b c a. (b -> c) -> (a -> b) -> a -> c
∘ 𝕊 -> String
tohsChars (𝕊 -> IO 𝕊) -> (ℙ -> 𝕊) -> ℙ -> IO 𝕊
forall b c a. (b -> c) -> (a -> b) -> a -> c
∘ ℙ -> 𝕊
unℙ

fwrite ∷ ℙ → 𝕊 → IO ()
fwrite :: ℙ -> 𝕊 -> IO ()
fwrite ℙ
file = String -> ByteString -> IO ()
BS.writeFile (𝕊 -> String
tohsChars (𝕊 -> String) -> 𝕊 -> String
forall a b. (a -> b) -> a -> b
$ ℙ -> 𝕊
unℙ ℙ
file) (ByteString -> IO ()) -> (𝕊 -> ByteString) -> 𝕊 -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
∘ 𝕊 -> ByteString
Text.encodeUtf8

fappend ∷ ℙ → 𝕊 → IO ()
fappend :: ℙ -> 𝕊 -> IO ()
fappend ℙ
fn = String -> ByteString -> IO ()
BS.appendFile (𝕊 -> String
tohsChars (𝕊 -> String) -> 𝕊 -> String
forall a b. (a -> b) -> a -> b
$ ℙ -> 𝕊
unℙ ℙ
fn) (ByteString -> IO ()) -> (𝕊 -> ByteString) -> 𝕊 -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
∘ 𝕊 -> ByteString
Text.encodeUtf8

fcopy ∷ ℙ → ℙ → IO ()
fcopy :: ℙ -> ℙ -> IO ()
fcopy ℙ
fr ℙ
to = String -> String -> IO ()
Dir.copyFile (𝕊 -> String
tohsChars (𝕊 -> String) -> 𝕊 -> String
forall a b. (a -> b) -> a -> b
$ ℙ -> 𝕊
unℙ ℙ
fr) (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ 𝕊 -> String
tohsChars (𝕊 -> String) -> 𝕊 -> String
forall a b. (a -> b) -> a -> b
$ ℙ -> 𝕊
unℙ ℙ
to

-----------------
-- Directories --
-----------------

dfilesAll ∷ IO (𝐿 ℙ)
dfilesAll :: IO (𝐿 ℙ)
dfilesAll = 𝐿 ℙ -> 𝐿 ℙ
forall a t. (ToIter a t, Ord a) => t -> 𝐿 a
sort (𝐿 ℙ -> 𝐿 ℙ) -> ([ℙ] -> 𝐿 ℙ) -> [ℙ] -> 𝐿 ℙ
forall b c a. (b -> c) -> (a -> b) -> a -> c
∘ [ℙ] -> 𝐿 ℙ
forall a t. ToIter a t => t -> 𝐿 a
list ([ℙ] -> 𝐿 ℙ) -> ([String] -> [ℙ]) -> [String] -> 𝐿 ℙ
forall b c a. (b -> c) -> (a -> b) -> a -> c
∘ (String -> ℙ) -> [String] -> [ℙ]
forall a b. (a -> b) -> [a] -> [b]
forall (t :: * -> *) a b. Functor t => (a -> b) -> t a -> t b
map (𝕊 -> ℙ
ℙ (𝕊 -> ℙ) -> (String -> 𝕊) -> String -> ℙ
forall b c a. (b -> c) -> (a -> b) -> a -> c
∘ String -> 𝕊
forall t. ToIter ℂ t => t -> 𝕊
string) ([String] -> 𝐿 ℙ) -> IO [String] -> IO (𝐿 ℙ)
forall (t :: * -> *) a b. Functor t => (a -> b) -> t a -> t b
^$ String -> IO [String]
Dir.listDirectory (String -> IO [String]) -> String -> IO [String]
forall a b. (a -> b) -> a -> b
$ 𝕊 -> String
tohsChars 𝕊
"."

dfiles ∷ IO (𝐿 ℙ)
dfiles :: IO (𝐿 ℙ)
dfiles = do
  𝐿 ℙ
files ← IO (𝐿 ℙ)
dfilesAll
  𝐿 ℙ -> IO (𝐿 ℙ)
forall a. a -> IO a
forall (m :: * -> *) a. Return m => a -> m a
return (𝐿 ℙ -> IO (𝐿 ℙ)) -> 𝐿 ℙ -> IO (𝐿 ℙ)
forall a b. (a -> b) -> a -> b
$ 𝐼 ℙ -> 𝐿 ℙ
forall a t. ToIter a t => t -> 𝐿 a
list (𝐼 ℙ -> 𝐿 ℙ) -> 𝐼 ℙ -> 𝐿 ℙ
forall a b. (a -> b) -> a -> b
$ 𝐿 ℙ -> (ℙ -> 𝔹) -> 𝐼 ℙ
forall a t. ToIter a t => t -> (a -> 𝔹) -> 𝐼 a
filterOn 𝐿 ℙ
files ((ℙ -> 𝔹) -> 𝐼 ℙ) -> (ℙ -> 𝔹) -> 𝐼 ℙ
forall a b. (a -> b) -> a -> b
$ \ ℙ
f → case 𝕊 -> 𝑂 ℂ
forall a t. ToIter a t => t -> 𝑂 a
firstElem (𝕊 -> 𝑂 ℂ) -> 𝕊 -> 𝑂 ℂ
forall a b. (a -> b) -> a -> b
$ ℙ -> 𝕊
unℙ ℙ
f of
    𝑂 ℂ
None → 𝔹
False
    Some ℂ
c → ℂ
c ℂ -> ℂ -> 𝔹
forall a. Eq a => a -> a -> 𝔹
≢ ℂ
'.'

din ∷ ℙ → IO a → IO a
din :: forall a. ℙ -> IO a -> IO a
din = String -> IO a -> IO a
forall a. String -> IO a -> IO a
Dir.withCurrentDirectory (String -> IO a -> IO a) -> (𝕊 -> String) -> 𝕊 -> IO a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
∘ 𝕊 -> String
tohsChars (𝕊 -> IO a -> IO a) -> (ℙ -> 𝕊) -> ℙ -> IO a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
∘ ℙ -> 𝕊
unℙ

dtouch ∷ ℙ → IO ()
dtouch :: ℙ -> IO ()
dtouch = 𝔹 -> String -> IO ()
Dir.createDirectoryIfMissing 𝔹
True (String -> IO ()) -> (𝕊 -> String) -> 𝕊 -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
∘ 𝕊 -> String
tohsChars (𝕊 -> IO ()) -> (ℙ -> 𝕊) -> ℙ -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
∘ ℙ -> 𝕊
unℙ

drremove ∷ ℙ → IO ()
drremove :: ℙ -> IO ()
drremove = String -> IO ()
Dir.removeDirectoryRecursive (String -> IO ()) -> (𝕊 -> String) -> 𝕊 -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
∘ 𝕊 -> String
tohsChars (𝕊 -> IO ()) -> (ℙ -> 𝕊) -> ℙ -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
∘ ℙ -> 𝕊
unℙ

dcurrent ∷ IO ℙ
dcurrent :: IO ℙ
dcurrent = 𝕊 -> ℙ
ℙ (𝕊 -> ℙ) -> (String -> 𝕊) -> String -> ℙ
forall b c a. (b -> c) -> (a -> b) -> a -> c
∘ String -> 𝕊
forall t. ToIter ℂ t => t -> 𝕊
string (String -> ℙ) -> IO String -> IO ℙ
forall (t :: * -> *) a b. Functor t => (a -> b) -> t a -> t b
^$ IO String
HS.getCurrentDirectory

-----------
-- Paths --
-----------

pexists ∷ ℙ → IO 𝔹
pexists :: ℙ -> IO 𝔹
pexists = String -> IO 𝔹
Dir.doesPathExist (String -> IO 𝔹) -> (𝕊 -> String) -> 𝕊 -> IO 𝔹
forall b c a. (b -> c) -> (a -> b) -> a -> c
∘ 𝕊 -> String
tohsChars (𝕊 -> IO 𝔹) -> (ℙ -> 𝕊) -> ℙ -> IO 𝔹
forall b c a. (b -> c) -> (a -> b) -> a -> c
∘ ℙ -> 𝕊
unℙ

-----------
-- Shell --
-----------

shell ∷ 𝕊 → IO (𝔹 ∧ 𝕊 ∧ 𝕊)
shell :: 𝕊 -> IO ((𝔹 ∧ 𝕊) ∧ 𝕊)
shell 𝕊
c = do
  (ExitCode
e,String
o,String
r) ← CreateProcess -> String -> IO (ExitCode, String, String)
Proc.readCreateProcessWithExitCode (String -> CreateProcess
Proc.shell (String -> CreateProcess) -> String -> CreateProcess
forall a b. (a -> b) -> a -> b
$ 𝕊 -> String
tohsChars 𝕊
c) []
  ((𝔹 ∧ 𝕊) ∧ 𝕊) -> IO ((𝔹 ∧ 𝕊) ∧ 𝕊)
forall a. a -> IO a
forall (m :: * -> *) a. Return m => a -> m a
return (((𝔹 ∧ 𝕊) ∧ 𝕊) -> IO ((𝔹 ∧ 𝕊) ∧ 𝕊))
-> ((𝔹 ∧ 𝕊) ∧ 𝕊) -> IO ((𝔹 ∧ 𝕊) ∧ 𝕊)
forall a b. (a -> b) -> a -> b
$ (ExitCode
e ExitCode -> ExitCode -> 𝔹
forall a. Eq a => a -> a -> 𝔹
≡ ExitCode
Exit.ExitSuccess) 𝔹 -> 𝕊 -> 𝔹 ∧ 𝕊
forall a b. a -> b -> a ∧ b
:* String -> 𝕊
forall t. ToIter ℂ t => t -> 𝕊
string String
o (𝔹 ∧ 𝕊) -> 𝕊 -> (𝔹 ∧ 𝕊) ∧ 𝕊
forall a b. a -> b -> a ∧ b
:* String -> 𝕊
forall t. ToIter ℂ t => t -> 𝕊
string String
r

shellOK ∷ 𝕊 → IO 𝕊
shellOK :: 𝕊 -> IO 𝕊
shellOK 𝕊
c = do
  (𝔹
e :* 𝕊
o :* 𝕊
r) ← 𝕊 -> IO ((𝔹 ∧ 𝕊) ∧ 𝕊)
shell 𝕊
c
  case 𝔹
e of
    𝔹
True → 𝕊 -> IO 𝕊
forall a. a -> IO a
forall (m :: * -> *) a. Return m => a -> m a
return 𝕊
o
    𝔹
False → do
      𝕊 -> IO ()
out 𝕊
r
      𝕊 -> IO 𝕊
forall a. 𝕊 -> IO a
failIO 𝕊
r

shelll ∷ 𝕊 → IO (𝔹 ∧ 𝕊 ∧ 𝕊)
shelll :: 𝕊 -> IO ((𝔹 ∧ 𝕊) ∧ 𝕊)
shelll 𝕊
c = do
  𝕊 -> IO ()
out (𝕊 -> IO ()) -> 𝕊 -> IO ()
forall a b. (a -> b) -> a -> b
$ 𝕊
"(sh) > " 𝕊 -> 𝕊 -> 𝕊
forall a. Append a => a -> a -> a
⧺ 𝕊
c
  𝕊 -> IO ((𝔹 ∧ 𝕊) ∧ 𝕊)
shell 𝕊
c

shelllOK ∷ 𝕊 → IO 𝕊
shelllOK :: 𝕊 -> IO 𝕊
shelllOK 𝕊
c = do
  𝕊 -> IO ()
out (𝕊 -> IO ()) -> 𝕊 -> IO ()
forall a b. (a -> b) -> a -> b
$ 𝕊
"(sh) > " 𝕊 -> 𝕊 -> 𝕊
forall a. Append a => a -> a -> a
⧺ 𝕊
c
  𝕊 -> IO 𝕊
shellOK 𝕊
c

--------
-- GC --
--------

gc ∷ IO ()
gc :: IO ()
gc = IO ()
Mem.performGC

---------------
-- Profiling --
---------------

time ∷ (() → a) → IO (a ∧ TimeD)
time :: forall a. (() -> a) -> IO (a ∧ TimeD)
time () -> a
f = do
  IO ()
gc
  Time
t₁ ← IO Time
now
  let x :: a
x = () -> a
f ()
  IO ()
gc
  Time
t₂ ← IO Time
now
  (a ∧ TimeD) -> IO (a ∧ TimeD)
forall a. a -> IO a
forall (m :: * -> *) a. Return m => a -> m a
return ((a ∧ TimeD) -> IO (a ∧ TimeD)) -> (a ∧ TimeD) -> IO (a ∧ TimeD)
forall a b. (a -> b) -> a -> b
$ a
x a -> TimeD -> a ∧ TimeD
forall a b. a -> b -> a ∧ b
:* (Time
t₂ Time -> Time -> TimeD
⨺ Time
t₁)

rtime ∷ 𝕊 → (() → a) → IO a
rtime :: forall a. 𝕊 -> (() -> a) -> IO a
rtime 𝕊
s () -> a
f = do
  do 𝕊 -> IO ()
out (𝕊 -> IO ()) -> 𝕊 -> IO ()
forall a b. (a -> b) -> a -> b
$ 𝕊
"TIMING: " 𝕊 -> 𝕊 -> 𝕊
forall a. Append a => a -> a -> a
⧺ 𝕊
s ; IO ()
oflush
  a
x :* TimeD
t ← (() -> a) -> IO (a ∧ TimeD)
forall a. (() -> a) -> IO (a ∧ TimeD)
time () -> a
f
  do 𝕊 -> IO ()
out (𝕊 -> IO ()) -> 𝕊 -> IO ()
forall a b. (a -> b) -> a -> b
$ 𝕊
"RESULT: " 𝕊 -> 𝕊 -> 𝕊
forall a. Append a => a -> a -> a
⧺ TimeD -> 𝕊
forall a. Show a => a -> 𝕊
show𝕊 TimeD
t ; IO ()
oflush
  a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Return m => a -> m a
return a
x

timeIO ∷ IO a → IO (a ∧ TimeD)
timeIO :: forall a. IO a -> IO (a ∧ TimeD)
timeIO IO a
xM = do
  IO ()
gc
  Time
t₁ ← IO Time
now
  a
x ← IO a
xM
  IO ()
gc
  Time
t₂ ← IO Time
now
  (a ∧ TimeD) -> IO (a ∧ TimeD)
forall a. a -> IO a
forall (m :: * -> *) a. Return m => a -> m a
return ((a ∧ TimeD) -> IO (a ∧ TimeD)) -> (a ∧ TimeD) -> IO (a ∧ TimeD)
forall a b. (a -> b) -> a -> b
$ a
x a -> TimeD -> a ∧ TimeD
forall a b. a -> b -> a ∧ b
:* (Time
t₂ Time -> Time -> TimeD
⨺ Time
t₁)

rtimeIO ∷ 𝕊 → IO a → IO a
rtimeIO :: forall a. 𝕊 -> IO a -> IO a
rtimeIO 𝕊
s IO a
xM = do
  do 𝕊 -> IO ()
out (𝕊 -> IO ()) -> 𝕊 -> IO ()
forall a b. (a -> b) -> a -> b
$ 𝕊
"TIMING: " 𝕊 -> 𝕊 -> 𝕊
forall a. Append a => a -> a -> a
⧺ 𝕊
s ; IO ()
oflush
  a
x :* TimeD
t ← IO a -> IO (a ∧ TimeD)
forall a. IO a -> IO (a ∧ TimeD)
timeIO IO a
xM
  do 𝕊 -> IO ()
out (𝕊 -> IO ()) -> 𝕊 -> IO ()
forall a b. (a -> b) -> a -> b
$ 𝕊
"RESULT: " 𝕊 -> 𝕊 -> 𝕊
forall a. Append a => a -> a -> a
⧺ TimeD -> 𝕊
forall a. Show a => a -> 𝕊
show𝕊 TimeD
t ; IO ()
oflush
  a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Return m => a -> m a
return a
x

profile ∷ IO a → IO (a ∧ 𝔻 ∧ 𝔻)
profile :: forall a. IO a -> IO ((a ∧ 𝔻) ∧ 𝔻)
profile IO a
xM = do
  IO ()
gc
  RTSStats
s₁ ← IO RTSStats
Stat.getRTSStats
  a
x ← IO a
xM
  IO ()
gc
  RTSStats
s₂ ← IO RTSStats
Stat.getRTSStats
  let -- total number of major GCs
      n₁ :: Word32
n₁ = RTSStats -> Word32
Stat.major_gcs RTSStats
s₁
      -- sum of live bytes across all major GCs
      u₁ :: Word64
u₁ = RTSStats -> Word64
Stat.cumulative_live_bytes RTSStats
s₁
      -- total CPU time at previous GC in nanoseconds
      t₁ :: ℤ64
t₁ = RTSStats -> ℤ64
Stat.cpu_ns RTSStats
s₁
      -- 
      n₂ :: Word32
n₂ = RTSStats -> Word32
Stat.major_gcs RTSStats
s₂
      u₂ :: Word64
u₂ = RTSStats -> Word64
Stat.cumulative_live_bytes RTSStats
s₂
      t₂ :: ℤ64
t₂ = RTSStats -> ℤ64
Stat.cpu_ns RTSStats
s₂
      --
      -- elapsed CPU time in seconds
      t' :: 𝔻
t' = ℤ64 -> 𝔻
forall a. ToDouble a => a -> 𝔻
dbl (ℤ64
t₂ ℤ64 -> ℤ64 -> ℤ64
forall a. Minus a => a -> a -> a
- ℤ64
t₁) 𝔻 -> 𝔻 -> 𝔻
forall a. Divide a => a -> a -> a
/ 𝔻
1000000000.0 
      -- average live data across GCs
      m :: 𝔻
m  = Word64 -> 𝔻
forall a. ToDouble a => a -> 𝔻
dbl (Word64
u₂ Word64 -> Word64 -> Word64
forall a. Minus a => a -> a -> a
- Word64
u₁) 𝔻 -> 𝔻 -> 𝔻
forall a. Divide a => a -> a -> a
/ Word32 -> 𝔻
forall a. ToDouble a => a -> 𝔻
dbl (Word32
n₂ Word32 -> Word32 -> Word32
forall a. Minus a => a -> a -> a
- Word32
n₁)
  ((a ∧ 𝔻) ∧ 𝔻) -> IO ((a ∧ 𝔻) ∧ 𝔻)
forall a. a -> IO a
forall (m :: * -> *) a. Return m => a -> m a
return (((a ∧ 𝔻) ∧ 𝔻) -> IO ((a ∧ 𝔻) ∧ 𝔻))
-> ((a ∧ 𝔻) ∧ 𝔻) -> IO ((a ∧ 𝔻) ∧ 𝔻)
forall a b. (a -> b) -> a -> b
$ a
x a -> 𝔻 -> a ∧ 𝔻
forall a b. a -> b -> a ∧ b
:* 𝔻
t' (a ∧ 𝔻) -> 𝔻 -> (a ∧ 𝔻) ∧ 𝔻
forall a b. a -> b -> a ∧ b
:* 𝔻
m