aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source/library/lux/meta/compiler/meta/cache/module.lux
blob: 050da13ff40c37be396cecefffeda3d4475b9793 (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
... 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)
   [abstract
    ["[0]" monad (.only Monad do)]]
   [control
    ["[0]" pipe]
    ["[0]" try (.only Try)]
    ["[0]" exception (.only Exception)]]
   [data
    [binary (.only Binary)]
    ["[0]" product]
    ["[0]" text (.use "[1]#[0]" equivalence)
     ["%" \\format (.only format)]]
    [collection
     ["[0]" list (.use "[1]#[0]" functor)]
     ["[0]" dictionary (.only Dictionary)]]]
   [meta
    [compiler
     ["@" target]]]
   [world
    ["[0]" file]]]]
 ["[0]" // (.only)
  [//
   [context (.only Context)]
   [archive
    ["[0]" module]]]])

(exception.def .public (cannot_enable [archive @module error])
  (Exception [file.Path module.ID Text])
  (exception.report
   (list ["Archive" archive]
         ["Module ID" (%.nat @module)]
         ["Error" error])))

(def .public (path fs context @module)
  (All (_ !) (-> (file.System !) Context module.ID file.Path))
  (format (//.path fs context)
          (of fs separator)
          (%.nat @module)))

(def .public (enabled? fs context @module)
  (All (_ !) (-> (file.System !) Context module.ID (! Bit)))
  (of fs directory? (..path fs context @module)))

(def .public (enable! ! fs context @module)
  (All (_ !) (-> (Monad !) (file.System !) Context module.ID (! (Try Any))))
  (do !
    [.let [path (..path fs context @module)]
     module_exists? (of fs directory? path)]
    (if module_exists?
      (in {try.#Success []})
      (with_expansions [<failure> (exception.except ..cannot_enable [(//.path fs context)
                                                                     @module
                                                                     error])]
        (do !
          [? (//.enable! ! fs context)]
          (when ?
            {try.#Failure error}
            (in <failure>)
            
            success
            (|> path
                (of fs make_directory)
                (of ! each (|>> (pipe.when
                                  {try.#Failure error}
                                  <failure>

                                  success
                                  success))))))))))

(def file
  file.Path
  "descriptor")

(def .public (descriptor fs context @module)
  (All (_ !) (-> (file.System !) Context module.ID file.Path))
  (format (..path fs context @module)
          (of fs separator)
          ..file))

(def .public (cache! fs context @module content)
  (All (_ !) (-> (file.System !) Context module.ID Binary (! (Try Any))))
  (of fs write (..descriptor fs context @module) content))

(def .public (cache fs context @module)
  (All (_ !) (-> (file.System !) Context module.ID (! (Try Binary))))
  (of fs read (..descriptor fs context @module)))

(def .public (artifacts ! fs context @module)
  (All (_ !) (-> (Monad !) (file.System !) Context module.ID (! (Try (Dictionary Text Binary)))))
  (do [! (try.with !)]
    [files (of fs directory_files (..path fs context @module))
     pairs (|> files
               (list#each (function (_ file)
                            [(file.name fs file) file]))
               (list.only (|>> product.left (text#= ..file) not))
               (monad.each ! (function (_ [name path])
                               (|> path
                                   (of fs read)
                                   (of ! each (|>> [name]))))))]
    (in (dictionary.of_list text.hash (for @.old (as (List [Text Binary]) pairs)
                                           pairs)))))