git.iko.soy/elk
on 42f3721 help sign in
elk/compiler/src/Type/Solve.hs
719 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 Reporting.Render.Type.Localizer as L
21import qualified Type.Occurs as Occurs
22import Type.Type as Type
23import qualified Type.Error as ET
24import qualified Type.Unify as Unify
25import qualified Type.UnionFind as UF
29-- RUN SOLVER
32run :: Constraint -> IO (Either [Error.Error] (Map.Map N.Name Can.Annotation))
33run constraint =
34 do pools <- MVector.replicate 8 []
36 (State env _ errors) <-
37 solve Map.empty outermostRank pools emptyState constraint
39 case errors of
40 [] ->
41 Right <$> traverse Type.toAnnotation env
43 _ ->
44 return $ Left errors
48{-# NOINLINE emptyState #-}
49emptyState :: State
50emptyState =
51 State Map.empty (nextMark noMark) []
55-- SOLVER
58type Env =
59 Map.Map N.Name Variable
62type Pools =
63 MVector.IOVector [Variable]
66data State =
67 State
68 { _env :: Env
69 , _mark :: Mark
70 , _errors :: [Error.Error]
71 }
74solve :: Env -> Int -> Pools -> State -> Constraint -> IO State
75solve env rank pools state constraint =
76 case constraint of
77 CTrue ->
78 return state
80 CSaveTheEnvironment ->
81 return (state { _env = env })
83 CEqual region category tipe expectation ->
84 do actual <- typeToVariable rank pools tipe
85 expected <- expectedToVariable rank pools expectation
86 answer <- Unify.unify actual expected
87 case answer of
88 Unify.Ok vars ->
89 do introduce rank pools vars
90 return state
92 Unify.Err vars actualType expectedType ->
93 do introduce rank pools vars
94 return $ addError state $
95 Error.BadExpr region category actualType $
96 Error.typeReplace expectation expectedType
98 CLocal region name expectation ->
99 do actual <- makeCopy rank pools (env ! name)
100 expected <- expectedToVariable rank pools expectation
101 answer <- Unify.unify actual expected
102 case answer of
103 Unify.Ok vars ->
104 do introduce rank pools vars
105 return state
107 Unify.Err vars actualType expectedType ->
108 do introduce rank pools vars
109 return $ addError state $
110 Error.BadExpr region (Error.Local name) actualType $
111 Error.typeReplace expectation expectedType
113 CForeign region name (Can.Forall freeVars srcType) expectation ->
114 do actual <- srcTypeToVariable rank pools freeVars srcType
115 expected <- expectedToVariable rank pools expectation
116 answer <- Unify.unify actual expected
117 case answer of
118 Unify.Ok vars ->
119 do introduce rank pools vars
120 return state
122 Unify.Err vars actualType expectedType ->
123 do introduce rank pools vars
124 return $ addError state $
125 Error.BadExpr region (Error.Foreign name) actualType $
126 Error.typeReplace expectation expectedType
128 CPattern region category tipe expectation ->
129 do actual <- typeToVariable rank pools tipe
130 expected <- patternExpectationToVariable rank pools expectation
131 answer <- Unify.unify actual expected
132 case answer of
133 Unify.Ok vars ->
134 do introduce rank pools vars
135 return state
137 Unify.Err vars actualType expectedType ->
138 do introduce rank pools vars
139 return $ addError state $
140 Error.BadPattern region category actualType
141 (Error.ptypeReplace expectation expectedType)
143 CAnd constraints ->
144 foldM (solve env rank pools) state constraints
146 CLet [] flexs _ headerCon CTrue ->
147 do introduce rank pools flexs
148 solve env rank pools state headerCon
150 CLet [] [] header headerCon subCon ->
151 do state1 <- solve env rank pools state headerCon
152 locals <- traverse (A.traverse (typeToVariable rank pools)) header
153 let newEnv = Map.union env (Map.map A.toValue locals)
154 state2 <- solve newEnv rank pools state1 subCon
155 foldM occurs state2 $ Map.toList locals
157 CLet rigids flexs header headerCon subCon ->
158 do
159 -- work in the next pool to localize header
160 let nextRank = rank + 1
161 let poolsLength = MVector.length pools
162 nextPools <-
163 if nextRank < poolsLength
164 then return pools
165 else MVector.grow pools poolsLength
167 -- introduce variables
168 let vars = rigids ++ flexs
169 forM_ vars $ \var ->
170 UF.modify var $ \(Descriptor content _ mark copy) ->
171 Descriptor content nextRank mark copy
172 MVector.write nextPools nextRank vars
174 -- run solver in next pool
175 locals <- traverse (A.traverse (typeToVariable nextRank nextPools)) header
176 (State savedEnv mark errors) <-
177 solve env nextRank nextPools state headerCon
179 let youngMark = mark
180 let visitMark = nextMark youngMark
181 let finalMark = nextMark visitMark
183 -- pop pool
184 generalize youngMark visitMark nextRank nextPools
185 MVector.write nextPools nextRank []
187 -- check that things went well
188 mapM_ isGeneric rigids
190 let newEnv = Map.union env (Map.map A.toValue locals)
191 let tempState = State savedEnv finalMark errors
192 newState <- solve newEnv rank nextPools tempState subCon
194 foldM occurs newState (Map.toList locals)
197-- Check that a variable has rank == noRank, meaning that it can be generalized.
198isGeneric :: Variable -> IO ()
199isGeneric var =
200 do (Descriptor _ rank _ _) <- UF.get var
201 if rank == noRank
202 then return ()
203 else
204 do tipe <- Type.toErrorType var
205 error $
206 "You ran into a compiler bug. Here are some details for the developers:\n\n"
207 ++ " " ++ show (ET.toDoc L.empty RT.None tipe) ++ " [rank = " ++ show rank ++ "]\n\n"
208 ++
209 "Please create an <http://sscce.org/> and then report it\n\
210 \at <https://github.com/elm/compiler/issues>\n\n"
214-- EXPECTATIONS TO VARIABLE
217expectedToVariable :: Int -> Pools -> Error.Expected Type -> IO Variable
218expectedToVariable rank pools expectation =
219 typeToVariable rank pools $
220 case expectation of
221 Error.NoExpectation tipe ->
222 tipe
224 Error.FromContext _ _ tipe ->
225 tipe
227 Error.FromAnnotation _ _ _ tipe ->
228 tipe
231patternExpectationToVariable :: Int -> Pools -> Error.PExpected Type -> IO Variable
232patternExpectationToVariable rank pools expectation =
233 typeToVariable rank pools $
234 case expectation of
235 Error.PNoExpectation tipe ->
236 tipe
238 Error.PFromContext _ _ tipe ->
239 tipe
243-- ERROR HELPERS
246addError :: State -> Error.Error -> State
247addError (State savedEnv rank errors) err =
248 State savedEnv rank (err:errors)
252-- OCCURS CHECK
255occurs :: State -> (N.Name, A.Located Variable) -> IO State
256occurs state (name, A.At region variable) =
257 do hasOccurred <- Occurs.occurs variable
258 if hasOccurred
259 then
260 do errorType <- Type.toErrorType variable
261 (Descriptor _ rank mark copy) <- UF.get variable
262 UF.set variable (Descriptor Error rank mark copy)
263 return $ addError state (Error.InfiniteType region name errorType)
264 else
265 return state
269-- GENERALIZE
272{-| Every variable has rank less than or equal to the maxRank of the pool.
273This sorts variables into the young and old pools accordingly.
274-}
275generalize :: Mark -> Mark -> Int -> Pools -> IO ()
276generalize youngMark visitMark youngRank pools =
277 do youngVars <- MVector.read pools youngRank
278 rankTable <- poolToRankTable youngMark youngRank youngVars
280 -- get the ranks right for each entry.
281 -- start at low ranks so that we only have to pass
282 -- over the information once.
283 Vector.imapM_
284 (\rank table -> mapM_ (adjustRank youngMark visitMark rank) table)
285 rankTable
287 -- For variables that have rank lowerer than youngRank, register them in
288 -- the appropriate old pool if they are not redundant.
289 Vector.forM_ (Vector.unsafeInit rankTable) $ \vars ->
290 forM_ vars $ \var ->
291 do isRedundant <- UF.redundant var
292 if isRedundant
293 then return ()
294 else
295 do (Descriptor _ rank _ _) <- UF.get var
296 MVector.modify pools (var:) rank
298 -- For variables with rank youngRank
299 -- If rank < youngRank: register in oldPool
300 -- otherwise generalize
301 forM_ (Vector.unsafeLast rankTable) $ \var ->
302 do isRedundant <- UF.redundant var
303 if isRedundant
304 then return ()
305 else
306 do (Descriptor content rank mark copy) <- UF.get var
307 if rank < youngRank
308 then MVector.modify pools (var:) rank
309 else UF.set var $ Descriptor content noRank mark copy
312poolToRankTable :: Mark -> Int -> [Variable] -> IO (Vector.Vector [Variable])
313poolToRankTable youngMark youngRank youngInhabitants =
314 do mutableTable <- MVector.replicate (youngRank + 1) []
316 -- Sort the youngPool variables into buckets by rank.
317 forM_ youngInhabitants $ \var ->
318 do (Descriptor content rank _ copy) <- UF.get var
319 UF.set var (Descriptor content rank youngMark copy)
320 MVector.modify mutableTable (var:) rank
322 Vector.unsafeFreeze mutableTable
326-- ADJUST RANK
328--
329-- Adjust variable ranks such that ranks never increase as you move deeper.
330-- This way the outermost rank is representative of the entire structure.
331--
332adjustRank :: Mark -> Mark -> Int -> Variable -> IO Int
333adjustRank youngMark visitMark groupRank var =
334 do (Descriptor content rank mark copy) <- UF.get var
335 if mark == youngMark then
336 do -- Set the variable as marked first because it may be cyclic.
337 UF.set var $ Descriptor content rank visitMark copy
338 maxRank <- adjustRankContent youngMark visitMark groupRank content
339 UF.set var $ Descriptor content maxRank visitMark copy
340 return maxRank
342 else if mark == visitMark then
343 return rank
345 else
346 do let minRank = min groupRank rank
347 -- TODO how can minRank ever be groupRank?
348 UF.set var $ Descriptor content minRank visitMark copy
349 return minRank
352adjustRankContent :: Mark -> Mark -> Int -> Content -> IO Int
353adjustRankContent youngMark visitMark groupRank content =
354 let
355 go = adjustRank youngMark visitMark groupRank
356 in
357 case content of
358 FlexVar _ ->
359 return groupRank
361 FlexSuper _ _ ->
362 return groupRank
364 RigidVar _ ->
365 return groupRank
367 RigidSuper _ _ ->
368 return groupRank
370 Structure flatType ->
371 case flatType of
372 App1 _ _ args ->
373 foldM (\rank arg -> max rank <$> go arg) outermostRank args
375 Fun1 arg result ->
376 max <$> go arg <*> go result
378 EmptyRecord1 ->
379 -- THEORY: an empty record never needs to get generalized
380 return outermostRank
382 Record1 fields extension ->
383 do extRank <- go extension
384 foldM (\rank field -> max rank <$> go field) extRank fields
386 Unit1 ->
387 -- THEORY: a unit never needs to get generalized
388 return outermostRank
390 Tuple1 a b maybeC ->
391 do ma <- go a
392 mb <- go b
393 case maybeC of
394 Nothing ->
395 return (max ma mb)
397 Just c ->
398 max (max ma mb) <$> go c
400 Alias _ _ args _ ->
401 -- THEORY: anything in the realVar would be outermostRank
402 foldM (\rank (_, argVar) -> max rank <$> go argVar) outermostRank args
404 Error ->
405 return groupRank
409-- REGISTER VARIABLES
412introduce :: Int -> Pools -> [Variable] -> IO ()
413introduce rank pools variables =
414 do MVector.modify pools (variables++) rank
415 forM_ variables $ \var ->
416 UF.modify var $ \(Descriptor content _ mark copy) ->
417 Descriptor content rank mark copy
421-- TYPE TO VARIABLE
424typeToVariable :: Int -> Pools -> Type -> IO Variable
425typeToVariable rank pools tipe =
426 typeToVar rank pools Map.empty tipe
429typeToVar :: Int -> Pools -> Map.Map N.Name Variable -> Type -> IO Variable
430typeToVar rank pools aliasDict tipe =
431 let go = typeToVar rank pools aliasDict in
432 case tipe of
433 VarN v ->
434 return v
436 AppN home name args ->
437 do argVars <- traverse go args
438 register rank pools (Structure (App1 home name argVars))
440 FunN a b ->
441 do aVar <- go a
442 bVar <- go b
443 register rank pools (Structure (Fun1 aVar bVar))
445 AliasN home name args aliasType ->
446 do argVars <- traverse (traverse go) args
447 aliasVar <- typeToVar rank pools (Map.fromList argVars) aliasType
448 register rank pools (Alias home name argVars aliasVar)
450 PlaceHolder name ->
451 return (aliasDict ! name)
453 RecordN fields ext ->
454 do fieldVars <- traverse go fields
455 extVar <- go ext
456 register rank pools (Structure (Record1 fieldVars extVar))
458 EmptyRecordN ->
459 register rank pools emptyRecord1
461 UnitN ->
462 register rank pools unit1
464 TupleN a b c ->
465 do aVar <- go a
466 bVar <- go b
467 cVar <- traverse go c
468 register rank pools (Structure (Tuple1 aVar bVar cVar))
471register :: Int -> Pools -> Content -> IO Variable
472register rank pools content =
473 do var <- UF.fresh (Descriptor content rank noMark Nothing)
474 MVector.modify pools (var:) rank
475 return var
478{-# NOINLINE emptyRecord1 #-}
479emptyRecord1 :: Content
480emptyRecord1 =
481 Structure EmptyRecord1
484{-# NOINLINE unit1 #-}
485unit1 :: Content
486unit1 =
487 Structure Unit1
491-- SOURCE TYPE TO VARIABLE
494srcTypeToVariable :: Int -> Pools -> Map.Map N.Name () -> Can.Type -> IO Variable
495srcTypeToVariable rank pools freeVars srcType =
496 let
497 nameToContent name
498 | N.startsWith "number" name = FlexSuper Number (Just name)
499 | N.startsWith "comparable" name = FlexSuper Comparable (Just name)
500 | N.startsWith "appendable" name = FlexSuper Appendable (Just name)
501 | N.startsWith "compappend" name = FlexSuper CompAppend (Just name)
502 | otherwise = FlexVar (Just name)
504 makeVar name _ =
505 UF.fresh (Descriptor (nameToContent name) rank noMark Nothing)
506 in
507 do flexVars <- Map.traverseWithKey makeVar freeVars
508 MVector.modify pools (Map.elems flexVars ++) rank
509 srcTypeToVar rank pools flexVars srcType
512srcTypeToVar :: Int -> Pools -> Map.Map N.Name Variable -> Can.Type -> IO Variable
513srcTypeToVar rank pools flexVars srcType =
514 let go = srcTypeToVar rank pools flexVars in
515 case srcType of
516 Can.TLambda argument result ->
517 do argVar <- go argument
518 resultVar <- go result
519 register rank pools (Structure (Fun1 argVar resultVar))
521 Can.TVar name ->
522 return (flexVars ! name)
524 Can.TType home name args ->
525 do argVars <- traverse go args
526 register rank pools (Structure (App1 home name argVars))
528 Can.TRecord fields maybeExt ->
529 do fieldVars <- traverse (srcFieldTypeToVar rank pools flexVars) fields
530 extVar <-
531 case maybeExt of
532 Nothing -> register rank pools emptyRecord1
533 Just ext -> return (flexVars ! ext)
534 register rank pools (Structure (Record1 fieldVars extVar))
536 Can.TUnit ->
537 register rank pools unit1
539 Can.TTuple a b c ->
540 do aVar <- go a
541 bVar <- go b
542 cVar <- traverse go c
543 register rank pools (Structure (Tuple1 aVar bVar cVar))
545 Can.TAlias home name args aliasType ->
546 do argVars <- traverse (traverse go) args
547 aliasVar <-
548 case aliasType of
549 Can.Holey tipe ->
550 srcTypeToVar rank pools (Map.fromList argVars) tipe
552 Can.Filled tipe ->
553 go tipe
555 register rank pools (Alias home name argVars aliasVar)
558srcFieldTypeToVar :: Int -> Pools -> Map.Map N.Name Variable -> Can.FieldType -> IO Variable
559srcFieldTypeToVar rank pools flexVars (Can.FieldType _ srcTipe) =
560 srcTypeToVar rank pools flexVars srcTipe
564-- COPY
567makeCopy :: Int -> Pools -> Variable -> IO Variable
568makeCopy rank pools var =
569 do copy <- makeCopyHelp rank pools var
570 restore var
571 return copy
574makeCopyHelp :: Int -> Pools -> Variable -> IO Variable
575makeCopyHelp maxRank pools variable =
576 do (Descriptor content rank _ maybeCopy) <- UF.get variable
578 case maybeCopy of
579 Just copy ->
580 return copy
582 Nothing ->
583 if rank /= noRank then
584 return variable
586 else
587 do let makeDescriptor c = Descriptor c maxRank noMark Nothing
588 copy <- UF.fresh $ makeDescriptor content
589 MVector.modify pools (copy:) maxRank
591 -- Link the original variable to the new variable. This lets us
592 -- avoid making multiple copies of the variable we are instantiating.
593 --
594 -- Need to do this before recursively copying to avoid looping.
595 UF.set variable $
596 Descriptor content rank noMark (Just copy)
598 -- Now we recursively copy the content of the variable.
599 -- We have already marked the variable as copied, so we
600 -- will not repeat this work or crawl this variable again.
601 case content of
602 Structure term ->
603 do newTerm <- traverseFlatType (makeCopyHelp maxRank pools) term
604 UF.set copy $ makeDescriptor (Structure newTerm)
605 return copy
607 FlexVar _ ->
608 return copy
610 FlexSuper _ _ ->
611 return copy
613 RigidVar name ->
614 do UF.set copy $ makeDescriptor $ FlexVar (Just name)
615 return copy
617 RigidSuper super name ->
618 do UF.set copy $ makeDescriptor $ FlexSuper super (Just name)
619 return copy
621 Alias home name args realType ->
622 do newArgs <- mapM (traverse (makeCopyHelp maxRank pools)) args
623 newRealType <- makeCopyHelp maxRank pools realType
624 UF.set copy $ makeDescriptor (Alias home name newArgs newRealType)
625 return copy
627 Error ->
628 return copy
632-- RESTORE
635restore :: Variable -> IO ()
636restore variable =
637 do (Descriptor content _ _ maybeCopy) <- UF.get variable
638 case maybeCopy of
639 Nothing ->
640 return ()
642 Just _ ->
643 do UF.set variable $ Descriptor content noRank noMark Nothing
644 restoreContent content
647restoreContent :: Content -> IO ()
648restoreContent content =
649 case content of
650 FlexVar _ ->
651 return ()
653 FlexSuper _ _ ->
654 return ()
656 RigidVar _ ->
657 return ()
659 RigidSuper _ _ ->
660 return ()
662 Structure term ->
663 case term of
664 App1 _ _ args ->
665 mapM_ restore args
667 Fun1 arg result ->
668 do restore arg
669 restore result
671 EmptyRecord1 ->
672 return ()
674 Record1 fields ext ->
675 do mapM_ restore fields
676 restore ext
678 Unit1 ->
679 return ()
681 Tuple1 a b maybeC ->
682 do restore a
683 restore b
684 case maybeC of
685 Nothing -> return ()
686 Just c -> restore c
688 Alias _ _ args var ->
689 do mapM_ (traverse restore) args
690 restore var
692 Error ->
693 return ()
697-- TRAVERSE FLAT TYPE
700traverseFlatType :: (Variable -> IO Variable) -> FlatType -> IO FlatType
701traverseFlatType f flatType =
702 case flatType of
703 App1 home name args ->
704 liftM (App1 home name) (traverse f args)
706 Fun1 a b ->
707 liftM2 Fun1 (f a) (f b)
709 EmptyRecord1 ->
710 pure EmptyRecord1
712 Record1 fields ext ->
713 liftM2 Record1 (traverse f fields) (f ext)
715 Unit1 ->
716 pure Unit1
718 Tuple1 a b cs ->
719 liftM3 Tuple1 (f a) (f b) (traverse f cs)