aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source/program/compositor.lux
blob: bcb9c76453c02511a33a44f89a743a4727b50d1d (plain)
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
... This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
... If a copy of the MPL was not distributed with this file, You can obtain one at https://mozilla.org/MPL/2.0/.

(.require
 [library
  [lux (.except Module)
   ["[0]" debug]
   [abstract
    ["[0]" monad (.only Monad do)]]
   [control
    ["[0]" io (.only IO io)]
    ["[0]" maybe]
    ["[0]" try (.only Try)]
    [concurrency
     ["[0]" async (.only Async) (.use "[1]#[0]" monad)]]]
   [data
    [binary (.only Binary)]
    ["[0]" product]
    ["[0]" text (.only)
     ["%" \\format (.only format)]]
    [collection
     ["[0]" dictionary (.only Dictionary)]
     ["[0]" sequence (.use "[1]#[0]" monoid mix)]
     ["[0]" list (.use "[1]#[0]" mix)]]
    [format
     ["[0]" tar (.only Tar)]]]
   [meta
    [type (.only sharing)]
    ["[0]" compiler
     ["@" target]
     [default
      ["[0]" platform (.only Platform)]]
     [language
      ["$" lux (.only)
       ["[1]/[0]" program (.only Program)]
       ["[0]" syntax]
       ["[0]" translation]
       ["[0]" declaration]
       ["[0]" analysis (.only)
        [macro (.only Expander)]]
       ["[0]" phase (.only)
        [extension (.only Extender)
         ["[0]E" analysis]
         ["[0]E" synthesis]]]]]
     [meta
      [packager (.only Packager)]
      ["[0]" context (.only Context)]
      ["[0]" cli (.only Service)]
      ["[0]" import]
      ["[0]" export]
      ["[0]" cache (.only)
       ["[1]/[0]" archive]]
      [archive (.only Archive)
       ["[0]" unit]
       [module
        [descriptor (.only Module)]]]
      [io
       ["ioW" archive]]]]
    ... ["[0]" interpreter]
    ]
   ["[0]" world
    ["[0]" console]
    ["[1]/[0]" environment]
    ["[0]" file (.only)
     ["[1]/[0]" extension]]
    [time
     ["[0]" instant]]]]])

