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
|
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE NoImplicitPrelude #-}
-- | Durable logical module owners, independent of invocation-local mount IDs.
module Felix.Module
( SourceNamespaceId
, sourceNamespaceId
, sourceNamespaceIdFromDigest
, sourceNamespaceDigest
, ModuleName
, moduleName
, moduleNameFromParts
, moduleNameNamespace
, moduleNameRelativePath
, preludeModuleName
, encodeAbsoluteSourceRoot
, encodeSafeRelativePath
, encodeModuleName
, LocalDeclarationOrdinal
, localDeclarationOrdinal
, localDeclarationOrdinalValue
, LocalFactOrdinal
, localFactOrdinal
, localFactOrdinalValue
, GeneratedObjectSlot
, generatedObjectSlot
, generatedObjectSlotValue
, DeclarationFamilyTag(..)
, encodeDeclarationFamilyTag
) where
import Base
import Felix.Math.Codec
import Felix.Source
import Data.ByteString (ByteString)
import Data.ByteString qualified as ByteString
import Data.Text qualified as Text
import Numeric.Natural (Natural)
import System.FilePath.Posix qualified as Posix
newtype SourceNamespaceId =
SourceNamespaceId MathematicalDigest
deriving stock (Show, Eq, Ord)
sourceNamespaceId :: CanonicalPath -> SourceNamespaceId
sourceNamespaceId root =
SourceNamespaceId
(codecInvariant
(hashCanonicalFields
"felix-source-namespace-v1"
[encodeAbsoluteSourceRoot root]))
sourceNamespaceIdFromDigest
:: MathematicalDigest
-> SourceNamespaceId
sourceNamespaceIdFromDigest =
SourceNamespaceId
sourceNamespaceDigest :: SourceNamespaceId -> MathematicalDigest
sourceNamespaceDigest (SourceNamespaceId digest) =
digest
data ModuleName = ModuleName
!SourceNamespaceId
!SafeRelativePath
deriving stock (Show, Eq, Ord)
moduleName :: ResolvedSourceAddress -> ModuleName
moduleName address =
ModuleName
(sourceNamespaceId (sourceAddressRoot address))
(sourceAddressRelativePath address)
moduleNameFromParts
:: SourceNamespaceId
-> SafeRelativePath
-> ModuleName
moduleNameFromParts =
ModuleName
moduleNameNamespace :: ModuleName -> SourceNamespaceId
moduleNameNamespace (ModuleName namespace _relativePath) =
namespace
moduleNameRelativePath :: ModuleName -> SafeRelativePath
moduleNameRelativePath (ModuleName _namespace relativePath) =
relativePath
preludeModuleName :: ModuleName
preludeModuleName =
ModuleName
reservedPreludeNamespace
(case safeRelativePath "prelude" of
Right relative -> relative
Left err ->
impossible
("invalid reserved prelude path: " <> show err))
where
reservedPreludeNamespace =
SourceNamespaceId
(codecInvariant
(hashCanonicalFields
"felix-reserved-prelude-namespace-v1"
[]))
encodeAbsoluteSourceRoot :: CanonicalPath -> ByteString
encodeAbsoluteSourceRoot root =
encodePath
"felix-absolute-source-root-path-v1"
components
where
path =
Posix.dropTrailingPathSeparator
(canonicalPathFilePath root)
components =
case Posix.splitDirectories path of
[] ->
[]
rootComponent : rest
| endsInPathSeparator rootComponent ->
rest
| otherwise ->
impossible
"canonical source root is not absolute"
endsInPathSeparator component =
case reverse component of
character : _ ->
Posix.isPathSeparator character
[] ->
False
encodeSafeRelativePath :: SafeRelativePath -> ByteString
encodeSafeRelativePath relative =
encodePath
"felix-safe-relative-path-v1"
(splitComponents
(safeRelativePathFilePath relative))
encodeModuleName :: ModuleName -> ByteString
encodeModuleName (ModuleName namespace relative) =
mathematicalDigestBytes (sourceNamespaceDigest namespace)
<> encodeSafeRelativePath relative
encodePath :: Text -> [FilePath] -> ByteString
encodePath domain components =
codecInvariant
(encodeCanonicalPathRecord
domain
(Text.pack <$> components))
splitComponents :: FilePath -> [FilePath]
splitComponents path =
case break (== '/') path of
(component, []) ->
[component]
(component, _slash : rest) ->
component : splitComponents rest
newtype LocalDeclarationOrdinal =
LocalDeclarationOrdinal Natural
deriving stock (Show, Eq, Ord)
localDeclarationOrdinal
:: Natural
-> LocalDeclarationOrdinal
localDeclarationOrdinal =
LocalDeclarationOrdinal
localDeclarationOrdinalValue
:: LocalDeclarationOrdinal
-> Natural
localDeclarationOrdinalValue
(LocalDeclarationOrdinal ordinal) =
ordinal
newtype LocalFactOrdinal =
LocalFactOrdinal Natural
deriving stock (Show, Eq, Ord)
localFactOrdinal :: Natural -> LocalFactOrdinal
localFactOrdinal =
LocalFactOrdinal
localFactOrdinalValue :: LocalFactOrdinal -> Natural
localFactOrdinalValue (LocalFactOrdinal ordinal) =
ordinal
newtype GeneratedObjectSlot =
GeneratedObjectSlot Natural
deriving stock (Show, Eq, Ord)
generatedObjectSlot :: Natural -> GeneratedObjectSlot
generatedObjectSlot =
GeneratedObjectSlot
generatedObjectSlotValue :: GeneratedObjectSlot -> Natural
generatedObjectSlotValue (GeneratedObjectSlot slot) =
slot
data DeclarationFamilyTag
= SignatureDeclaration
| StructureDeclaration
| DatatypeDeclaration
| InductiveDeclaration
deriving stock (Show, Eq, Ord, Enum, Bounded)
encodeDeclarationFamilyTag :: DeclarationFamilyTag -> ByteString
encodeDeclarationFamilyTag =
ByteString.singleton . \case
SignatureDeclaration ->
0x00
StructureDeclaration ->
0x01
DatatypeDeclaration ->
0x02
InductiveDeclaration ->
0x03
codecInvariant
:: Either MathematicalCodecError value
-> value
codecInvariant =
either
(impossible . ("canonical codec invariant: " <>) . show)
id
|
