git.iko.soy/elk
on 6a96e21 help sign in
elk/compiler/src/Type/Solve.hs
713 lines 21 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Type.Solve
4 ( run
5 )
6 where
9import Control.Monad
10import qualified Data.Map.Strict as Map
11import Data.Map.Strict ((!))
12import qualified Data.Vector as Vector
13import qualified Data.Vector.Mutable as MVector
15import qualified AST.Canonical as Can
16import qualified Elm.Name as N
17import qualified Reporting.Annotation as A
18import qualified Reporting.Error.Type as Error
19import qualified Reporting.Render.Type as RT
20import qualified Type.Occurs as Occurs
21import Type.Type as Type
22import qualified Type.Error as ET
23import qualified Type.Unify as Unify
24import qualified Type.UnionFind as UF
28-- RUN SOLVER
31run :: Constraint -> IO (Either [Error.Error] (Map.Map N.Name Can.Annotation))
32run constraint =
33 do pools <- MVector.replicate 8 []
35 (State env _ errors) <-
36 solve Map.empty outermostRank pools emptyState constraint
38 case errors of
39 [] ->
40 Right <$> traverse Type.toAnnotation env
42 _ ->
43 return $ Left errors
47{-# NOINLINE emptyState #-}
48emptyState :: State
49emptyState =
50 State Map.empty (nextMark noMark) []
54-- SOLVER
57type Env =
58 Map.Map N.Name Variable
61type Pools =
62 MVector.IOVector [Variable]
65data State =
66 State
67 { _env :: Env
68 , _mark :: Mark
69 , _errors :: [Error.Error]
70 }
73solve :: Env -> Int -> Pools -> State -> Constraint -> IO State
74solve env rank pools state constraint =
75 case constraint of
76 CTrue ->
77 return state
79 CSaveTheEnvironment ->
80 return (state { _env = env })
82 CEqual region category tipe expectation ->
83 do actual <- typeToVariable rank pools tipe
84 expected <- expectedToVariable rank pools expectation
85 answer <- Unify.unify actual expected
86 case answer of
87 Unify.Ok vars ->
88 do introduce rank pools vars
89 return state
91 Unify.Err vars actualType expectedType ->
92 do introduce rank pools vars
93 return $ addError state $
94 Error.BadExpr region category actualType $
95 Error.typeReplace expectation expectedType
97 CLocal region name expectation ->
98 do actual <- makeCopy rank pools (env ! name)
99 expected <- expectedToVariable rank pools expectation
100 answer <- Unify.unify actual expected
101 case answer of
102 Unify.Ok vars ->
103 do introduce rank pools vars
104 return state
106 Unify.Err vars actualType expectedType ->
107 do introduce rank pools vars
108 return $ addError state $
109 Error.BadExpr region (Error.Local name) actualType $
110 Error.typeReplace expectation expectedType
112 CForeign region name (Can.Forall freeVars srcType) expectation ->
113 do actual <- srcTypeToVariable rank pools freeVars srcType
114 expected <- expectedToVariable rank pools expectation
115 answer <- Unify.unify actual expected
116 case answer of
117 Unify.Ok vars ->
118 do introduce rank pools vars
119 return state
121 Unify.Err vars actualType expectedType ->
122 do introduce rank pools vars
123 return $ addError state $
124 Error.BadExpr region (Error.Foreign name) actualType $
125 Error.typeReplace expectation expectedType
127 CPattern region category tipe expectation ->
128 do actual <- typeToVariable rank pools tipe
129 expected <- patternExpectationToVariable rank pools expectation
130 answer <- Unify.unify actual expected
131 case answer of
132 Unify.Ok vars ->
133 do introduce rank pools vars
134 return state
136 Unify.Err vars actualType expectedType ->
137 do introduce rank pools vars
138 return $ addError state $
139 Error.BadPattern region category actualType
140 (Error.ptypeReplace expectation expectedType)
142 CAnd constraints ->
143 foldM (solve env rank pools) state constraints
145 CLet [] flexs _ headerCon CTrue ->
146 do introduce rank pools flexs
147 solve env rank pools state headerCon
149 CLet [] [] header headerCon subCon ->
150 do state1 <- solve env rank pools state headerCon
151 locals <- traverse (A.traverse (typeToVariable rank pools)) header
152 let newEnv = Map.union env (Map.map A.toValue locals)
153 state2 <- solve newEnv rank pools state1 subCon
154 foldM occurs state2 $ Map.toList locals
156 CLet rigids flexs header headerCon subCon ->
157 do
158 -- work in the next pool to localize header
159 let nextRank = rank + 1
160 let poolsLength = MVector.length pools
161 nextPools <-
162 if nextRank < poolsLength
163 then return pools
164 else MVector.grow pools poolsLength
166 -- introduce variables
167 let vars = rigids ++ flexs
168 forM_ vars $ \var ->
169 UF.modify var $ \(Descriptor content _ mark copy) ->
170 Descriptor content nextRank mark copy
171 MVector.write nextPools nextRank vars
173 -- run solver in next pool
174 locals <- traverse (A.traverse (typeToVariable nextRank nextPools)) header
175 (State savedEnv mark errors) <-
176 solve env nextRank nextPools state headerCon
178 let youngMark = mark
179 let visitMark = nextMark youngMark
180 let finalMark = nextMark visitMark
182 -- pop pool
183 generalize youngMark visitMark nextRank nextPools
184 MVector.write nextPools nextRank []
186 -- check that things went well
187 mapM_ isGeneric rigids
189 let newEnv = Map.union env (Map.map A.toValue locals)
190 let tempState = State savedEnv finalMark errors
191 newState <- solve newEnv rank nextPools tempState subCon
193 foldM occurs newState (Map.toList locals)
196-- Check that a variable has rank == noRank, meaning that it can be generalized.
197isGeneric :: Variable -> IO ()
198isGeneric var =
199 do (Descriptor _ rank _ _) <- UF.get var
200 if rank == noRank
201 then return ()
202 else
203 do tipe <- Type.toErrorType var
204 error $
205 "You ran into a compiler bug. Here are some details for the developers:\n\n"
206 ++ " " ++ show (ET.toDoc Map.empty RT.None tipe) ++ " [rank = " ++ show rank ++ "]\n\n"
207 ++
208 "Please create an <http://sscce.org/> and then report it\n\
209 \at <https://github.com/elm-lang/elm-compiler/issues>\n\n"
213-- EXPECTATIONS TO VARIABLE
216expectedToVariable :: Int -> Pools -> Error.Expected Type -> IO Variable
217expectedToVariable rank pools expectation =
218 typeToVariable rank pools $
219 case expectation of
220 Error.NoExpectation tipe ->
221 tipe
223 Error.FromContext _ _ tipe ->
224 tipe
226 Error.FromAnnotation _ _ _ tipe ->
227 tipe
230patternExpectationToVariable :: Int -> Pools -> Error.PExpected Type -> IO Variable
231patternExpectationToVariable rank pools expectation =
232 typeToVariable rank pools $
233 case expectation of
234 Error.PNoExpectation tipe ->
235 tipe
237 Error.PFromContext _ _ tipe ->
238 tipe
242-- ERROR HELPERS
245addError :: State -> Error.Error -> State
246addError (State savedEnv rank errors) err =
247 State savedEnv rank (err:errors)
251-- OCCURS CHECK
254occurs :: State -> (N.Name, A.Located Variable) -> IO State
255occurs state (name, A.At region variable) =
256 do hasOccurred <- Occurs.occurs variable
257 if hasOccurred
258 then
259 do errorType <- Type.toErrorType variable
260 (Descriptor _ rank mark copy) <- UF.get variable
261 UF.set variable (Descriptor Error rank mark copy)
262 return $ state { _errors = Error.InfiniteType region name errorType : _errors state }
263 else
264 return state
268-- GENERALIZE
271{-| Every variable has rank less than or equal to the maxRank of the pool.
272This sorts variables into the young and old pools accordingly.
273-}
274generalize :: Mark -> Mark -> Int -> Pools -> IO ()
275generalize youngMark visitMark youngRank pools =
276 do youngVars <- MVector.read pools youngRank
277 rankTable <- poolToRankTable youngMark youngRank youngVars
279 -- get the ranks right for each entry.
280 -- start at low ranks so that we only have to pass
281 -- over the information once.
282 Vector.imapM_
283 (\rank table -> mapM_ (adjustRank youngMark visitMark rank) table)
284 rankTable
286 -- For variables that have rank lowerer than youngRank, register them in
287 -- the appropriate old pool if they are not redundant.
288 Vector.forM_ (Vector.unsafeInit rankTable) $ \vars ->
289 forM_ vars $ \var ->
290 do isRedundant <- UF.redundant var
291 if isRedundant
292 then return ()
293 else
294 do (Descriptor _ rank _ _) <- UF.get var
295 MVector.modify pools (var:) rank
297 -- For variables with rank youngRank
298 -- If rank < youngRank: register in oldPool
299 -- otherwise generalize
300 forM_ (Vector.unsafeLast rankTable) $ \var ->
301 do isRedundant <- UF.redundant var
302 if isRedundant
303 then return ()
304 else
305 do (Descriptor content rank mark copy) <- UF.get var
306 if rank < youngRank
307 then MVector.modify pools (var:) rank
308 else UF.set var $ Descriptor content noRank mark copy
311poolToRankTable :: Mark -> Int -> [Variable] -> IO (Vector.Vector [Variable])
312poolToRankTable youngMark youngRank youngInhabitants =
313 do mutableTable <- MVector.replicate (youngRank + 1) []
315 -- Sort the youngPool variables into buckets by rank.
316 forM_ youngInhabitants $ \var ->
317 do (Descriptor content rank _ copy) <- UF.get var
318 UF.set var (Descriptor content rank youngMark copy)
319 MVector.modify mutableTable (var:) rank
321 Vector.unsafeFreeze mutableTable
325-- ADJUST RANK
327--
328-- Adjust variable ranks such that ranks never increase as you move deeper.
329-- This way the outermost rank is representative of the entire structure.
330--
331adjustRank :: Mark -> Mark -> Int -> Variable -> IO Int
332adjustRank youngMark visitMark groupRank var =
333 do (Descriptor content rank mark copy) <- UF.get var
334 if mark == youngMark then
335 do -- Set the variable as marked first because it may be cyclic.
336 UF.set var $ Descriptor content rank visitMark copy
337 maxRank <- adjustRankContent youngMark visitMark groupRank content
338 UF.set var $ Descriptor content maxRank visitMark copy
339 return maxRank
341 else if mark == visitMark then
342 return rank
344 else
345 do let minRank = min groupRank rank
346 -- TODO how can minRank ever be groupRank?
347 UF.set var $ Descriptor content minRank visitMark copy
348 return minRank
351adjustRankContent :: Mark -> Mark -> Int -> Content -> IO Int
352adjustRankContent youngMark visitMark groupRank content =
353 let
354 go = adjustRank youngMark visitMark groupRank
355 in
356 case content of
357 FlexVar _ ->
358 return groupRank
360 FlexSuper _ _ ->
361 return groupRank
363 RigidVar _ ->
364 return groupRank
366 RigidSuper _ _ ->
367 return groupRank
369 Structure flatType ->
370 case flatType of
371 App1 _ _ args ->
372 foldM (\rank arg -> max rank <$> go arg) outermostRank args
374 Fun1 arg result ->
375 max <$> go arg <*> go result
377 EmptyRecord1 ->
378 -- THEORY: an empty record never needs to get generalized
379 return outermostRank
381 Record1 fields extension ->
382 do extRank <- go extension
383 foldM (\rank field -> max rank <$> go field) extRank fields
385 Unit1 ->
386 -- THEORY: a unit never needs to get generalized
387 return outermostRank
389 Tuple1 a b maybeC ->
390 do ma <- go a
391 mb <- go b
392 case maybeC of
393 Nothing ->
394 return (max ma mb)
396 Just c ->
397 max (max ma mb) <$> go c
399 Alias _ _ args _ ->
400 -- THEORY: anything in the realVar would be outermostRank
401 foldM (\rank (_, argVar) -> max rank <$> go argVar) outermostRank args
403 Error ->
404 return groupRank
408-- REGISTER VARIABLES
411introduce :: Int -> Pools -> [Variable] -> IO ()
412introduce rank pools variables =
413 do MVector.modify pools (variables++) rank
414 forM_ variables $ \var ->
415 UF.modify var $ \(Descriptor content _ mark copy) ->
416 Descriptor content rank mark copy
420-- TYPE TO VARIABLE
423typeToVariable :: Int -> Pools -> Type -> IO Variable
424typeToVariable rank pools tipe =
425 typeToVar rank pools Map.empty tipe
428typeToVar :: Int -> Pools -> Map.Map N.Name Variable -> Type -> IO Variable
429typeToVar rank pools aliasDict tipe =
430 let go = typeToVar rank pools aliasDict in
431 case tipe of
432 VarN v ->
433 return v
435 AppN home name args ->
436 do argVars <- traverse go args
437 register rank pools (Structure (App1 home name argVars))
439 FunN a b ->
440 do aVar <- go a
441 bVar <- go b
442 register rank pools (Structure (Fun1 aVar bVar))
444 AliasN home name args aliasType ->
445 do argVars <- traverse (traverse go) args
446 aliasVar <- typeToVar rank pools (Map.fromList argVars) aliasType
447 register rank pools (Alias home name argVars aliasVar)
449 PlaceHolder name ->
450 return (aliasDict ! name)
452 RecordN fields ext ->
453 do fieldVars <- traverse go fields
454 extVar <- go ext
455 register rank pools (Structure (Record1 fieldVars extVar))
457 EmptyRecordN ->
458 register rank pools emptyRecord1
460 UnitN ->
461 register rank pools unit1
463 TupleN a b c ->
464 do aVar <- go a
465 bVar <- go b
466 cVar <- traverse go c
467 register rank pools (Structure (Tuple1 aVar bVar cVar))
470register :: Int -> Pools -> Content -> IO Variable
471register rank pools content =
472 do var <- UF.fresh (Descriptor content rank noMark Nothing)
473 MVector.modify pools (var:) rank
474 return var
477{-# NOINLINE emptyRecord1 #-}
478emptyRecord1 :: Content
479emptyRecord1 =
480 Structure EmptyRecord1
483{-# NOINLINE unit1 #-}
484unit1 :: Content
485unit1 =
486 Structure Unit1
490-- SOURCE TYPE TO VARIABLE
493srcTypeToVariable :: Int -> Pools -> Map.Map N.Name () -> Can.Type -> IO Variable
494srcTypeToVariable rank pools freeVars srcType =
495 let
496 nameToContent name
497 | N.startsWith "number" name = FlexSuper Number (Just name)
498 | N.startsWith "comparable" name = FlexSuper Comparable (Just name)
499 | N.startsWith "appendable" name = FlexSuper Appendable (Just name)
500 | N.startsWith "compappend" name = FlexSuper CompAppend (Just name)
501 | otherwise = FlexVar (Just name)
503 makeVar name _ =
504 UF.fresh (Descriptor (nameToContent name) rank noMark Nothing)
505 in
506 do flexVars <- Map.traverseWithKey makeVar freeVars
507 MVector.modify pools (Map.elems flexVars ++) rank
508 srcTypeToVar rank pools flexVars srcType
511srcTypeToVar :: Int -> Pools -> Map.Map N.Name Variable -> Can.Type -> IO Variable
512srcTypeToVar rank pools flexVars srcType =
513 let go = srcTypeToVar rank pools flexVars in
514 case srcType of
515 Can.TLambda argument result ->
516 do argVar <- go argument
517 resultVar <- go result
518 register rank pools (Structure (Fun1 argVar resultVar))
520 Can.TVar name ->
521 return (flexVars ! name)
523 Can.TType home name args ->
524 do argVars <- traverse go args
525 register rank pools (Structure (App1 home name argVars))
527 Can.TRecord fields maybeExt ->
528 do fieldVars <- traverse go fields
529 extVar <-
530 case maybeExt of
531 Nothing -> register rank pools emptyRecord1
532 Just ext -> return (flexVars ! ext)
533 register rank pools (Structure (Record1 fieldVars extVar))
535 Can.TUnit ->
536 register rank pools unit1
538 Can.TTuple a b c ->
539 do aVar <- go a
540 bVar <- go b
541 cVar <- traverse go c
542 register rank pools (Structure (Tuple1 aVar bVar cVar))
544 Can.TAlias home name args aliasType ->
545 do argVars <- traverse (traverse go) args
546 aliasVar <-
547 case aliasType of
548 Can.Holey tipe ->
549 srcTypeToVar rank pools (Map.fromList argVars) tipe
551 Can.Filled tipe ->
552 go tipe
554 register rank pools (Alias home name argVars aliasVar)
558-- COPY
561makeCopy :: Int -> Pools -> Variable -> IO Variable
562makeCopy rank pools var =
563 do copy <- makeCopyHelp rank pools var
564 restore var
565 return copy
568makeCopyHelp :: Int -> Pools -> Variable -> IO Variable
569makeCopyHelp maxRank pools variable =
570 do (Descriptor content rank _ maybeCopy) <- UF.get variable
572 case maybeCopy of
573 Just copy ->
574 return copy
576 Nothing ->
577 if rank /= noRank then
578 return variable
580 else
581 do let makeDescriptor c = Descriptor c maxRank noMark Nothing
582 copy <- UF.fresh $ makeDescriptor content
583 MVector.modify pools (copy:) maxRank
585 -- Link the original variable to the new variable. This lets us
586 -- avoid making multiple copies of the variable we are instantiating.
587 --
588 -- Need to do this before recursively copying to avoid looping.
589 UF.set variable $
590 Descriptor content rank noMark (Just copy)
592 -- Now we recursively copy the content of the variable.
593 -- We have already marked the variable as copied, so we
594 -- will not repeat this work or crawl this variable again.
595 case content of
596 Structure term ->
597 do newTerm <- traverseFlatType (makeCopyHelp maxRank pools) term
598 UF.set copy $ makeDescriptor (Structure newTerm)
599 return copy
601 FlexVar _ ->
602 return copy
604 FlexSuper _ _ ->
605 return copy
607 RigidVar name ->
608 do UF.set copy $ makeDescriptor $ FlexVar (Just name)
609 return copy
611 RigidSuper super name ->
612 do UF.set copy $ makeDescriptor $ FlexSuper super (Just name)
613 return copy
615 Alias home name args realType ->
616 do newArgs <- mapM (traverse (makeCopyHelp maxRank pools)) args
617 newRealType <- makeCopyHelp maxRank pools realType
618 UF.set copy $ makeDescriptor (Alias home name newArgs newRealType)
619 return copy
621 Error ->
622 return copy
626-- RESTORE
629restore :: Variable -> IO ()
630restore variable =
631 do (Descriptor content _ _ maybeCopy) <- UF.get variable
632 case maybeCopy of
633 Nothing ->
634 return ()
636 Just _ ->
637 do UF.set variable $ Descriptor content noRank noMark Nothing
638 restoreContent content
641restoreContent :: Content -> IO ()
642restoreContent content =
643 case content of
644 FlexVar _ ->
645 return ()
647 FlexSuper _ _ ->
648 return ()
650 RigidVar _ ->
651 return ()
653 RigidSuper _ _ ->
654 return ()
656 Structure term ->
657 case term of
658 App1 _ _ args ->
659 mapM_ restore args
661 Fun1 arg result ->
662 do restore arg
663 restore result
665 EmptyRecord1 ->
666 return ()
668 Record1 fields ext ->
669 do mapM_ restore fields
670 restore ext
672 Unit1 ->
673 return ()
675 Tuple1 a b maybeC ->
676 do restore a
677 restore b
678 case maybeC of
679 Nothing -> return ()
680 Just c -> restore c
682 Alias _ _ args var ->
683 do mapM_ (traverse restore) args
684 restore var
686 Error ->
687 return ()
691-- TRAVERSE FLAT TYPE
694traverseFlatType :: (Variable -> IO Variable) -> FlatType -> IO FlatType
695traverseFlatType f flatType =
696 case flatType of
697 App1 home name args ->
698 liftM (App1 home name) (traverse f args)
700 Fun1 a b ->
701 liftM2 Fun1 (f a) (f b)
703 EmptyRecord1 ->
704 pure EmptyRecord1
706 Record1 fields ext ->
707 liftM2 Record1 (traverse f fields) (f ext)
709 Unit1 ->
710 pure Unit1
712 Tuple1 a b cs ->
713 liftM3 Tuple1 (f a) (f b) (traverse f cs)