-
Notifications
You must be signed in to change notification settings - Fork 335
/
IO.lean
697 lines (552 loc) · 24.2 KB
/
IO.lean
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Luke Nelson, Jared Roesch, Leonardo de Moura, Sebastian Ullrich
-/
prelude
import Init.Control.EState
import Init.Control.Reader
import Init.Data.String
import Init.Data.ByteArray
import Init.System.IOError
import Init.System.FilePath
import Init.System.ST
import Init.Data.ToString.Macro
import Init.Data.Ord
open System
/-- Like https://hackage.haskell.org/package/ghc-Prim-0.5.2.0/docs/GHC-Prim.html#t:RealWorld.
Makes sure we never reorder `IO` operations.
TODO: mark opaque -/
def IO.RealWorld : Type := Unit
/- TODO(Leo): mark it as an opaque definition. Reason: prevent
functions defined in other modules from accessing `IO.RealWorld`.
We don't want action such as
```
def getWorld : IO (IO.RealWorld) := get
```
-/
def EIO (ε : Type) : Type → Type := EStateM ε IO.RealWorld
instance : Monad (EIO ε) := inferInstanceAs (Monad (EStateM ε IO.RealWorld))
instance : MonadFinally (EIO ε) := inferInstanceAs (MonadFinally (EStateM ε IO.RealWorld))
instance : MonadExceptOf ε (EIO ε) := inferInstanceAs (MonadExceptOf ε (EStateM ε IO.RealWorld))
instance : OrElse (EIO ε α) := ⟨MonadExcept.orElse⟩
instance [Inhabited ε] : Inhabited (EIO ε α) := inferInstanceAs (Inhabited (EStateM ε IO.RealWorld α))
/-- An `EIO` monad that cannot throw exceptions. -/
def BaseIO := EIO Empty
instance : Monad BaseIO := inferInstanceAs (Monad (EIO Empty))
instance : MonadFinally BaseIO := inferInstanceAs (MonadFinally (EIO Empty))
@[inline] def BaseIO.toEIO (act : BaseIO α) : EIO ε α :=
fun s => match act s with
| EStateM.Result.ok a s => EStateM.Result.ok a s
instance : MonadLift BaseIO (EIO ε) := ⟨BaseIO.toEIO⟩
@[inline] def EIO.toBaseIO (act : EIO ε α) : BaseIO (Except ε α) :=
fun s => match act s with
| EStateM.Result.ok a s => EStateM.Result.ok (Except.ok a) s
| EStateM.Result.error ex s => EStateM.Result.ok (Except.error ex) s
@[inline] def EIO.catchExceptions (act : EIO ε α) (h : ε → BaseIO α) : BaseIO α :=
fun s => match act s with
| EStateM.Result.ok a s => EStateM.Result.ok a s
| EStateM.Result.error ex s => h ex s
open IO (Error) in
abbrev IO : Type → Type := EIO Error
@[inline] def BaseIO.toIO (act : BaseIO α) : IO α :=
act
@[inline] def EIO.toIO (f : ε → IO.Error) (act : EIO ε α) : IO α :=
act.adaptExcept f
@[inline] def EIO.toIO' (act : EIO ε α) : IO (Except ε α) :=
act.toBaseIO
@[inline] def IO.toEIO (f : IO.Error → ε) (act : IO α) : EIO ε α :=
act.adaptExcept f
/- After we inline `EState.run'`, the closed term `((), ())` is generated, where the second `()`
represents the "initial world". We don't want to cache this closed term. So, we disable
the "extract closed terms" optimization. -/
set_option compiler.extract_closed false in
@[inline] unsafe def unsafeBaseIO (fn : BaseIO α) : α :=
match fn.run () with
| EStateM.Result.ok a _ => a
@[inline] unsafe def unsafeEIO (fn : EIO ε α) : Except ε α :=
unsafeBaseIO fn.toBaseIO
@[inline] unsafe def unsafeIO (fn : IO α) : Except IO.Error α :=
unsafeEIO fn
@[extern "lean_io_timeit"] constant timeit (msg : @& String) (fn : IO α) : IO α
@[extern "lean_io_allocprof"] constant allocprof (msg : @& String) (fn : IO α) : IO α
/- Programs can execute IO actions during initialization that occurs before
the `main` function is executed. The attribute `[init <action>]` specifies
which IO action is executed to set the value of an opaque constant.
The action `initializing` returns `true` iff it is invoked during initialization. -/
@[extern "lean_io_initializing"] constant IO.initializing : BaseIO Bool
namespace BaseIO
/--
Run `act` in a separate `Task`.
This is similar to Haskell's [`unsafeInterleaveIO`](http://hackage.haskell.org/package/base-4.14.0.0/docs/System-IO-Unsafe.html#v:unsafeInterleaveIO),
except that the `Task` is started eagerly as usual. Thus pure accesses to the `Task` do not influence the impure `act`
computation.
Unlike with pure tasks created by `Task.spawn`, tasks created by this function will be run even if the last reference
to the task is dropped. The `act` should manually check for cancellation via `IO.checkCanceled` if it wants to react
to that. -/
@[extern "lean_io_as_task"]
constant asTask (act : BaseIO α) (prio := Task.Priority.default) : BaseIO (Task α) :=
Task.pure <$> act
/-- See `BaseIO.asTask`. -/
@[extern "lean_io_map_task"]
constant mapTask (f : α → BaseIO β) (t : Task α) (prio := Task.Priority.default) : BaseIO (Task β) :=
Task.pure <$> f t.get
/-- See `BaseIO.asTask`. -/
@[extern "lean_io_bind_task"]
constant bindTask (t : Task α) (f : α → BaseIO (Task β)) (prio := Task.Priority.default) : BaseIO (Task β) :=
f t.get
def mapTasks (f : List α → BaseIO β) (tasks : List (Task α)) (prio := Task.Priority.default) : BaseIO (Task β) :=
go tasks []
where
go
| t::ts, as =>
BaseIO.bindTask t (fun a => go ts (a :: as)) prio
| [], as => f as.reverse |>.asTask prio
end BaseIO
namespace EIO
/-- `EIO` specialization of `BaseIO.asTask`. -/
@[inline] def asTask (act : EIO ε α) (prio := Task.Priority.default) : BaseIO (Task (Except ε α)) :=
act.toBaseIO.asTask prio
/-- `EIO` specialization of `BaseIO.mapTask`. -/
@[inline] def mapTask (f : α → EIO ε β) (t : Task α) (prio := Task.Priority.default) : BaseIO (Task (Except ε β)) :=
BaseIO.mapTask (fun a => f a |>.toBaseIO) t prio
/-- `EIO` specialization of `BaseIO.bindTask`. -/
@[inline] def bindTask (t : Task α) (f : α → EIO ε (Task (Except ε β))) (prio := Task.Priority.default) : BaseIO (Task (Except ε β)) :=
BaseIO.bindTask t (fun a => f a |>.catchExceptions fun e => return Task.pure <| Except.error e) prio
/-- `EIO` specialization of `BaseIO.mapTasks`. -/
@[inline] def mapTasks (f : List α → EIO ε β) (tasks : List (Task α)) (prio := Task.Priority.default) : BaseIO (Task (Except ε β)) :=
BaseIO.mapTasks (fun as => f as |>.toBaseIO) tasks prio
end EIO
namespace IO
def ofExcept [ToString ε] (e : Except ε α) : IO α :=
match e with
| Except.ok a => pure a
| Except.error e => throw (IO.userError (toString e))
def lazyPure (fn : Unit → α) : IO α :=
pure (fn ())
/-- Monotonically increasing time since an unspecified past point in milliseconds. No relation to wall clock time. -/
@[extern "lean_io_mono_ms_now"] constant monoMsNow : BaseIO Nat
/-- Read bytes from a system entropy source. Not guaranteed to be cryptographically secure.
If `nBytes = 0`, return immediately with an empty buffer. -/
@[extern "lean_io_get_random_bytes"] constant getRandomBytes (nBytes : USize) : IO ByteArray
def sleep (ms : UInt32) : IO Unit :=
-- TODO: add a proper primitive for IO.sleep
fun s => dbgSleep ms fun _ => EStateM.Result.ok () s
/-- `IO` specialization of `EIO.asTask`. -/
@[inline] def asTask (act : IO α) (prio := Task.Priority.default) : BaseIO (Task (Except IO.Error α)) :=
EIO.asTask act prio
/-- `IO` specialization of `EIO.mapTask`. -/
@[inline] def mapTask (f : α → IO β) (t : Task α) (prio := Task.Priority.default) : BaseIO (Task (Except IO.Error β)) :=
EIO.mapTask f t prio
/-- `IO` specialization of `EIO.bindTask`. -/
@[inline] def bindTask (t : Task α) (f : α → IO (Task (Except IO.Error β))) (prio := Task.Priority.default) : BaseIO (Task (Except IO.Error β)) :=
EIO.bindTask t f prio
/-- `IO` specialization of `EIO.mapTasks`. -/
@[inline] def mapTasks (f : List α → IO β) (tasks : List (Task α)) (prio := Task.Priority.default) : BaseIO (Task (Except IO.Error β)) :=
EIO.mapTasks f tasks prio
/-- Check if the task's cancellation flag has been set by calling `IO.cancel` or dropping the last reference to the task. -/
@[extern "lean_io_check_canceled"] constant checkCanceled : BaseIO Bool
/-- Request cooperative cancellation of the task. The task must explicitly call `IO.checkCanceled` to react to the cancellation. -/
@[extern "lean_io_cancel"] constant cancel : @& Task α → BaseIO Unit
/-- Check if the task has finished execution, at which point calling `Task.get` will return immediately. -/
@[extern "lean_io_has_finished"] constant hasFinished : @& Task α → BaseIO Bool
/-- Wait for the task to finish, then return its result. -/
@[extern "lean_io_wait"] constant wait (t : Task α) : BaseIO α :=
return t.get
/-- Wait until any of the tasks in the given list has finished, then return its result. -/
@[extern "lean_io_wait_any"] constant waitAny : @& List (Task α) → IO α
/-- Helper method for implementing "deterministic" timeouts. It is the number of "small" memory allocations performed by the current execution thread. -/
@[extern "lean_io_get_num_heartbeats"] constant getNumHeartbeats : BaseIO Nat
inductive FS.Mode where
| read | write | readWrite | append
constant FS.Handle : Type := Unit
/--
A pure-Lean abstraction of POSIX streams. We use `Stream`s for the standard streams stdin/stdout/stderr so we can
capture output of `#eval` commands into memory. -/
structure FS.Stream where
isEof : IO Bool
flush : IO Unit
read : USize → IO ByteArray
write : ByteArray → IO Unit
getLine : IO String
putStr : String → IO Unit
deriving Inhabited
open FS
@[extern "lean_get_stdin"] constant getStdin : BaseIO FS.Stream
@[extern "lean_get_stdout"] constant getStdout : BaseIO FS.Stream
@[extern "lean_get_stderr"] constant getStderr : BaseIO FS.Stream
/-- Replaces the stdin stream of the current thread and returns its previous value. -/
@[extern "lean_get_set_stdin"] constant setStdin : FS.Stream → BaseIO FS.Stream
/-- Replaces the stdout stream of the current thread and returns its previous value. -/
@[extern "lean_get_set_stdout"] constant setStdout : FS.Stream → BaseIO FS.Stream
/-- Replaces the stderr stream of the current thread and returns its previous value. -/
@[extern "lean_get_set_stderr"] constant setStderr : FS.Stream → BaseIO FS.Stream
@[specialize] partial def iterate (a : α) (f : α → IO (Sum α β)) : IO β := do
let v ← f a
match v with
| Sum.inl a => iterate a f
| Sum.inr b => pure b
namespace FS
namespace Handle
private def fopenFlags (m : FS.Mode) (b : Bool) : String :=
let mode :=
match m with
| FS.Mode.read => "r"
| FS.Mode.write => "w"
| FS.Mode.readWrite => "r+"
| FS.Mode.append => "a" ;
let bin := if b then "b" else "t"
mode ++ bin
@[extern "lean_io_prim_handle_mk"] constant mkPrim (fn : @& FilePath) (mode : @& String) : IO Handle
def mk (fn : FilePath) (Mode : Mode) (bin : Bool := true) : IO Handle :=
mkPrim fn (fopenFlags Mode bin)
/--
Returns whether the end of the file has been reached while reading a file.
`h.isEof` returns true /after/ the first attempt at reading past the end of `h`.
Once `h.isEof` is true, reading `h` will always return an empty array.
-/
@[extern "lean_io_prim_handle_is_eof"] constant isEof (h : @& Handle) : BaseIO Bool
@[extern "lean_io_prim_handle_flush"] constant flush (h : @& Handle) : IO Unit
@[extern "lean_io_prim_handle_read"] constant read (h : @& Handle) (bytes : USize) : IO ByteArray
@[extern "lean_io_prim_handle_write"] constant write (h : @& Handle) (buffer : @& ByteArray) : IO Unit
@[extern "lean_io_prim_handle_get_line"] constant getLine (h : @& Handle) : IO String
@[extern "lean_io_prim_handle_put_str"] constant putStr (h : @& Handle) (s : @& String) : IO Unit
end Handle
@[extern "lean_io_realpath"] constant realPath (fname : FilePath) : IO FilePath
@[extern "lean_io_remove_file"] constant removeFile (fname : @& FilePath) : IO Unit
/-- Remove given directory. Fails if not empty; see also `IO.FS.removeDirAll`. -/
@[extern "lean_io_remove_dir"] constant removeDir : @& FilePath → IO Unit
@[extern "lean_io_create_dir"] constant createDir : @& FilePath → IO Unit
end FS
@[extern "lean_io_getenv"] constant getEnv (var : @& String) : BaseIO (Option String)
@[extern "lean_io_app_path"] constant appPath : IO FilePath
@[extern "lean_io_current_dir"] constant currentDir : IO FilePath
namespace FS
@[inline]
def withFile (fn : FilePath) (mode : Mode) (f : Handle → IO α) : IO α :=
Handle.mk fn mode >>= f
def Handle.putStrLn (h : Handle) (s : String) : IO Unit :=
h.putStr (s.push '\n')
partial def Handle.readBinToEnd (h : Handle) : IO ByteArray := do
let rec loop (acc : ByteArray) : IO ByteArray := do
let buf ← h.read 1024
if buf.isEmpty then
return acc
else
loop (acc ++ buf)
loop ByteArray.empty
partial def Handle.readToEnd (h : Handle) : IO String := do
let rec loop (s : String) := do
let line ← h.getLine
if line.isEmpty then
return s
else
loop (s ++ line)
loop ""
def readBinFile (fname : FilePath) : IO ByteArray := do
let h ← Handle.mk fname Mode.read true
h.readBinToEnd
def readFile (fname : FilePath) : IO String := do
let h ← Handle.mk fname Mode.read false
h.readToEnd
partial def lines (fname : FilePath) : IO (Array String) := do
let h ← Handle.mk fname Mode.read false
let rec read (lines : Array String) := do
let line ← h.getLine
if line.length == 0 then
pure lines
else if line.back == '\n' then
let line := line.dropRight 1
let line := if System.Platform.isWindows && line.back == '\x0d' then line.dropRight 1 else line
read <| lines.push line
else
pure <| lines.push line
read #[]
def writeBinFile (fname : FilePath) (content : ByteArray) : IO Unit := do
let h ← Handle.mk fname Mode.write true
h.write content
def writeFile (fname : FilePath) (content : String) : IO Unit := do
let h ← Handle.mk fname Mode.write false
h.putStr content
def Stream.putStrLn (strm : FS.Stream) (s : String) : IO Unit :=
strm.putStr (s.push '\n')
structure DirEntry where
root : FilePath
fileName : String
deriving Repr
def DirEntry.path (entry : DirEntry) : FilePath :=
entry.root / entry.fileName
inductive FileType where
| dir
| file
| symlink
| other
deriving Repr, BEq
structure SystemTime where
sec : Int
nsec : UInt32
deriving Repr, BEq, Ord, Inhabited
instance : LT SystemTime := ltOfOrd
instance : LE SystemTime := leOfOrd
structure Metadata where
--permissions : ...
accessed : SystemTime
modified : SystemTime
byteSize : UInt64
type : FileType
deriving Repr
end FS
end IO
namespace System.FilePath
open IO
@[extern "lean_io_read_dir"]
constant readDir : @& FilePath → IO (Array IO.FS.DirEntry)
@[extern "lean_io_metadata"]
constant metadata : @& FilePath → IO IO.FS.Metadata
def isDir (p : FilePath) : BaseIO Bool := do
match (← p.metadata.toBaseIO) with
| Except.ok m => return m.type == IO.FS.FileType.dir
| Except.error _ => return false
def pathExists (p : FilePath) : BaseIO Bool :=
return (← p.metadata.toBaseIO).toBool
/--
Return all filesystem entries of a preorder traversal of all directories satisfying `enter`, starting at `p`.
Symbolic links are visited as well by default. -/
partial def walkDir (p : FilePath) (enter : FilePath → IO Bool := fun _ => pure true) : IO (Array FilePath) :=
Prod.snd <$> StateT.run (go p) #[]
where
go p := do
if !(← enter p) then
return ()
for d in (← p.readDir) do
modify (·.push d.path)
let m ← d.path.metadata
match m.type with
| FS.FileType.symlink =>
let p' ← FS.realPath d.path
if (← p'.isDir) then
-- do not call `enter` on a non-directory symlink
if (← enter p) then
go p'
| FS.FileType.dir => go d.path
| _ => pure ()
end System.FilePath
namespace IO
def withStdin [Monad m] [MonadFinally m] [MonadLiftT BaseIO m] (h : FS.Stream) (x : m α) : m α := do
let prev ← setStdin h
try x finally discard <| setStdin prev
def withStdout [Monad m] [MonadFinally m] [MonadLiftT BaseIO m] (h : FS.Stream) (x : m α) : m α := do
let prev ← setStdout h
try
x
finally
discard <| setStdout prev
def withStderr [Monad m] [MonadFinally m] [MonadLiftT BaseIO m] (h : FS.Stream) (x : m α) : m α := do
let prev ← setStderr h
try x finally discard <| setStderr prev
def print [ToString α] (s : α) : IO Unit := do
let out ← getStdout
out.putStr <| toString s
def println [ToString α] (s : α) : IO Unit :=
print ((toString s).push '\n')
def eprint [ToString α] (s : α) : IO Unit := do
let out ← getStderr
out.putStr <| toString s
def eprintln [ToString α] (s : α) : IO Unit :=
eprint <| toString s |>.push '\n'
@[export lean_io_eprint]
private def eprintAux (s : String) : IO Unit :=
eprint s
@[export lean_io_eprintln]
private def eprintlnAux (s : String) : IO Unit :=
eprintln s
def appDir : IO FilePath := do
let p ← appPath
let some p ← pure p.parent
| throw <| IO.userError s!"System.IO.appDir: unexpected filename '{p}'"
FS.realPath p
/-- Create given path and all missing parents as directories. -/
partial def FS.createDirAll (p : FilePath) : IO Unit := do
if ← p.isDir then
return ()
if let some parent := p.parent then
createDirAll parent
try
createDir p
catch
| e =>
if ← p.isDir then
pure () -- I guess someone else was faster
else
throw e
/--
Fully remove given directory by deleting all contained files and directories in an unspecified order.
Fails if any contained entry cannot be deleted or was newly created during execution. -/
partial def FS.removeDirAll (p : FilePath) : IO Unit := do
for ent in (← p.readDir) do
if (← ent.path.isDir : Bool) then
removeDirAll ent.path
else
removeFile ent.path
removeDir p
namespace Process
inductive Stdio where
| piped
| inherit
| null
def Stdio.toHandleType : Stdio → Type
| Stdio.piped => FS.Handle
| Stdio.inherit => Unit
| Stdio.null => Unit
structure StdioConfig where
/- Configuration for the process' stdin handle. -/
stdin := Stdio.inherit
/- Configuration for the process' stdout handle. -/
stdout := Stdio.inherit
/- Configuration for the process' stderr handle. -/
stderr := Stdio.inherit
structure SpawnArgs extends StdioConfig where
/- Command name. -/
cmd : String
/- Arguments for the process -/
args : Array String := #[]
/- Working directory for the process. Inherit from current process if `none`. -/
cwd : Option FilePath := none
/- Add or remove environment variables for the process. -/
env : Array (String × Option String) := #[]
-- TODO(Sebastian): constructor must be private
structure Child (cfg : StdioConfig) where
stdin : cfg.stdin.toHandleType
stdout : cfg.stdout.toHandleType
stderr : cfg.stderr.toHandleType
@[extern "lean_io_process_spawn"] constant spawn (args : SpawnArgs) : IO (Child args.toStdioConfig)
@[extern "lean_io_process_child_wait"] constant Child.wait {cfg : @& StdioConfig} : @& Child cfg → IO UInt32
/--
Extract the `stdin` field from a `Child` object, allowing them to be freed independently.
This operation is necessary for closing the child process' stdin while still holding on to a process handle,
e.g. for `Child.wait`. A file handle is closed when all references to it are dropped, which without this
operation includes the `Child` object.
-/
@[extern "lean_io_process_child_take_stdin"] constant Child.takeStdin {cfg : @& StdioConfig} : Child cfg →
IO (cfg.stdin.toHandleType × Child { cfg with stdin := Stdio.null })
structure Output where
exitCode : UInt32
stdout : String
stderr : String
/-- Run process to completion and capture output. -/
def output (args : SpawnArgs) : IO Output := do
let child ← spawn { args with stdout := Stdio.piped, stderr := Stdio.piped }
let stdout ← IO.asTask child.stdout.readToEnd Task.Priority.dedicated
let stderr ← child.stderr.readToEnd
let exitCode ← child.wait
let stdout ← IO.ofExcept stdout.get
pure { exitCode := exitCode, stdout := stdout, stderr := stderr }
/-- Run process to completion and return stdout on success. -/
def run (args : SpawnArgs) : IO String := do
let out ← output args
if out.exitCode != 0 then
throw <| IO.userError <| "process '" ++ args.cmd ++ "' exited with code " ++ toString out.exitCode
pure out.stdout
@[extern "lean_io_exit"] constant exit : UInt8 → IO α
end Process
structure AccessRight where
read : Bool := false
write : Bool := false
execution : Bool := false
def AccessRight.flags (acc : AccessRight) : UInt32 :=
let r : UInt32 := if acc.read then 0x4 else 0
let w : UInt32 := if acc.write then 0x2 else 0
let x : UInt32 := if acc.execution then 0x1 else 0
r.lor <| w.lor x
structure FileRight where
user : AccessRight := {}
group : AccessRight := {}
other : AccessRight := {}
def FileRight.flags (acc : FileRight) : UInt32 :=
let u : UInt32 := acc.user.flags.shiftLeft 6
let g : UInt32 := acc.group.flags.shiftLeft 3
let o : UInt32 := acc.other.flags
u.lor <| g.lor o
@[extern "lean_chmod"] constant Prim.setAccessRights (filename : @& FilePath) (mode : UInt32) : IO Unit
def setAccessRights (filename : FilePath) (mode : FileRight) : IO Unit :=
Prim.setAccessRights filename mode.flags
/- References -/
abbrev Ref (α : Type) := ST.Ref IO.RealWorld α
instance : MonadLift (ST IO.RealWorld) BaseIO := ⟨id⟩
def mkRef (a : α) : BaseIO (IO.Ref α) :=
ST.mkRef a
namespace FS
namespace Stream
@[export lean_stream_of_handle]
def ofHandle (h : Handle) : Stream := {
isEof := Handle.isEof h,
flush := Handle.flush h,
read := Handle.read h,
write := Handle.write h,
getLine := Handle.getLine h,
putStr := Handle.putStr h,
}
structure Buffer where
data : ByteArray := ByteArray.empty
pos : Nat := 0
def ofBuffer (r : Ref Buffer) : Stream := {
isEof := do let b ← r.get; pure <| b.pos >= b.data.size,
flush := pure (),
read := fun n => r.modifyGet fun b =>
let data := b.data.extract b.pos (b.pos + n.toNat)
(data, { b with pos := b.pos + data.size }),
write := fun data => r.modify fun b =>
-- set `exact` to `false` so that repeatedly writing to the stream does not impose quadratic run time
{ b with data := data.copySlice 0 b.data b.pos data.size false, pos := b.pos + data.size },
getLine := r.modifyGet fun b =>
let pos := match b.data.findIdx? (start := b.pos) fun u => u == 0 || u = '\n'.toNat.toUInt8 with
-- include '\n', but not '\0'
| some pos => if b.data.get! pos == 0 then pos else pos + 1
| none => b.data.size
(String.fromUTF8Unchecked <| b.data.extract b.pos pos, { b with pos := pos }),
putStr := fun s => r.modify fun b =>
let data := s.toUTF8
{ b with data := data.copySlice 0 b.data b.pos data.size false, pos := b.pos + data.size },
}
end Stream
/-- Run action with `stdin` emptied and `stdout+stderr` captured into a `String`. -/
def withIsolatedStreams [Monad m] [MonadFinally m] [MonadLiftT BaseIO m] (x : m α) : m (String × α) := do
let bIn ← mkRef { : Stream.Buffer }
let bOut ← mkRef { : Stream.Buffer }
let r ← withStdin (Stream.ofBuffer bIn) <|
withStdout (Stream.ofBuffer bOut) <|
withStderr (Stream.ofBuffer bOut) <|
x
let bOut ← liftM (m := BaseIO) bOut.get
let out := String.fromUTF8Unchecked bOut.data
pure (out, r)
end FS
end IO
universe u
namespace Lean
/-- Typeclass used for presenting the output of an `#eval` command. -/
class Eval (α : Type u) where
-- We default `hideUnit` to `true`, but set it to `false` in the direct call from `#eval`
-- so that `()` output is hidden in chained instances such as for some `IO Unit`.
-- We take `Unit → α` instead of `α` because ‵α` may contain effectful debugging primitives (e.g., `dbg_trace`)
eval : (Unit → α) → forall (hideUnit : optParam Bool true), IO Unit
instance [ToString α] : Eval α where
eval a _ := IO.println (toString (a ()))
instance [Repr α] : Eval α where
eval a _ := IO.println (repr (a ()))
instance : Eval Unit where
eval u hideUnit := if hideUnit then pure () else IO.println (repr (u ()))
instance [Eval α] : Eval (IO α) where
eval x _ := do
let a ← x ()
Eval.eval fun _ => a
@[noinline, nospecialize] def runEval [Eval α] (a : Unit → α) : IO (String × Except IO.Error Unit) :=
IO.FS.withIsolatedStreams (Eval.eval a false |>.toBaseIO)
end Lean
syntax "println! " (interpolatedStr(term) <|> term) : term
macro_rules
| `(println! $msg) =>
if msg.getKind == Lean.interpolatedStrKind then
`((IO.println (s! $msg) : IO Unit))
else
`((IO.println $msg : IO Unit))