(def (or_crash! failure_description action)
  (All (_ of)
    (-> Text (Async (Try of))
        (Async of)))
  (do [! async.monad]
    [?output action]
    (when ?output
      {try.#Failure error}
      (let [report (format text.new_line
                           failure_description text.new_line
                           error text.new_line)]
        (do !
          [_ (with_expansions [<else> (in {try.#Success (debug.log! report)})]
               (for @.js (is (Async (Try Any))
                             (when console.default
                               {.#None}
                               <else>

                               {.#Some console}
                               (console.write_line report console)))
                    (is (Async (Try Any))
                        <else>)))]
          (io.run! (of world/environment.default exit +1))))

      {try.#Success output}
      (in output))))

(def (timed process)
  (All (_ of)
    (-> (Async (Try of))
        (Async (Try of))))
  (do async.monad
    [.let [start (io.run! instant.now)]
     output process
     .let [_ (debug.log! (|> (io.run! instant.now)
                             (instant.span start)
                             %.duration
                             (format "Duration: ")))]]
    (in output)))

(def (package! file_context fs host_dependencies [packager package] archive context)
  (-> Context (file.System Async) (Dictionary file.Path Binary) [Packager file.Path] Archive (Maybe unit.ID)
      (Async (Try Any)))
  (let [target_root (the context.#target file_context)
        package (file.rooted fs target_root package)]
    (when (packager host_dependencies archive context)
      {try.#Success content}
      (when content
        {.#Left content}
        (of fs write package content)
        
        {.#Right content}
        (do [! (try.with async.monad)]
          [_ (of fs make_directory package)
           _ (monad.each ! (function (_ [name content])
                             (of fs write (file.rooted fs package name) content))
                         content)]
          (in [])))
      
      {try.#Failure error}
      (of async.monad in {try.#Failure error}))))

(def (load_host_dependencies fs host_dependencies)
  (-> (file.System Async) (List file.Path)
      (Async (Try (Dictionary file.Path Binary))))
  (do [! (try.with async.monad)]
    []
    (loop (again [pending host_dependencies
                  output (is (Dictionary file.Path Binary)
                             (dictionary.empty text.hash))])
      (when pending
        {.#End}
        (in output)

        {.#Item head tail}
        (do !
          [content (of fs read head)]
          (again tail
                 (dictionary.has head content output)))))))

(def (hybrid_fs cache host)
  (-> (file.System Async) (file.System Async)
      (file.System Async))
  (`` (implementation
       (def separator
         (of host separator))
       (,, (with_template [<name>]
             [(def (<name> path)
                (do async.monad
                  [?/0 (of cache <name> path)
                   ?/1 (of host <name> path)]
                  (in (or ?/0 ?/1))))]

             [file?]
             [directory?]
             ))
       (,, (with_template [<name>]
             [(def <name>
                (of cache <name>))]

             [make_directory]
             [directory_files]
             [sub_directories]
             
             [file_size]
             [last_modified]
             [can_execute?]
             [delete]
             ))
       (def (read path)
         (do async.monad
           [it (of cache read path)]
           (when it
             {try.#Failure _}
             (of host read path)
             
             _
             (in it))))
       (,, (with_template [<name>]
             [(def <name>
                (of cache <name>))]
             
             [modify]
             [write]
             [append]
             [move]
             ))
       )))

(def cache_mode
  tar.Mode
  (all tar.and
       tar.execute_by_other
       tar.write_by_other
       tar.read_by_other

       tar.execute_by_group
       tar.write_by_group
       tar.read_by_group

       tar.execute_by_owner
       tar.write_by_owner
       tar.read_by_owner

       tar.save_text
       tar.set_group_id_on_execution
       tar.set_user_id_on_execution
       ))

(type (Action of)
  (Async (Try of)))

(def monad
  (is (Monad Action)
      (as_expected (try.with async.monad))))

(def (cache_tar_entry fs path)
  (-> (file.System Async) file.Path
      (Action tar.Entry))
  (do async.monad
    [content (of fs read path)]
    (in (do try.monad
          [content content
           path (tar.path path)
           content (tar.content content)]
          (in {tar.#Normal [path instant.epoch ..cache_mode tar.no_ownership content]})))))

(def (cache_tar context fs)
  (-> Context (file.System Async)
      (Action Tar))
  (loop (again [root cache.path])
    (do [! ..monad]
      [files (of fs directory_files root)
       subs (of fs sub_directories root)
       files (monad.each ! (cache_tar_entry fs) files)
       subs (monad.each ! again subs)]
      (in (list#mix sequence#composite
                    (sequence.of_list files)
                    subs)))))

(def (cache_path fs context)
  (-> (file.System Async) Context
      file.Path)
  (%.format (the context.#target context)
            (of fs separator)
            (the context.#host context)
            file/extension.tape_archive))

(def (cached_file_path fs full_path)
  (-> (file.System Async) file.Path
      [file.Path file.Path])
  (<| maybe.trusted
      (do maybe.monad
        [.let [/ (of fs separator)]
         @ (text.last_index / full_path)
         [directory file] (text.split_at @ full_path)]
        (in [directory (text.replaced_once / "" file)]))))

(with_expansions [<parameters> (these anchor expression artifact)]
  (def (load_cache! host_fs cache_fs context)
    (-> (file.System Async) (file.System Async) Context
        (Async (Try Any)))
    (do [! async.monad]
      [tar (of host_fs read (cache_path host_fs context))]
      (when tar
        {try.#Failure _}
        (in {try.#Success []})

        {try.#Success tar}
        (do [! (try.with !)]
          [tar (async#in (of tar.codec decoded tar))
           _ (sequence#mix (function (_ entry then)
                             (when entry
                               {tar.#Normal [path instant mode ownership content]}
                               (do !
                                 [_ then
                                  .let [path (tar.from_path path)
                                        directory (maybe.else path (file.parent cache_fs path))]
                                  _ (is (Async (Try Any))
                                        (file.make_directories async.monad cache_fs directory))]
                                 (of cache_fs write path (tar.data content)))

                               _
                               then))
                           (in [])
                           tar)]
          (in [])))))

  (def (cache! original_fs context platform)
    (All (_ <parameters>)
      (-> (file.System Async) Context (Platform <parameters>)
          (Async (Try Any))))
    (do (try.with async.monad)
      [cache (cache_tar context (the platform.#file_system platform))]
      (of original_fs write
          (cache_path original_fs context)
          (of tar.codec encoded cache))))

  (def (with_caching it)
    (All (_ <parameters>)
      (-> (Platform <parameters>)
          [(file.System Async) (Platform <parameters>)]))
    (let [cache_fs (file.mock (of (the platform.#file_system it) separator))
          it (revised platform.#file_system (hybrid_fs cache_fs) it)]
      [cache_fs it]))

  (def (enable_output! original_fs context)
    (-> (file.System Async) Context
        (Async (Try Any)))
    (let [target_root (the context.#target context)]
      (do async.monad
        [? (of original_fs directory? target_root)]
        (if ?
          (in {try.#Success []})
          (of original_fs make_directory target_root)))))
  
  (def .public (compiler lux_compiler file_context
                         expander host_analysis platform translation_bundle host_declaration_bundle program global extender
                         service
                         packager,package)
    (All (_ <parameters>)
      (-> (-> Any platform.Custom)
          Context
          Expander
          analysis.Bundle
          (IO (Platform <parameters>))
          (translation.Bundle <parameters>)
          (declaration.Bundle <parameters>)
          (Program expression artifact) (-> Archive Symbol (translation.Operation <parameters> expression))
          Extender
          Service
          [Packager file.Path]
          (Async Any)))
    (do [! async.monad]
      [platform (async.future platform)]
      (when service
        {cli.#Compilation compilation}
        (<| (or_crash! "Compilation failed:")
            ..timed
            (do [! (try.with !)]
              [.let [original_fs (the platform.#file_system platform)
                     [cache_fs platform] (with_caching platform)]
               _ (enable_output! original_fs file_context)
               _ (load_cache! original_fs cache_fs file_context)
               import (import.import (the platform.#file_system platform) (the cli.#libraries compilation))
               .let [all_extensions [(analysisE.bundle host_analysis)
                                     synthesisE.bundle
                                     translation_bundle
                                     host_declaration_bundle]]
               [state archive phase_wrapper] (sharing [<parameters>]
                                               (is (Platform <parameters>)
                                                   platform)
                                               (is (Async (Try [(declaration.State <parameters>)
                                                                Archive
                                                                phase.Wrapper]))
                                                   (as_expected (platform.initialize file_context
                                                                                     (the cli.#module compilation)
                                                                                     expander
                                                                                     platform
                                                                                     program
                                                                                     extender
                                                                                     import
                                                                                     (the cli.#sources compilation)
                                                                                     (the cli.#configuration compilation)
                                                                                     all_extensions))))
               archive,state (do async.monad
                               [archive,state (sharing [<parameters>]
                                                (is (Platform <parameters>)
                                                    platform)
                                                (is (Async (Try [Archive (declaration.State <parameters>)]))
                                                    (as_expected (platform.compile program
                                                                                   global
                                                                                   lux_compiler
                                                                                   phase_wrapper
                                                                                   import
                                                                                   file_context
                                                                                   extender
                                                                                   expander
                                                                                   platform
                                                                                   compilation
                                                                                   [archive state]
                                                                                   all_extensions))))]
                               (in {try.#Success archive,state}))]
              (when archive,state
                {try.#Success [archive state]}
                (do !
                  [_ (cache/archive.cache! (the platform.#file_system platform) (the cli.#configuration compilation) archive)
                   _ (cache! original_fs file_context platform)
                   host_dependencies (..load_host_dependencies (the platform.#file_system platform)
                                                               (the cli.#host_dependencies compilation))

                   _ (..package! file_context
                                 original_fs
                                 host_dependencies
                                 packager,package
                                 archive
                                 (try.maybe ($/program.context archive)))]
                  (in (debug.log! "Compilation complete!")))

                {try.#Failure error}
                (do !
                  [_ (cache! original_fs file_context platform)]
                  (async#in {try.#Failure error})))))

        {cli.#Export export}
        (<| (or_crash! "Export failed:")
            (do (try.with !)
              [_ (export.export (the platform.#file_system platform)
                   export)]
              (in (debug.log! "Export complete!"))))
        
        {cli.#Interpretation interpretation}
        ... TODO: Fix the interpreter...
        (undefined)
        ... (<| (or_crash! "Interpretation failed:")
        ...     (do !
        ...       [console (|> console.default
        ...                    async.future
        ...                    (of ! each (|>> try.trusted console.async)))]
        ...       (interpreter.run! (try.with async.monad) console platform interpretation translation_bundle)))
        )))
  )