aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source/lux/tool/compiler/meta/io/context.lux
blob: bd1efd73bd6657c69419385b32ef2585defc2bb3 (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
(.module:
  [lux (#- Module Code)
   ["@" target]
   [abstract
    [monad (#+ Monad do)]]
   [control
    ["ex" exception (#+ Exception exception:)]
    [security
     ["!" capability]]]
   [data
    ["." error (#+ Error)]
    ["." text ("#;." hash)
     format
     ["." encoding]]]
   [world
    ["." file (#+ Path File)]
    [binary (#+ Binary)]]
   [type (#+ :share)]]
  ["." // (#+ Context Code)
   ["#/" // #_
    [archive
     [descriptor (#+ Module)]]
    ["#/" // (#+ Input)]]])

(template [<name>]
  [(exception: #export (<name> {module Module})
     (ex.report ["Module" module]))]

  [cannot-find-module]
  [cannot-read-module]
  )

(type: #export Extension Text)

(def: lux-extension
  Extension
  ".lux")

(def: partial-host-extension
  Extension
  (`` (for {(~~ (static @.common-lisp)) ".cl"
            (~~ (static @.js))          ".js"
            (~~ (static @.old))         ".jvm"
            (~~ (static @.jvm))         ".jvm"
            (~~ (static @.lua))         ".lua"
            (~~ (static @.php))         ".php"
            (~~ (static @.python))      ".py"
            (~~ (static @.r))           ".r"
            (~~ (static @.ruby))        ".rb"
            (~~ (static @.scheme))      ".scm"})))

(def: full-host-extension
  Extension
  (format partial-host-extension lux-extension))

(def: #export (path system context module)
  (All [m] (-> (file.System m) Context Module Path))
  (|> module
      (//.sanitize system)
      (format context (:: system separator))))

(def: (find-source-file monad system contexts module extension)
  (All [!]
    (-> (Monad !) (file.System !) (List Context) Module Extension
        (! (Error [Path (File !)]))))
  (case contexts
    #.Nil
    (:: monad wrap (ex.throw ..cannot-find-module [module]))

    (#.Cons context contexts')
    (do monad
      [#let [path (format (..path system context module) extension)]
       file (!.use (:: system file) path)]
      (case file
        (#error.Success file)
        (wrap (#error.Success [path file]))

        (#error.Failure error)
        (find-source-file monad system contexts' module extension)))))

(def: #export (find-any-source-file monad system contexts module)
  (All [!]
    (-> (Monad !) (file.System !) (List Context) Module
        (! (Error [Path (File !)]))))
  (do monad
    [outcome (find-source-file monad system contexts module ..full-host-extension)]
    (case outcome
      (#error.Success output)
      (wrap outcome)

      (#error.Failure error)
      (find-source-file monad system contexts module ..lux-extension))))

(def: #export (read monad system contexts module)
  (All [!]
    (-> (Monad !) (file.System !) (List Context) Module
        (! (Error Input))))
  (do (error.with monad)
    [## TODO: Get rid of both ":share"s ASAP
     path,file (:share [!]
                       {(Monad !)
                        monad}
                       {(! (Error [Path (File !)]))
                        (find-any-source-file monad system contexts module)})
     #let [[path file] (:share [!]
                               {(Monad !)
                                monad}
                               {[Path (File !)]
                                path,file})]
     binary (!.use (:: file content) [])]
    (case (encoding.from-utf8 binary)
      (#error.Success code)
      (wrap {#////.module module
             #////.file path
             #////.hash (text;hash code)
             #////.code code})
      
      (#error.Failure _)
      (:: monad wrap (ex.throw ..cannot-read-module [module])))))