git.iko.soy/elk
on e00a3f3 help sign in
elk/src/Type/State.hs
477 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 (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 a b ->
223 do flatA <- flattenHelp aliasDict a
224 flatB <- flattenHelp aliasDict b
225 makeFlatType (Structure (App1 flatA flatB))
227 FunN a b ->
228 do flatA <- flattenHelp aliasDict a
229 flatB <- flattenHelp aliasDict b
230 makeFlatType (Structure (Fun1 flatA flatB))
232 EmptyRecordN ->
233 makeFlatType (Structure EmptyRecord1)
235 RecordN fields ext ->
236 do flatFields <- traverse (flattenHelp aliasDict) fields
237 flatExt <- flattenHelp aliasDict ext
238 makeFlatType (Structure (Record1 flatFields flatExt))
241makeFlatType :: Content -> Solver Variable
242makeFlatType content =
243 do pool <- getPool
244 variable <- liftIO $ UF.fresh $
245 Descriptor
246 { _content = content
247 , _rank = _maxRank pool
248 , _mark = noMark
249 , _copy = Nothing
250 }
251 register variable
255-- MAKE INSTANCE
258makeInstance :: Variable -> Solver Variable
259makeInstance var =
260 do alreadyCopiedMark <- uniqueMark
261 freshVar <- makeCopy alreadyCopiedMark var
262 _ <- restore alreadyCopiedMark var
263 return freshVar
267-- MAKE COPY
270makeCopy :: Int -> Variable -> Solver Variable
271makeCopy alreadyCopiedMark variable =
272 {-# SCC elm_compiler_type_copy #-}
273 do desc <- liftIO $ UF.descriptor variable
274 makeCopyHelp desc alreadyCopiedMark variable
277makeCopyHelp :: Descriptor -> Int -> Variable -> Solver Variable
278makeCopyHelp (Descriptor content rank mark copy) alreadyCopiedMark variable =
279 if mark == alreadyCopiedMark then
280 case copy of
281 Just copiedVariable ->
282 return copiedVariable
284 Nothing ->
285 error
286 "Error copying type variable. This should be impossible.\
287 \ Please report this at <https://github.com/elm-lang/elm-compiler/issues>\
288 \ with a <http://sscce.org> and information on your OS, how you installed,\
289 \ and any other configuration information that might be helpful."
291 else if rank /= noRank || not (needsCopy content) then
292 return variable
294 else
295 do pool <- getPool
296 newVar <-
297 liftIO $ UF.fresh $ Descriptor
298 { _content = content -- place holder!
299 , _rank = _maxRank pool
300 , _mark = noMark
301 , _copy = Nothing
302 }
303 _ <- register newVar
305 -- Link the original variable to the new variable. This lets us
306 -- avoid making multiple copies of the variable we are instantiating.
307 --
308 -- Need to do this before recursively copying the content of
309 -- the variable to avoid looping on cyclic terms.
310 liftIO $ UF.modifyDescriptor variable $ \desc ->
311 desc { _mark = alreadyCopiedMark, _copy = Just newVar }
314 let setContent newContent =
315 liftIO $ UF.modifyDescriptor newVar $ \desc ->
316 desc { _content = newContent }
318 -- Now we recursively copy the content of the variable.
319 -- We have already marked the variable as copied, so we
320 -- will not repeat this work or crawl this variable again.
321 case content of
322 Structure term ->
323 do newTerm <- traverseFlatType (makeCopy alreadyCopiedMark) term
324 setContent (Structure newTerm)
326 Atom _ ->
327 return ()
329 Var Rigid maybeSuper maybeName ->
330 setContent (Var Flex maybeSuper maybeName)
332 Var Flex _ _ ->
333 return ()
335 Alias name args realType ->
336 setContent =<< (
337 Alias name
338 <$> mapM (traverse (makeCopy alreadyCopiedMark)) args
339 <*> makeCopy alreadyCopiedMark realType
340 )
342 Error ->
343 return ()
345 return newVar
348needsCopy :: Content -> Bool
349needsCopy content =
350 case content of
351 Structure _ ->
352 True
354 Atom _ ->
355 False
357 Var _ _ _ ->
358 True
360 Alias _ _ _ ->
361 True
363 Error ->
364 False
368-- RESTORE
371restore :: Int -> Variable -> Solver Variable
372restore alreadyCopiedMark variable =
373 do desc <- liftIO $ UF.descriptor variable
374 if _mark desc /= alreadyCopiedMark
375 then
376 return variable
378 else
379 do restoredContent <-
380 restoreContent alreadyCopiedMark (_content desc)
381 liftIO $ UF.setDescriptor variable $ Descriptor
382 { _content = restoredContent
383 , _rank = noRank
384 , _mark = noMark
385 , _copy = Nothing
386 }
387 return variable
391restoreContent :: Int -> Content -> Solver Content
392restoreContent alreadyCopiedMark content =
393 let
394 go = restore alreadyCopiedMark
395 in
396 case content of
397 Structure term ->
398 Structure <$> traverseFlatType go term
400 Atom _ ->
401 return content
403 Var _ _ _ ->
404 return content
406 Alias name args var ->
407 Alias name
408 <$> mapM (traverse go) args
409 <*> go var
411 Error ->
412 return content
416-- TRAVERSE FLAT TYPE
419traverseFlatType :: (Variable -> Solver Variable) -> FlatType -> Solver FlatType
420traverseFlatType f flatType =
421 case flatType of
422 App1 a b ->
423 liftM2 App1 (f a) (f b)
425 Fun1 a b ->
426 liftM2 Fun1 (f a) (f b)
428 EmptyRecord1 ->
429 pure EmptyRecord1
431 Record1 fields ext ->
432 liftM2 Record1 (traverse f fields) (f ext)
436-- INSTANCES
439instance Functor Solver where
440 {-# INLINE fmap #-}
441 fmap f (Solver solver) =
442 Solver $ \s1 ->
443 fmap (\(a, s2) -> (f a, s2)) (solver s1)
446instance Applicative Solver where
447 {-# INLINE pure #-}
448 pure a =
449 Solver $ \s -> return (a, s)
451 {-# INLINE (<*>) #-}
452 Solver solverFunc <*> Solver solverValue =
453 Solver $ \s1 ->
454 do (f, s2) <- solverFunc s1
455 (x, s3) <- solverValue s2
456 return (f x, s3)
459instance Monad Solver where
460 {-# INLINE (>>=) #-}
461 Solver solver >>= k =
462 Solver $ \s1 ->
463 do (a, s2) <- solver s1
464 (b, s3) <- _solve (k a) s2
465 return (b, s3)
467 {-# INLINE fail #-}
468 fail msg =
469 Solver $ \_ -> fail msg
472instance MonadIO Solver where
473 {-# INLINE liftIO #-}
474 liftIO io =
475 Solver $ \state ->
476 do a <- io
477 return (a, state)