git.iko.soy/elk
on master help sign in
Redo Type.State.Solver to not use RWS
b441190Evan Czaplicki
src/Type/Solve.hs+3−3
compare with master
unifiedsplit
@@ -23,14 +23,14 @@ This sorts variables into the young and old pools accordingly.
23generalize :: TS.Pool -> TS.Solver ()
23generalize :: TS.Pool -> TS.Solver ()
24generalize youngPool =
24generalize youngPool =
25 do youngMark <- TS.uniqueMark
25 do youngMark <- TS.uniqueMark
26− let youngRank = TS.maxRank youngPool
26+ let youngRank = TS._maxRank youngPool
27 let insert dict var =
27 let insert dict var =
28 do descriptor <- liftIO $ UF.descriptor var
28 do descriptor <- liftIO $ UF.descriptor var
29 liftIO $ UF.modifyDescriptor var (\desc -> desc { _mark = youngMark })
29 liftIO $ UF.modifyDescriptor var (\desc -> desc { _mark = youngMark })
30 return $ Map.insertWith (++) (_rank descriptor) [var] dict
30 return $ Map.insertWith (++) (_rank descriptor) [var] dict
31
31
32 -- Sort the youngPool variables by rank.
32 -- Sort the youngPool variables by rank.
33− rankDict <- foldM insert Map.empty (TS.inhabitants youngPool)
33+ rankDict <- foldM insert Map.empty (TS._inhabitants youngPool)
34
34
35 -- get the ranks right for each entry.
35 -- get the ranks right for each entry.
36 -- start at low ranks so that we only have to pass
36 -- start at low ranks so that we only have to pass
@@ -150,7 +150,7 @@ adjustRankContent youngMark visitedMark groupRank content =
150-- SOLVER
150-- SOLVER
151
151
152
152
153−solve :: TypeConstraint -> ExceptT [A.Located Error.Error] IO TS.SolverState
153+solve :: TypeConstraint -> ExceptT [A.Located Error.Error] IO TS.State
154solve constraint =
154solve constraint =
155 do state <- liftIO (TS.run (actuallySolve constraint))
155 do state <- liftIO (TS.run (actuallySolve constraint))
156 case TS.sError state of
156 case TS.sError state of
src/Type/State.hs+156−51
@@ -2,7 +2,7 @@
2module Type.State
2module Type.State
3 ( Solver
3 ( Solver
4 , run
4 , run
5− , SolverState(..)
5+ , State(..)
6 , Pool(..)
6 , Pool(..)
7 , Env
7 , Env
8 , modifyEnv
8 , modifyEnv
@@ -21,7 +21,9 @@ module Type.State
21 )
21 )
22 where
22 where
23
23
24−import qualified Control.Monad.State as State
24+
25+import Control.Monad (liftM2)
26+import Control.Monad.Trans (MonadIO, liftIO)
25import qualified Data.Map as Map
27import qualified Data.Map as Map
26import Data.Map ((!))
28import Data.Map ((!))
27import Data.Text (Text)
29import Data.Text (Text)
@@ -33,29 +35,40 @@ import qualified Reporting.Region as R
33import Type.Type
35import Type.Type
34
36
35
37
38+
36-- SOLVER
39-- SOLVER
37
40
38
41
39−type Solver = State.StateT SolverState IO
42+newtype Solver a =
43+ Solver { _solve :: State -> IO (a, State) }
44+
45+
46+
47+-- RUN SOLVER
40
48
41
49
42−run :: Solver () -> IO SolverState
50+run :: Solver () -> IO State
43−run solver =
51+run (Solver solver) =
44− State.execStateT solver $
52+ do (_, state) <- solver initialState
53+ return state
54+
55+
56+initialState :: State
57+initialState =
45− SS
58+ SS
46− { sEnv = Map.empty
59+ { sEnv = Map.empty
47− , sSavedEnv = Map.empty
60+ , sSavedEnv = Map.empty
48− , sPool = Pool outermostRank []
61+ , sPool = Pool outermostRank []
49− , sMark = noMark + 1 -- The mark must never be equal to noMark!
62+ , sMark = noMark + 1 -- The mark must never be equal to noMark!
50− , sError = []
63+ , sError = []
51− }
64+ }
52
65
53
66
54
67
55-- SOLVER STATE
68-- SOLVER STATE
56
69
57
70
58−data SolverState =
71+data State =
59 SS
72 SS
60 { sEnv :: Env
73 { sEnv :: Env
61 , sSavedEnv :: Env
74 , sSavedEnv :: Env
@@ -71,8 +84,8 @@ The young pool exists to make it possible to identify these vars in constant tim
71-}
84-}
72data Pool =
85data Pool =
73 Pool
86 Pool
74− { maxRank :: Int
87+ { _maxRank :: Int
75− , inhabitants :: [Variable]
88+ , _inhabitants :: [Variable]
76 }
89 }
77
90
78
91
@@ -83,67 +96,105 @@ type Env = Map.Map Text (A.Located Variable)
83-- HELPERS
96-- HELPERS
84
97
85
98
99+{-# INLINE modifyEnv #-}
86modifyEnv :: (Env -> Env) -> Solver ()
100modifyEnv :: (Env -> Env) -> Solver ()
87modifyEnv f =
101modifyEnv f =
102+ Solver $ \state ->
88− State.modify $ \state -> state { sEnv = f (sEnv state) }
103+ return ( (), state { sEnv = f (sEnv state) } )
89
104
90
105
106+{-# INLINE modifyPool #-}
91modifyPool :: (Pool -> Pool) -> Solver ()
107modifyPool :: (Pool -> Pool) -> Solver ()
92modifyPool f =
108modifyPool f =
109+ Solver $ \state ->
93− State.modify $ \state -> state { sPool = f (sPool state) }
110+ return ( (), state { sPool = f (sPool state) } )
94
111
95
112
113+{-# INLINE addError #-}
96addError :: R.Region -> Error.Error -> Solver ()
114addError :: R.Region -> Error.Error -> Solver ()
97addError region err =
115addError region err =
116+ Solver $ \state ->
98− State.modify $ \state -> state { sError = A.A region err : sError state }
117+ return ( (), state { sError = A.A region err : sError state } )
99
118
100
119
120+{-# INLINE switchToPool #-}
101switchToPool :: Pool -> Solver ()
121switchToPool :: Pool -> Solver ()
102switchToPool pool =
122switchToPool pool =
103− modifyPool (\_ -> pool)
123+ modifyPool (\_ -> pool)
104
124
105
125
126+{-# INLINE getPool #-}
106getPool :: Solver Pool
127getPool :: Solver Pool
107getPool =
128getPool =
108− State.gets sPool
129+ Solver $ \state ->
130+ return ( sPool state, state )
109
131
110
132
133+{-# INLINE getEnv #-}
111getEnv :: Solver Env
134getEnv :: Solver Env
112getEnv =
135getEnv =
113− State.gets sEnv
136+ Solver $ \state ->
137+ return ( sEnv state, state )
114
138
115
139
140+{-# INLINE saveLocalEnv #-}
116saveLocalEnv :: Solver ()
141saveLocalEnv :: Solver ()
117saveLocalEnv =
142saveLocalEnv =
118− do currentEnv <- getEnv
143+ Solver $ \state ->
119− State.modify $ \state -> state { sSavedEnv = currentEnv }
144+ return ( (), state { sSavedEnv = sEnv state } )
120
145
121
146
147+{-# INLINE uniqueMark #-}
122uniqueMark :: Solver Int
148uniqueMark :: Solver Int
123uniqueMark =
149uniqueMark =
124− do state <- State.get
150+ Solver $ \state ->
125− let mark = sMark state
151+ let
152+ mark =
153+ sMark state
154+ in
126− State.put $ state { sMark = mark + 1 }
155+ return ( mark, state { sMark = mark + 1 } )
127− return mark
128
156
129
157
158+{-# INLINE nextRankPool #-}
130nextRankPool :: Solver Pool
159nextRankPool :: Solver Pool
131nextRankPool =
160nextRankPool =
132− do pool <- getPool
161+ Solver $ \state ->
133− return $ Pool { maxRank = maxRank pool + 1, inhabitants = [] }
162+ let
163+ (Pool maxRank _) =
164+ sPool state
165+ in
166+ return ( Pool (maxRank + 1) [], state )
167+
134
168
135
169
170+-- REGISTER VARIABLES
171+
172+
173+{-# INLINE register #-}
136register :: Variable -> Solver Variable
174register :: Variable -> Solver Variable
137register variable =
175register variable =
138− do modifyPool $ \pool -> pool { inhabitants = variable : inhabitants pool }
176+ Solver $ \state ->
139− return variable
177+ let
178+ (Pool maxRank inhabitants) =
179+ sPool state
180+ in
181+ return ( variable, state { sPool = Pool maxRank (variable : inhabitants) } )
140
182
141
183
184+{-# INLINE introduce #-}
142introduce :: Variable -> Solver Variable
185introduce :: Variable -> Solver Variable
143introduce variable =
186introduce variable =
144− do pool <- getPool
187+ Solver $ \state ->
188+ let
189+ (Pool maxRank inhabitants) =
190+ sPool state
191+ in
145− State.liftIO $ UF.modifyDescriptor variable (\desc -> desc { _rank = maxRank pool })
192+ do UF.modifyDescriptor variable (\desc -> desc { _rank = maxRank })
146− register variable
193+ return ( variable, state { sPool = Pool maxRank (variable : inhabitants) } )
194+
195+
196+
197+-- FLATTEN
147
198
148
199
149flatten :: Type -> Solver Variable
200flatten :: Type -> Solver Variable
@@ -162,9 +213,9 @@ flattenHelp aliasDict termN =
162 flatVar <- flattenHelp (Map.fromList flatArgs) realType
213 flatVar <- flattenHelp (Map.fromList flatArgs) realType
163 pool <- getPool
214 pool <- getPool
164 variable <-
215 variable <-
165− State.liftIO . UF.fresh $ Descriptor
216+ liftIO . UF.fresh $ Descriptor
166 { _content = Alias name flatArgs flatVar
217 { _content = Alias name flatArgs flatVar
167− , _rank = maxRank pool
218+ , _rank = _maxRank pool
168 , _mark = noMark
219 , _mark = noMark
169 , _copy = Nothing
220 , _copy = Nothing
170 }
221 }
@@ -177,15 +228,19 @@ flattenHelp aliasDict termN =
177 do variableTerm <- traverseTerm (flattenHelp aliasDict) term1
228 do variableTerm <- traverseTerm (flattenHelp aliasDict) term1
178 pool <- getPool
229 pool <- getPool
179 variable <-
230 variable <-
180− State.liftIO . UF.fresh $ Descriptor
231+ liftIO . UF.fresh $ Descriptor
181 { _content = Structure variableTerm
232 { _content = Structure variableTerm
182− , _rank = maxRank pool
233+ , _rank = _maxRank pool
183 , _mark = noMark
234 , _mark = noMark
184 , _copy = Nothing
235 , _copy = Nothing
185 }
236 }
186 register variable
237 register variable
187
238
188
239
240+
241+-- MAKE INSTANCE
242+
243+
189makeInstance :: Variable -> Solver Variable
244makeInstance :: Variable -> Solver Variable
190makeInstance var =
245makeInstance var =
191 do alreadyCopiedMark <- uniqueMark
246 do alreadyCopiedMark <- uniqueMark
@@ -194,9 +249,13 @@ makeInstance var =
194 return freshVar
249 return freshVar
195
250
196
251
252+
253+-- MAKE COPY
254+
255+
197makeCopy :: Int -> Variable -> Solver Variable
256makeCopy :: Int -> Variable -> Solver Variable
198makeCopy alreadyCopiedMark variable =
257makeCopy alreadyCopiedMark variable =
199− do desc <- State.liftIO $ UF.descriptor variable
258+ do desc <- liftIO $ UF.descriptor variable
200 makeCopyHelp desc alreadyCopiedMark variable
259 makeCopyHelp desc alreadyCopiedMark variable
201
260
202
261
@@ -220,9 +279,9 @@ makeCopyHelp (Descriptor content rank mark copy) alreadyCopiedMark variable =
220 else
279 else
221 do pool <- getPool
280 do pool <- getPool
222 newVar <-
281 newVar <-
223− State.liftIO $ UF.fresh $ Descriptor
282+ liftIO $ UF.fresh $ Descriptor
224 { _content = content -- place holder!
283 { _content = content -- place holder!
225− , _rank = maxRank pool
284+ , _rank = _maxRank pool
226 , _mark = noMark
285 , _mark = noMark
227 , _copy = Nothing
286 , _copy = Nothing
228 }
287 }
@@ -233,12 +292,12 @@ makeCopyHelp (Descriptor content rank mark copy) alreadyCopiedMark variable =
233 --
292 --
234 -- Need to do this before recursively copying the content of
293 -- Need to do this before recursively copying the content of
235 -- the variable to avoid looping on cyclic terms.
294 -- the variable to avoid looping on cyclic terms.
236− State.liftIO $ UF.modifyDescriptor variable $ \desc ->
295+ liftIO $ UF.modifyDescriptor variable $ \desc ->
237 desc { _mark = alreadyCopiedMark, _copy = Just newVar }
296 desc { _mark = alreadyCopiedMark, _copy = Just newVar }
238
297
239
298
240 let setContent newContent =
299 let setContent newContent =
241− State.liftIO $ UF.modifyDescriptor newVar $ \desc ->
300+ liftIO $ UF.modifyDescriptor newVar $ \desc ->
242 desc { _content = newContent }
301 desc { _content = newContent }
243
302
244 -- Now we recursively copy the content of the variable.
303 -- Now we recursively copy the content of the variable.
@@ -291,9 +350,12 @@ needsCopy content =
291
350
292
351
293
352
353+-- RESTORE
354+
355+
294restore :: Int -> Variable -> Solver Variable
356restore :: Int -> Variable -> Solver Variable
295restore alreadyCopiedMark variable =
357restore alreadyCopiedMark variable =
296− do desc <- State.liftIO $ UF.descriptor variable
358+ do desc <- liftIO $ UF.descriptor variable
297 if _mark desc /= alreadyCopiedMark
359 if _mark desc /= alreadyCopiedMark
298 then
360 then
299 return variable
361 return variable
@@ -301,7 +363,7 @@ restore alreadyCopiedMark variable =
301 else
363 else
302 do restoredContent <-
364 do restoredContent <-
303 restoreContent alreadyCopiedMark (_content desc)
365 restoreContent alreadyCopiedMark (_content desc)
304− State.liftIO $ UF.setDescriptor variable $ Descriptor
366+ liftIO $ UF.setDescriptor variable $ Descriptor
305 { _content = restoredContent
367 { _content = restoredContent
306 , _rank = noRank
368 , _rank = noRank
307 , _mark = noMark
369 , _mark = noMark
@@ -339,17 +401,60 @@ restoreContent alreadyCopiedMark content =
339-- TERM TRAVERSAL
401-- TERM TRAVERSAL
340
402
341
403
342−traverseTerm :: (Monad f, Applicative f) => (a -> f b) -> Term1 a -> f (Term1 b)
404+traverseTerm :: (a -> Solver b) -> Term1 a -> Solver (Term1 b)
343traverseTerm f term =
405traverseTerm f term =
344 case term of
406 case term of
345 App1 a b ->
407 App1 a b ->
346− App1 <$> f a <*> f b
408+ liftM2 App1 (f a) (f b)
347
409
348 Fun1 a b ->
410 Fun1 a b ->
349− Fun1 <$> f a <*> f b
411+ liftM2 Fun1 (f a) (f b)
350
412
351 EmptyRecord1 ->
413 EmptyRecord1 ->
352− return EmptyRecord1
414+ pure EmptyRecord1
353
415
354 Record1 fields ext ->
416 Record1 fields ext ->
355− Record1 <$> traverse f fields <*> f ext
417+ liftM2 Record1 (traverse f fields) (f ext)
418+
419+
420+
421+-- INSTANCES
422+
423+
424+instance Functor Solver where
425+ {-# INLINE fmap #-}
426+ fmap f (Solver solver) = Solver $ \s1 ->
427+ fmap (\(a, s2) -> (f a, s2)) (solver s1)
428+
429+
430+instance Applicative Solver where
431+ {-# INLINE pure #-}
432+ pure a = Solver $ \s -> return (a, s)
433+
434+ {-# INLINE (<*>) #-}
435+ Solver solverFunc <*> Solver solverValue =
436+ Solver $ \s1 ->
437+ do (f, s2) <- solverFunc s1
438+ (x, s3) <- solverValue s2
439+ return (f x, s3)
440+
441+
442+instance Monad Solver where
443+ {-# INLINE (>>=) #-}
444+ Solver solver >>= k =
445+ Solver $ \s1 ->
446+ do (a, s2) <- solver s1
447+ (b, s3) <- _solve (k a) s2
448+ return (b, s3)
449+
450+ {-# INLINE fail #-}
451+ fail msg =
452+ Solver $ \_ -> fail msg
453+
454+
455+instance MonadIO Solver where
456+ {-# INLINE liftIO #-}
457+ liftIO io =
458+ Solver $ \state ->
459+ do a <- io
460+ return (a, state)