git.iko.soy/elk
on 08a8971 help sign in
elk/src/Type/State.hs
466 lines 10 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Type.State
3 ( Solver
4 , run
5 , State(..)
6 , Pool(..)
7 , Env
8 , modifyEnv
9 , addError
10 , switchToPool
11 , getPool
12 , getEnv
13 , saveLocalEnv
14 , uniqueMark
15 , nextRankPool
16 , register
17 , introduce
18 , flatten
19 , makeInstance
20 , makeCopy
21 )
22 where
25import Control.Monad (liftM2)
26import Control.Monad.Trans (MonadIO, liftIO)
27import qualified Data.Map as Map
28import Data.Map ((!))
29import Data.Text (Text)
30import qualified Data.UnionFind.IO as UF
32import qualified Reporting.Annotation as A
33import qualified Reporting.Error.Type as Error
34import qualified Reporting.Region as R
35import Type.Type
39-- SOLVER
42newtype Solver a =
43 Solver { _solve :: State -> IO (a, State) }
47-- RUN SOLVER
50run :: Solver () -> IO State
51run (Solver solver) =
52 do (_, state) <- solver initialState
53 return state
56initialState :: State
57initialState =
58 SS
59 { sEnv = Map.empty
60 , sSavedEnv = Map.empty
61 , sPool = Pool outermostRank []
62 , sMark = noMark + 1 -- The mark must never be equal to noMark!
63 , sError = []
64 }
68-- SOLVER STATE
71data State =
72 SS
73 { sEnv :: Env
74 , sSavedEnv :: Env
75 , sPool :: Pool
76 , sMark :: Int
77 , sError :: [A.Located Error.Error]
78 }
81{-| A pool holds a bunch of variables
82The rank of each variable is less than or equal to the pool's "maxRank"
83The young pool exists to make it possible to identify these vars in constant time.
84-}
85data Pool =
86 Pool
87 { _maxRank :: Int
88 , _inhabitants :: [Variable]
89 }
92type Env = Map.Map Text (A.Located Variable)
96-- HELPERS
99{-# INLINE modifyEnv #-}
100modifyEnv :: (Env -> Env) -> Solver ()
101modifyEnv f =
102 Solver $ \state ->
103 return ( (), state { sEnv = f (sEnv state) } )
106{-# INLINE modifyPool #-}
107modifyPool :: (Pool -> Pool) -> Solver ()
108modifyPool f =
109 Solver $ \state ->
110 return ( (), state { sPool = f (sPool state) } )
113{-# INLINE addError #-}
114addError :: R.Region -> Error.Error -> Solver ()
115addError region err =
116 Solver $ \state ->
117 return ( (), state { sError = A.A region err : sError state } )
120{-# INLINE switchToPool #-}
121switchToPool :: Pool -> Solver ()
122switchToPool pool =
123 modifyPool (\_ -> pool)
126{-# INLINE getPool #-}
127getPool :: Solver Pool
128getPool =
129 Solver $ \state ->
130 return ( sPool state, state )
133{-# INLINE getEnv #-}
134getEnv :: Solver Env
135getEnv =
136 Solver $ \state ->
137 return ( sEnv state, state )
140{-# INLINE saveLocalEnv #-}
141saveLocalEnv :: Solver ()
142saveLocalEnv =
143 Solver $ \state ->
144 return ( (), state { sSavedEnv = sEnv state } )
147{-# INLINE uniqueMark #-}
148uniqueMark :: Solver Int
149uniqueMark =
150 Solver $ \state ->
151 let
152 mark =
153 sMark state
154 in
155 return ( mark, state { sMark = mark + 1 } )
158{-# INLINE nextRankPool #-}
159nextRankPool :: Solver Pool
160nextRankPool =
161 Solver $ \state ->
162 let
163 (Pool maxRank _) =
164 sPool state
165 in
166 return ( Pool (maxRank + 1) [], state )
170-- REGISTER VARIABLES
173{-# INLINE register #-}
174register :: Variable -> Solver Variable
175register variable =
176 {-# SCC elm_compiler_type_register #-}
177 Solver $ \state ->
178 let
179 (Pool maxRank inhabitants) =
180 sPool state
181 in
182 return ( variable, state { sPool = Pool maxRank (variable : inhabitants) } )
185{-# INLINE introduce #-}
186introduce :: Variable -> Solver Variable
187introduce variable =
188 {-# SCC elm_compiler_type_introduce #-}
189 Solver $ \state ->
190 let
191 (Pool maxRank inhabitants) =
192 sPool state
193 in
194 do UF.modifyDescriptor variable (\desc -> desc { _rank = maxRank })
195 return ( variable, state { sPool = Pool maxRank (variable : inhabitants) } )
199-- FLATTEN
202flatten :: Type -> Solver Variable
203flatten term =
204 {-# SCC elm_compiler_type_flatten #-}
205 flattenHelp Map.empty term
208flattenHelp :: Map.Map Text Variable -> Type -> Solver Variable
209flattenHelp aliasDict termN =
210 case termN of
211 PlaceHolder name ->
212 return (aliasDict ! name)
214 AliasN name args realType ->
215 do flatArgs <- mapM (traverse (flattenHelp aliasDict)) args
216 flatVar <- flattenHelp (Map.fromList flatArgs) realType
217 pool <- getPool
218 variable <-
219 liftIO $ UF.fresh $ Descriptor
220 { _content = Alias name flatArgs flatVar
221 , _rank = _maxRank pool
222 , _mark = noMark
223 , _copy = Nothing
224 }
225 register variable
227 VarN v ->
228 return v
230 TermN term1 ->
231 do variableTerm <- traverseTerm (flattenHelp aliasDict) term1
232 pool <- getPool
233 variable <-
234 liftIO $ UF.fresh $ Descriptor
235 { _content = Structure variableTerm
236 , _rank = _maxRank pool
237 , _mark = noMark
238 , _copy = Nothing
239 }
240 register variable
244-- MAKE INSTANCE
247makeInstance :: Variable -> Solver Variable
248makeInstance var =
249 do alreadyCopiedMark <- uniqueMark
250 freshVar <- makeCopy alreadyCopiedMark var
251 _ <- restore alreadyCopiedMark var
252 return freshVar
256-- MAKE COPY
259makeCopy :: Int -> Variable -> Solver Variable
260makeCopy alreadyCopiedMark variable =
261 {-# SCC elm_compiler_type_copy #-}
262 do desc <- liftIO $ UF.descriptor variable
263 makeCopyHelp desc alreadyCopiedMark variable
266makeCopyHelp :: Descriptor -> Int -> Variable -> Solver Variable
267makeCopyHelp (Descriptor content rank mark copy) alreadyCopiedMark variable =
268 if mark == alreadyCopiedMark then
269 case copy of
270 Just copiedVariable ->
271 return copiedVariable
273 Nothing ->
274 error
275 "Error copying type variable. This should be impossible.\
276 \ Please report this at <https://github.com/elm-lang/elm-compiler/issues>\
277 \ with a <http://sscce.org> and information on your OS, how you installed,\
278 \ and any other configuration information that might be helpful."
280 else if rank /= noRank || not (needsCopy content) then
281 return variable
283 else
284 do pool <- getPool
285 newVar <-
286 liftIO $ UF.fresh $ Descriptor
287 { _content = content -- place holder!
288 , _rank = _maxRank pool
289 , _mark = noMark
290 , _copy = Nothing
291 }
292 _ <- register newVar
294 -- Link the original variable to the new variable. This lets us
295 -- avoid making multiple copies of the variable we are instantiating.
296 --
297 -- Need to do this before recursively copying the content of
298 -- the variable to avoid looping on cyclic terms.
299 liftIO $ UF.modifyDescriptor variable $ \desc ->
300 desc { _mark = alreadyCopiedMark, _copy = Just newVar }
303 let setContent newContent =
304 liftIO $ UF.modifyDescriptor newVar $ \desc ->
305 desc { _content = newContent }
307 -- Now we recursively copy the content of the variable.
308 -- We have already marked the variable as copied, so we
309 -- will not repeat this work or crawl this variable again.
310 case content of
311 Structure term ->
312 do newTerm <- traverseTerm (makeCopy alreadyCopiedMark) term
313 setContent (Structure newTerm)
315 Atom _ ->
316 return ()
318 Var Rigid maybeSuper maybeName ->
319 setContent (Var Flex maybeSuper maybeName)
321 Var Flex _ _ ->
322 return ()
324 Alias name args realType ->
325 setContent =<< (
326 Alias name
327 <$> mapM (traverse (makeCopy alreadyCopiedMark)) args
328 <*> makeCopy alreadyCopiedMark realType
329 )
331 Error ->
332 return ()
334 return newVar
337needsCopy :: Content -> Bool
338needsCopy content =
339 case content of
340 Structure _ ->
341 True
343 Atom _ ->
344 False
346 Var _ _ _ ->
347 True
349 Alias _ _ _ ->
350 True
352 Error ->
353 False
357-- RESTORE
360restore :: Int -> Variable -> Solver Variable
361restore alreadyCopiedMark variable =
362 do desc <- liftIO $ UF.descriptor variable
363 if _mark desc /= alreadyCopiedMark
364 then
365 return variable
367 else
368 do restoredContent <-
369 restoreContent alreadyCopiedMark (_content desc)
370 liftIO $ UF.setDescriptor variable $ Descriptor
371 { _content = restoredContent
372 , _rank = noRank
373 , _mark = noMark
374 , _copy = Nothing
375 }
376 return variable
380restoreContent :: Int -> Content -> Solver Content
381restoreContent alreadyCopiedMark content =
382 let
383 go = restore alreadyCopiedMark
384 in
385 case content of
386 Structure term ->
387 Structure <$> traverseTerm go term
389 Atom _ ->
390 return content
392 Var _ _ _ ->
393 return content
395 Alias name args var ->
396 Alias name
397 <$> mapM (traverse go) args
398 <*> go var
400 Error ->
401 return content
405-- TERM TRAVERSAL
408traverseTerm :: (a -> Solver b) -> Term1 a -> Solver (Term1 b)
409traverseTerm f term =
410 case term of
411 App1 a b ->
412 liftM2 App1 (f a) (f b)
414 Fun1 a b ->
415 liftM2 Fun1 (f a) (f b)
417 EmptyRecord1 ->
418 pure EmptyRecord1
420 Record1 fields ext ->
421 liftM2 Record1 (traverse f fields) (f ext)
425-- INSTANCES
428instance Functor Solver where
429 {-# INLINE fmap #-}
430 fmap f (Solver solver) =
431 Solver $ \s1 ->
432 fmap (\(a, s2) -> (f a, s2)) (solver s1)
435instance Applicative Solver where
436 {-# INLINE pure #-}
437 pure a =
438 Solver $ \s -> return (a, s)
440 {-# INLINE (<*>) #-}
441 Solver solverFunc <*> Solver solverValue =
442 Solver $ \s1 ->
443 do (f, s2) <- solverFunc s1
444 (x, s3) <- solverValue s2
445 return (f x, s3)
448instance Monad Solver where
449 {-# INLINE (>>=) #-}
450 Solver solver >>= k =
451 Solver $ \s1 ->
452 do (a, s2) <- solver s1
453 (b, s3) <- _solve (k a) s2
454 return (b, s3)
456 {-# INLINE fail #-}
457 fail msg =
458 Solver $ \_ -> fail msg
461instance MonadIO Solver where
462 {-# INLINE liftIO #-}
463 liftIO io =
464 Solver $ \state ->
465 do a <- io
466 return (a, state)