@@ -22,133 +22,6 @@ import qualified Type.UnionFind as UF
2222
2323
2424
25−{-| Every variable has rank less than or equal to the maxRank of the pool.
26−This sorts variables into the young and old pools accordingly.
27−-}
28−generalize :: TS.Pool -> TS.Solver ()
29−generalize pool@(TS.Pool youngRank _) =
30− {-# SCC elm_compiler_type_generalize #-}
31− do youngMark <- TS.uniqueMark
32−
33− rankTable <- liftIO $ poolToRankTable youngMark pool
34−
35− -- get the ranks right for each entry.
36− -- start at low ranks so that we only have to pass
37− -- over the information once.
38− visitedMark <- TS.uniqueMark
39− let adjust poolRank vars =
40− F.traverse_ (adjustRank youngMark visitedMark poolRank) vars
41− liftIO $ Vector.imapM_ adjust rankTable
42−
43− -- For variables that have rank lowerer than youngRank, register them in
44− -- the old pool if they are not redundant.
45− Vector.forM_ (Vector.unsafeInit rankTable) $ \vars ->
46− forM_ vars $ \var ->
47− do isRedundant <- liftIO $ UF.redundant var
48− if isRedundant then return var else TS.register var
49−
50− -- For variables with rank youngRank
51− -- If rank < youngRank: register in oldPool
52− -- otherwise generalize
53− forM_ (Vector.unsafeLast rankTable) $ \var ->
54− {-# SCC elm_compiler_type_register #-}
55− do isRedundant <- liftIO $ UF.redundant var
56− if isRedundant
57− then return ()
58− else do
59− (Descriptor content rank mark copy) <- liftIO $ UF.descriptor var
60− if rank < youngRank
61− then
62− TS.register var >> return ()
63− else
64− liftIO $ UF.setDescriptor var $ Descriptor (rigidify content) noRank mark copy
65−
66−
67−poolToRankTable :: Mark -> TS.Pool -> IO (Vector.Vector [Variable])
68−poolToRankTable youngMark (TS.Pool youngRank youngInhabitants) =
69− do mutableTable <- MVector.replicate (youngRank + 1) []
70−
71− -- Sort the youngPool variables by rank.
72− forM_ youngInhabitants $ \var ->
73− do (Descriptor content rank _ copy) <- UF.descriptor var
74− UF.setDescriptor var (Descriptor content rank youngMark copy)
75− MVector.modify mutableTable (var:) rank
76−
77− Vector.unsafeFreeze mutableTable
78−
79−
80−rigidify :: Content -> Content
81−rigidify content =
82− case content of
83− Var Flex maybeSuper maybeName ->
84− Var Rigid maybeSuper maybeName
85−
86− _ ->
87− content
88−
89−
90−
91−-- ADJUST RANK
92−
93−--
94−-- Adjust variable ranks such that ranks never increase as you move deeper.
95−-- This way the outermost rank is representative of the entire structure.
96−--
97−adjustRank :: Mark -> Mark -> Int -> Variable -> IO Int
98−adjustRank youngMark visitedMark groupRank var =
99− {-# SCC elm_compiler_type_adjust #-}
100− do (Descriptor content rank mark copy) <- UF.descriptor var
101− if mark == youngMark then
102− do -- Set the variable as marked first because it may be cyclic.
103− UF.setDescriptor var $ Descriptor content rank visitedMark copy
104− maxRank <- adjustRankContent youngMark visitedMark groupRank content
105− UF.setDescriptor var $ Descriptor content maxRank visitedMark copy
106− return maxRank
107−
108− else if mark == visitedMark then
109− return rank
110−
111− else
112− do let minRank = min groupRank rank
113− -- TODO how can minRank ever be groupRank?
114− UF.setDescriptor var $ Descriptor content minRank visitedMark copy
115− return minRank
116−
117−
118−adjustRankContent :: Mark -> Mark -> Int -> Content -> IO Int
119−adjustRankContent youngMark visitedMark groupRank content =
120− let
121− go = adjustRank youngMark visitedMark groupRank
122− in
123− case content of
124− Error _ ->
125− return groupRank
126−
127− Var _ _ _ ->
128− return groupRank
129−
130− Alias _ args _ ->
131− -- THEORY: anything in the realVar would be outermostRank
132− foldM (\rank (_, argVar) -> max rank <$> go argVar) outermostRank args
133−
134− Structure flatType ->
135− case flatType of
136− App1 _ args ->
137− foldM (\rank arg -> max rank <$> go arg) outermostRank args
138−
139− Fun1 arg result ->
140− max <$> go arg <*> go result
141−
142− EmptyRecord1 ->
143− -- THEORY: an empty record never needs to get generalized
144− return outermostRank
145−
146− Record1 fields extension ->
147− do extRank <- go extension
148− foldM (\rank field -> max rank <$> go field) extRank fields
149−
150−
151−
15225-- SOLVER
15326
15427
@@ -281,3 +154,132 @@ occurs (name, A.A region variable) =
281154 liftIO $ UF.setDescriptor variable (Descriptor (Error "∞") rank mark copy)
282155 TS.addError region (Error.InfiniteType (Right name) overallType)
283156
157+
158+
159+-- GENERALIZE
160+
161+
162+{-| Every variable has rank less than or equal to the maxRank of the pool.
163+This sorts variables into the young and old pools accordingly.
164+-}
165+generalize :: TS.Pool -> TS.Solver ()
166+generalize pool@(TS.Pool youngRank _) =
167+ {-# SCC elm_compiler_type_generalize #-}
168+ do youngMark <- TS.uniqueMark
169+
170+ rankTable <- liftIO $ poolToRankTable youngMark pool
171+
172+ -- get the ranks right for each entry.
173+ -- start at low ranks so that we only have to pass
174+ -- over the information once.
175+ visitedMark <- TS.uniqueMark
176+ let adjust poolRank vars =
177+ F.traverse_ (adjustRank youngMark visitedMark poolRank) vars
178+ liftIO $ Vector.imapM_ adjust rankTable
179+
180+ -- For variables that have rank lowerer than youngRank, register them in
181+ -- the old pool if they are not redundant.
182+ Vector.forM_ (Vector.unsafeInit rankTable) $ \vars ->
183+ forM_ vars $ \var ->
184+ do isRedundant <- liftIO $ UF.redundant var
185+ if isRedundant then return var else TS.register var
186+
187+ -- For variables with rank youngRank
188+ -- If rank < youngRank: register in oldPool
189+ -- otherwise generalize
190+ forM_ (Vector.unsafeLast rankTable) $ \var ->
191+ {-# SCC elm_compiler_type_register #-}
192+ do isRedundant <- liftIO $ UF.redundant var
193+ if isRedundant
194+ then return ()
195+ else do
196+ (Descriptor content rank mark copy) <- liftIO $ UF.descriptor var
197+ if rank < youngRank
198+ then
199+ TS.register var >> return ()
200+ else
201+ liftIO $ UF.setDescriptor var $ Descriptor (rigidify content) noRank mark copy
202+
203+
204+poolToRankTable :: Mark -> TS.Pool -> IO (Vector.Vector [Variable])
205+poolToRankTable youngMark (TS.Pool youngRank youngInhabitants) =
206+ do mutableTable <- MVector.replicate (youngRank + 1) []
207+
208+ -- Sort the youngPool variables by rank.
209+ forM_ youngInhabitants $ \var ->
210+ do (Descriptor content rank _ copy) <- UF.descriptor var
211+ UF.setDescriptor var (Descriptor content rank youngMark copy)
212+ MVector.modify mutableTable (var:) rank
213+
214+ Vector.unsafeFreeze mutableTable
215+
216+
217+rigidify :: Content -> Content
218+rigidify content =
219+ case content of
220+ Var Flex maybeSuper maybeName ->
221+ Var Rigid maybeSuper maybeName
222+
223+ _ ->
224+ content
225+
226+
227+
228+-- ADJUST RANK
229+
230+--
231+-- Adjust variable ranks such that ranks never increase as you move deeper.
232+-- This way the outermost rank is representative of the entire structure.
233+--
234+adjustRank :: Mark -> Mark -> Int -> Variable -> IO Int
235+adjustRank youngMark visitedMark groupRank var =
236+ {-# SCC elm_compiler_type_adjust #-}
237+ do (Descriptor content rank mark copy) <- UF.descriptor var
238+ if mark == youngMark then
239+ do -- Set the variable as marked first because it may be cyclic.
240+ UF.setDescriptor var $ Descriptor content rank visitedMark copy
241+ maxRank <- adjustRankContent youngMark visitedMark groupRank content
242+ UF.setDescriptor var $ Descriptor content maxRank visitedMark copy
243+ return maxRank
244+
245+ else if mark == visitedMark then
246+ return rank
247+
248+ else
249+ do let minRank = min groupRank rank
250+ -- TODO how can minRank ever be groupRank?
251+ UF.setDescriptor var $ Descriptor content minRank visitedMark copy
252+ return minRank
253+
254+
255+adjustRankContent :: Mark -> Mark -> Int -> Content -> IO Int
256+adjustRankContent youngMark visitedMark groupRank content =
257+ let
258+ go = adjustRank youngMark visitedMark groupRank
259+ in
260+ case content of
261+ Error _ ->
262+ return groupRank
263+
264+ Var _ _ _ ->
265+ return groupRank
266+
267+ Alias _ args _ ->
268+ -- THEORY: anything in the realVar would be outermostRank
269+ foldM (\rank (_, argVar) -> max rank <$> go argVar) outermostRank args
270+
271+ Structure flatType ->
272+ case flatType of
273+ App1 _ args ->
274+ foldM (\rank arg -> max rank <$> go arg) outermostRank args
275+
276+ Fun1 arg result ->
277+ max <$> go arg <*> go result
278+
279+ EmptyRecord1 ->
280+ -- THEORY: an empty record never needs to get generalized
281+ return outermostRank
282+
283+ Record1 fields extension ->
284+ do extRank <- go extension
285+ foldM (\rank field -> max rank <$> go field) extRank fields