-
-
Notifications
You must be signed in to change notification settings - Fork 1.1k
/
Copy pathIR.purs
376 lines (337 loc) · 15.2 KB
/
IR.purs
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
module IR
( IR
, unifySetOfClasses
, followRedirections
, normalizeGraphOrder
, getClass
, addClass
, addTopLevel
, replaceClass
, addPlaceholder
, replacePlaceholder
, replaceNoInformationWithAnyType
, unifyTypes
, unifyMultipleTypes
, execIR
, runIR
) where
import Prelude
import Control.Monad.Except (ExceptT, runExceptT)
import Control.Monad.State (State, runState, evalState)
import Control.Monad.State.Class (get, put)
import Data.Either (Either(..))
import Data.Foldable (class Foldable, foldM, for_)
import Data.Int.Bits as Bits
import Data.List (List, (:))
import Data.List as L
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe(..), fromMaybe, fromJust)
import Data.Sequence as Seq
import Data.Set (Set)
import Data.Set as S
import Data.Tuple (Tuple(..), fst, snd)
import Data.Tuple as T
import IRGraph (Entry(..), IRClassData(..), IRGraph(..), IRType(..), IRUnionRep(..), Named, emptyGraph, emptyUnion, followIndex, getClassFromGraph, irUnion_Bool, irUnion_Double, irUnion_Integer, irUnion_Null, irUnion_String, unifyNamed)
import Partial.Unsafe (unsafePartial)
import Utils (lookupOrDefault, mapM, mapMapM, mapMaybeM, sortByKey)
type IR = ExceptT String (State IRGraph)
execIR :: forall a. IR a -> Either String IRGraph
execIR ir = snd <$> runIR ir
runIR :: forall a. IR a -> Either String (Tuple a IRGraph)
runIR ir =
case runState (runExceptT ir) emptyGraph of
Tuple (Right a) s -> Right (Tuple a s)
Tuple (Left error) _ -> Left error
addTopLevel :: String -> IRType -> IR Unit
addTopLevel name toplevel = do
IRGraph { classes, toplevels } <- get
let newTopLevels = M.insert name toplevel toplevels
put $ IRGraph { classes, toplevels: newTopLevels }
addClassWithIndex :: IRClassData -> IR (Tuple Int IRType)
addClassWithIndex classData = do
IRGraph { classes, toplevels } <- get
case Seq.elemIndex (Class classData) classes of
Nothing -> do
let index = Seq.length classes
put $ IRGraph { classes: Seq.snoc classes (Class classData), toplevels }
pure $ Tuple index (IRClass index)
Just index -> pure $ Tuple index (IRClass index)
addPlaceholder :: IR Int
addPlaceholder = do
IRGraph { classes, toplevels } <- get
let index = Seq.length classes
put $ IRGraph { classes: Seq.snoc classes NoType, toplevels }
pure index
replacePlaceholder :: Int -> IRClassData -> IR Unit
replacePlaceholder i classData = do
IRGraph { classes, toplevels } <- get
-- FIXME: assert it is a placeholder!
let newClasses = Seq.replace (Class classData) i classes
put $ IRGraph { classes: newClasses, toplevels}
addClass :: IRClassData -> IR IRType
addClass classData = T.snd <$> addClassWithIndex classData
redirectClass :: Int -> Int -> IR Unit
redirectClass from to = do
graph@(IRGraph { classes: c1, toplevels }) <- get
let realTo = T.fst $ followIndex graph to
if from == realTo
then pure unit
else do
let c2 = Seq.replace (Redirect realTo) from c1
put $ IRGraph { classes: c2, toplevels }
deleteClass :: Int -> IR Unit
deleteClass i = do
IRGraph { classes, toplevels } <- get
let newClasses = Seq.replace NoType i classes
put $ IRGraph { classes: newClasses, toplevels }
getClass :: Int -> IR IRClassData
getClass index = do
graph <- get
pure $ getClassFromGraph graph index
combineClasses :: Int -> Int -> IRClassData -> IR Int
combineClasses ia ib combined = do
IRGraph { classes } <- get
Tuple newIndex t <- addClassWithIndex combined
redirectClass ia newIndex
redirectClass ib newIndex
pure newIndex
-- FIXME: this is ugly and inefficient
unionWithDefault :: forall k v. Ord k => (v -> v -> IR v) -> v -> Map k v -> Map k v -> IR (Map k v)
unionWithDefault unifier default m1 m2 =
let allKeys = L.fromFoldable $ S.union (S.fromFoldable $ M.keys m1) (S.fromFoldable $ M.keys m2)
valueFor k = unifier (lookupOrDefault default k m1) (lookupOrDefault default k m2)
keyMapper k = Tuple k <$> valueFor k
in M.fromFoldable <$> mapM keyMapper allKeys
unifyClassDatas :: IRClassData -> IRClassData -> IR IRClassData
unifyClassDatas (IRClassData { names: na, properties: pa }) (IRClassData { names: nb, properties: pb }) = do
properties <- unionWithDefault unifyTypesWithNull IRNoInformation pa pb
pure $ IRClassData { names: unifyNamed S.union na nb, properties }
where
unifyTypesWithNull :: IRType -> IRType -> IR IRType
unifyTypesWithNull IRNoInformation IRNoInformation = pure IRNoInformation
unifyTypesWithNull a b = unifyTypes (nullifyNoInformation a) (nullifyNoInformation b)
nullifyNoInformation :: IRType -> IRType
nullifyNoInformation IRNoInformation = IRNull
nullifyNoInformation x = x
unifyClassRefs :: Int -> Int -> IR Int
unifyClassRefs ia ib =
if ia == ib
then pure ia
else do
a <- getClass ia
b <- getClass ib
unified <- unifyClassDatas a b
combineClasses ia ib unified
unifyMaybes :: Maybe IRType -> Maybe IRType -> IR IRType
unifyMaybes Nothing Nothing = pure IRNoInformation
unifyMaybes (Just a) Nothing = pure a
unifyMaybes Nothing (Just b) = pure b
unifyMaybes (Just a) (Just b) = unifyTypes a b
unifyTypes :: IRType -> IRType -> IR IRType
unifyTypes IRNoInformation x = pure x
unifyTypes x IRNoInformation = pure x
unifyTypes IRAnyType x = pure IRAnyType
unifyTypes x IRAnyType = pure IRAnyType
unifyTypes IRInteger IRDouble = pure IRDouble
unifyTypes IRDouble IRInteger = pure IRDouble
unifyTypes (IRArray a) (IRArray b) = IRArray <$> unifyTypes a b
unifyTypes a@(IRClass ia) (IRClass ib) = do
unified <- unifyClassRefs ia ib
pure $ IRClass unified
unifyTypes (IRMap a) (IRMap b) = IRMap <$> unifyTypes a b
unifyTypes (IRUnion a) b = unifyWithUnion a b
unifyTypes a (IRUnion b) = unifyWithUnion b a
unifyTypes a b | a == b = pure a
| otherwise = do
u1 <- unifyWithUnion emptyUnion a
unifyTypes u1 b
unifyMultipleTypes :: forall f. Foldable f => f IRType -> IR IRType
unifyMultipleTypes = foldM unifyTypes IRNoInformation
unifySetOfClasses :: Set Int -> IR Unit
unifySetOfClasses indexes =
case L.fromFoldable indexes of
L.Nil -> pure unit
_ : L.Nil -> pure unit
first : rest -> do
firstClass <- getClass first
let folder cd1 i2 = getClass i2 >>= unifyClassDatas cd1
combined <- foldM folder firstClass rest
Tuple newIndex _ <- addClassWithIndex combined
for_ indexes \i -> redirectClass i newIndex
followRedirections :: IR Unit
followRedirections = do
graph <- get
replaceTypes (replaceClassesInType \i -> Just $ IRClass $ T.fst $ followIndex graph i)
updateClasses :: (IRClassData -> IR IRClassData) -> (IRType -> IR IRType) -> IR Unit
updateClasses classUpdater typeUpdater = do
IRGraph { classes, toplevels } <- get
newClasses <- mapM mapper $ L.fromFoldable classes
newToplevels <- mapMapM (\_ -> typeUpdater) toplevels
put $ IRGraph { classes: Seq.fromFoldable newClasses, toplevels: newToplevels }
where
mapper entry =
case entry of
Class cd -> Class <$> classUpdater cd
_ -> pure entry
unifyWithUnion :: IRUnionRep -> IRType -> IR IRType
unifyWithUnion u@(IRUnionRep { names, primitives, arrayType, classRef, mapType }) t =
case t of
IRNoInformation -> pure $ IRUnion u
IRAnyType -> pure IRAnyType
IRNull -> addBit irUnion_Null
IRInteger -> addBit irUnion_Integer
IRDouble -> addBit irUnion_Double
IRBool -> addBit irUnion_Bool
IRString -> addBit irUnion_String
IRArray ta -> do
unified <- doTypes ta arrayType
pure $ IRUnion $ IRUnionRep { names, primitives, arrayType: unified, classRef, mapType }
IRClass ti -> do
unified <- doClasses ti classRef
pure $ IRUnion $ IRUnionRep { names, primitives, arrayType, classRef: unified, mapType }
IRMap tm -> do
unified <- doTypes tm mapType
pure $ IRUnion $ IRUnionRep { names, primitives, arrayType, classRef, mapType: unified }
IRUnion (IRUnionRep { names: na, primitives: pb, arrayType: ab, classRef: cb, mapType: mb }) -> do
let p = Bits.or primitives pb
a <- doMaybeTypes arrayType ab
c <- doMaybeClasses classRef cb
m <- doMaybeTypes mapType mb
pure $ IRUnion $ IRUnionRep { names: unifyNamed S.union names na, primitives: p, arrayType: a, classRef: c, mapType: m }
where
addBit b =
pure $ IRUnion $ IRUnionRep { names, primitives: Bits.or b primitives, arrayType, classRef, mapType }
doWithUnifier :: forall a. (a -> a -> IR a) -> a -> Maybe a -> IR (Maybe a)
doWithUnifier unify a mb =
case mb of
Just b -> do
unified <- unify a b
pure $ Just unified
Nothing ->
pure $ Just a
doTypes = doWithUnifier unifyTypes
doClasses = doWithUnifier unifyClassRefs
doMaybe :: forall a. (a -> Maybe a -> IR (Maybe a)) -> Maybe a -> Maybe a -> IR (Maybe a)
doMaybe doer ma mb =
case ma of
Just a -> doer a mb
Nothing -> pure mb
doMaybeTypes = doMaybe doTypes
doMaybeClasses = doMaybe doClasses
replaceClassesInType :: (Int -> Maybe IRType) -> IRType -> IR IRType
replaceClassesInType replacer t =
case t of
IRClass i -> pure $ fromMaybe t $ replacer i
IRArray a -> do
replaced <- replace a
pure $ IRArray replaced
IRMap m -> do
replaced <- replace m
pure $ IRMap replaced
IRUnion (IRUnionRep { names, primitives, arrayType, classRef, mapType }) -> do
a <- replaceInMaybe arrayType
m <- replaceInMaybe mapType
doClassRef names primitives a classRef m
_ -> pure t
where
replace = replaceClassesInType replacer
replaceInMaybe :: (Maybe IRType) -> IR (Maybe IRType)
replaceInMaybe m =
case m of
Just x -> Just <$> replace x
Nothing -> pure Nothing
doClassRef :: Named (Set String) -> Int -> Maybe IRType -> Maybe Int -> Maybe IRType -> IR IRType
doClassRef names primitives arrayType classRef mapType =
case classRef of
Just i ->
case replacer i of
Just replacement ->
unifyWithUnion (IRUnionRep { names, primitives, arrayType, classRef: Nothing, mapType }) replacement
Nothing -> pure $ IRUnion $ IRUnionRep { names, primitives, arrayType, classRef, mapType }
_ -> pure $ IRUnion $ IRUnionRep { names, primitives, arrayType, classRef, mapType }
replaceTypes :: (IRType -> IR IRType) -> IR Unit
replaceTypes typeUpdater =
updateClasses classUpdater typeUpdater
where
classUpdater (IRClassData { names, properties }) = do
newProperties <- mapMapM (\_ t -> typeUpdater t) properties
pure $ IRClassData { names, properties: newProperties }
replaceClass :: Int -> IRType -> IR Unit
replaceClass from to = do
replaceTypes $ (replaceClassesInType \i -> if i == from then Just to else Nothing)
deleteClass from
replaceNoInformationWithAnyType :: IR Unit
replaceNoInformationWithAnyType = do
replaceTypes replacer
where
replacer :: IRType -> IR IRType
replacer IRNoInformation = pure IRAnyType
replacer (IRArray a) = IRArray <$> replacer a
replacer (IRMap m) = IRMap <$> replacer m
replacer (IRUnion (IRUnionRep { names, primitives, arrayType, classRef, mapType })) = do
arrayType <- mapM replacer arrayType
mapType <- mapM replacer mapType
pure $ IRUnion $ IRUnionRep { names, primitives, arrayType, classRef, mapType }
replacer t = pure t
-- This maps from old class index to new class index and new class data
type ClassMapper = State (Map Int (Tuple Int (Maybe IRClassData)))
normalizeGraphOrder :: IRGraph -> IRGraph
normalizeGraphOrder graph@(IRGraph { toplevels }) =
evalState work M.empty
where
-- When we encounter a class we first check whether we've seen
-- it before (Right), or whether it's new (Left). In the Left
-- case, we get a new index for the class, and the index is added
-- to the map.
registerClass :: Int -> ClassMapper (Either Int Int)
registerClass oldIndex = do
m <- get
case M.lookup oldIndex m of
Just (Tuple newIndex _) -> pure $ Right newIndex
Nothing -> do
let newIndex = M.size m
put $ M.insert oldIndex (Tuple newIndex Nothing) m
pure $ Left newIndex
-- After we're done processing a new class, we update the
-- entry in the map with its IRClassData.
setClass :: Int -> IRClassData -> ClassMapper Unit
setClass oldIndex cd = do
m <- get
let Tuple newIndex _ = unsafePartial $ fromJust $ M.lookup oldIndex m
put $ M.insert oldIndex (Tuple newIndex $ Just cd) m
sortMap :: Map String IRType -> List (Tuple String IRType)
sortMap m = sortByKey fst $ M.toUnfoldable m
addClassesFromClass :: Int -> ClassMapper Int
addClassesFromClass oldIndex = do
reg <- registerClass oldIndex
case reg of
Left newIndex -> do
let IRClassData { names, properties } = getClassFromGraph graph oldIndex
let sorted = sortMap properties
newProperties <- M.fromFoldable <$> mapM (\(Tuple n t) -> Tuple n <$> addClasses t) sorted
let cd = IRClassData { names, properties: newProperties }
setClass oldIndex cd
pure newIndex
Right newIndex -> pure newIndex
addClasses :: IRType -> ClassMapper IRType
addClasses (IRClass i) = IRClass <$> addClassesFromClass i
addClasses (IRArray t) = IRArray <$> addClasses t
addClasses (IRMap m) = IRMap <$> addClasses m
addClasses (IRUnion (IRUnionRep { names, primitives, arrayType, classRef, mapType })) = do
newArrayType <- mapMaybeM addClasses arrayType
newClassRef <- mapMaybeM addClassesFromClass classRef
newMapType <- mapMaybeM addClasses mapType
pure $ IRUnion $ IRUnionRep { names, primitives, arrayType: newArrayType, classRef: newClassRef, mapType: newMapType }
addClasses t = pure t
dejustifyClassMapEntry (Tuple i mcd) = Tuple i $ unsafePartial $ fromJust mcd
work :: ClassMapper IRGraph
work = do
let sortedToplevels = sortMap toplevels
newToplevels <- mapM (\(Tuple name t) -> Tuple name <$> addClasses t) sortedToplevels
classMap <- get
let reverseClassMap = M.fromFoldable $ map dejustifyClassMapEntry $ M.values classMap
let numClasses = M.size reverseClassMap
let classIndexRange = if numClasses == 0 then L.Nil else L.range 0 (numClasses - 1)
let newClasses = map (\i -> Class $ unsafePartial $ fromJust $ M.lookup i reverseClassMap) classIndexRange
pure $ IRGraph { classes: Seq.fromFoldable newClasses, toplevels: M.fromFoldable newToplevels }