git.iko.soy/elk
on 4cd5aec help sign in
elk/src/Type/State.hs
467 lines 11 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 (liftM, liftM2)
26import Control.Monad.Trans (MonadIO, liftIO)
27import qualified Data.Map as Map
28import Data.Map ((!))
29import Data.Text (Text)
31import qualified Reporting.Annotation as A
32import qualified Reporting.Error.Type as Error
33import qualified Reporting.Region as R
34import Type.Type
35import qualified Type.UnionFind as UF
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 makeFlatType (Alias name flatArgs flatVar)
219 VarN v ->
220 return v
222 AppN name args ->
223 do flatArgs <- traverse (flattenHelp aliasDict) args
224 makeFlatType (Structure (App1 name flatArgs))
226 FunN a b ->
227 do flatA <- flattenHelp aliasDict a
228 flatB <- flattenHelp aliasDict b
229 makeFlatType (Structure (Fun1 flatA flatB))
231 EmptyRecordN ->
232 makeFlatType (Structure EmptyRecord1)
234 RecordN fields ext ->
235 do flatFields <- traverse (flattenHelp aliasDict) fields
236 flatExt <- flattenHelp aliasDict ext
237 makeFlatType (Structure (Record1 flatFields flatExt))
240makeFlatType :: Content -> Solver Variable
241makeFlatType content =
242 do pool <- getPool
243 variable <- liftIO $ UF.fresh $
244 Descriptor
245 { _content = content
246 , _rank = _maxRank pool
247 , _mark = noMark
248 , _copy = Nothing
249 }
250 register variable
254-- MAKE INSTANCE
257makeInstance :: Variable -> Solver Variable
258makeInstance var =
259 do alreadyCopiedMark <- uniqueMark
260 freshVar <- makeCopy alreadyCopiedMark var
261 _ <- restore alreadyCopiedMark var
262 return freshVar
266-- MAKE COPY
269makeCopy :: Int -> Variable -> Solver Variable
270makeCopy alreadyCopiedMark variable =
271 {-# SCC elm_compiler_type_copy #-}
272 do desc <- liftIO $ UF.descriptor variable
273 makeCopyHelp desc alreadyCopiedMark variable
276makeCopyHelp :: Descriptor -> Int -> Variable -> Solver Variable
277makeCopyHelp (Descriptor content rank mark copy) alreadyCopiedMark variable =
278 if mark == alreadyCopiedMark then
279 case copy of
280 Just copiedVariable ->
281 return copiedVariable
283 Nothing ->
284 error
285 "Error copying type variable. This should be impossible.\
286 \ Please report this at <https://github.com/elm-lang/elm-compiler/issues>\
287 \ with a <http://sscce.org> and information on your OS, how you installed,\
288 \ and any other configuration information that might be helpful."
290 else if rank /= noRank || not (needsCopy content) then
291 return variable
293 else
294 do pool <- getPool
295 newVar <-
296 liftIO $ UF.fresh $ Descriptor
297 { _content = content -- place holder!
298 , _rank = _maxRank pool
299 , _mark = noMark
300 , _copy = Nothing
301 }
302 _ <- register newVar
304 -- Link the original variable to the new variable. This lets us
305 -- avoid making multiple copies of the variable we are instantiating.
306 --
307 -- Need to do this before recursively copying the content of
308 -- the variable to avoid looping on cyclic terms.
309 liftIO $ UF.modifyDescriptor variable $ \desc ->
310 desc { _mark = alreadyCopiedMark, _copy = Just newVar }
313 let setContent newContent =
314 liftIO $ UF.modifyDescriptor newVar $ \desc ->
315 desc { _content = newContent }
317 -- Now we recursively copy the content of the variable.
318 -- We have already marked the variable as copied, so we
319 -- will not repeat this work or crawl this variable again.
320 case content of
321 Structure term ->
322 do newTerm <- traverseFlatType (makeCopy alreadyCopiedMark) term
323 setContent (Structure newTerm)
325 Var Rigid maybeSuper maybeName ->
326 setContent (Var Flex maybeSuper maybeName)
328 Var Flex _ _ ->
329 return ()
331 Alias name args realType ->
332 setContent =<< (
333 Alias name
334 <$> mapM (traverse (makeCopy alreadyCopiedMark)) args
335 <*> makeCopy alreadyCopiedMark realType
336 )
338 Error _ ->
339 return ()
341 return newVar
344needsCopy :: Content -> Bool
345needsCopy content =
346 case content of
347 Structure _ ->
348 True
350 Var _ _ _ ->
351 True
353 Alias _ _ _ ->
354 True
356 Error _ ->
357 False
361-- RESTORE
364restore :: Int -> Variable -> Solver Variable
365restore alreadyCopiedMark variable =
366 do desc <- liftIO $ UF.descriptor variable
367 if _mark desc /= alreadyCopiedMark
368 then
369 return variable
371 else
372 do restoredContent <-
373 restoreContent alreadyCopiedMark (_content desc)
374 liftIO $ UF.setDescriptor variable $ Descriptor
375 { _content = restoredContent
376 , _rank = noRank
377 , _mark = noMark
378 , _copy = Nothing
379 }
380 return variable
384restoreContent :: Int -> Content -> Solver Content
385restoreContent alreadyCopiedMark content =
386 let
387 go = restore alreadyCopiedMark
388 in
389 case content of
390 Structure term ->
391 Structure <$> traverseFlatType go term
393 Var _ _ _ ->
394 return content
396 Alias name args var ->
397 Alias name
398 <$> mapM (traverse go) args
399 <*> go var
401 Error _ ->
402 return content
406-- TRAVERSE FLAT TYPE
409traverseFlatType :: (Variable -> Solver Variable) -> FlatType -> Solver FlatType
410traverseFlatType f flatType =
411 case flatType of
412 App1 name args ->
413 liftM (App1 name) (traverse f args)
415 Fun1 a b ->
416 liftM2 Fun1 (f a) (f b)
418 EmptyRecord1 ->
419 pure EmptyRecord1
421 Record1 fields ext ->
422 liftM2 Record1 (traverse f fields) (f ext)
426-- INSTANCES
429instance Functor Solver where
430 {-# INLINE fmap #-}
431 fmap f (Solver solver) =
432 Solver $ \s1 ->
433 fmap (\(a, s2) -> (f a, s2)) (solver s1)
436instance Applicative Solver where
437 {-# INLINE pure #-}
438 pure a =
439 Solver $ \s -> return (a, s)
441 {-# INLINE (<*>) #-}
442 Solver solverFunc <*> Solver solverValue =
443 Solver $ \s1 ->
444 do (f, s2) <- solverFunc s1
445 (x, s3) <- solverValue s2
446 return (f x, s3)
449instance Monad Solver where
450 {-# INLINE (>>=) #-}
451 Solver solver >>= k =
452 Solver $ \s1 ->
453 do (a, s2) <- solver s1
454 (b, s3) <- _solve (k a) s2
455 return (b, s3)
457 {-# INLINE fail #-}
458 fail msg =
459 Solver $ \_ -> fail msg
462instance MonadIO Solver where
463 {-# INLINE liftIO #-}
464 liftIO io =
465 Solver $ \state ->
466 do a <- io
467 return (a, state)