git.iko.soy/elk
on 4eae013 help sign in
elk/compiler/src/Type/Solve.hs
727 lines 22 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.Name as Name
13import qualified Data.NonEmptyList as NE
14import qualified Data.Vector as Vector
15import qualified Data.Vector.Mutable as MVector
17import qualified AST.Canonical as Can
18import qualified Reporting.Annotation as A
19import qualified Reporting.Error.Type as Error
20import qualified Reporting.Render.Type as RT
21import qualified Reporting.Render.Type.Localizer as L
22import qualified Type.Occurs as Occurs
23import Type.Type as Type
24import qualified Type.Error as ET
25import qualified Type.Unify as Unify
26import qualified Type.UnionFind as UF
30-- RUN SOLVER
33run :: Constraint -> IO (Either (NE.List Error.Error) (Map.Map Name.Name Can.Annotation))
34run constraint =
35 do pools <- MVector.replicate 8 []
37 (State env _ errors) <-
38 solve Map.empty outermostRank pools emptyState constraint
40 case errors of
41 [] ->
42 Right <$> traverse Type.toAnnotation env
44 e:es ->
45 return $ Left (NE.List e es)
49{-# NOINLINE emptyState #-}
50emptyState :: State
51emptyState =
52 State Map.empty (nextMark noMark) []
56-- SOLVER
59type Env =
60 Map.Map Name.Name Variable
63type Pools =
64 MVector.IOVector [Variable]
67data State =
68 State
69 { _env :: Env
70 , _mark :: Mark
71 , _errors :: [Error.Error]
72 }
75solve :: Env -> Int -> Pools -> State -> Constraint -> IO State
76solve env rank pools state constraint =
77 case constraint of
78 CTrue ->
79 return state
81 CSaveTheEnvironment ->
82 return (state { _env = env })
84 CEqual region category tipe expectation ->
85 do actual <- typeToVariable rank pools tipe
86 expected <- expectedToVariable rank pools expectation
87 answer <- Unify.unify actual expected
88 case answer of
89 Unify.Ok vars ->
90 do introduce rank pools vars
91 return state
93 Unify.Err vars actualType expectedType ->
94 do introduce rank pools vars
95 return $ addError state $
96 Error.BadExpr region category actualType $
97 Error.typeReplace expectation expectedType
99 CLocal region name expectation ->
100 do actual <- makeCopy rank pools (env ! name)
101 expected <- expectedToVariable rank pools expectation
102 answer <- Unify.unify actual expected
103 case answer of
104 Unify.Ok vars ->
105 do introduce rank pools vars
106 return state
108 Unify.Err vars actualType expectedType ->
109 do introduce rank pools vars
110 return $ addError state $
111 Error.BadExpr region (Error.Local name) actualType $
112 Error.typeReplace expectation expectedType
114 CForeign region name (Can.Forall freeVars srcType) expectation ->
115 do actual <- srcTypeToVariable rank pools freeVars srcType
116 expected <- expectedToVariable rank pools expectation
117 answer <- Unify.unify actual expected
118 case answer of
119 Unify.Ok vars ->
120 do introduce rank pools vars
121 return state
123 Unify.Err vars actualType expectedType ->
124 do introduce rank pools vars
125 return $ addError state $
126 Error.BadExpr region (Error.Foreign name) actualType $
127 Error.typeReplace expectation expectedType
129 CPattern region category tipe expectation ->
130 do actual <- typeToVariable rank pools tipe
131 expected <- patternExpectationToVariable rank pools expectation
132 answer <- Unify.unify actual expected
133 case answer of
134 Unify.Ok vars ->
135 do introduce rank pools vars
136 return state
138 Unify.Err vars actualType expectedType ->
139 do introduce rank pools vars
140 return $ addError state $
141 Error.BadPattern region category actualType
142 (Error.ptypeReplace expectation expectedType)
144 CAnd constraints ->
145 foldM (solve env rank pools) state constraints
147 CLet [] flexs _ headerCon CTrue ->
148 do introduce rank pools flexs
149 solve env rank pools state headerCon
151 CLet [] [] header headerCon subCon ->
152 do state1 <- solve env rank pools state headerCon
153 locals <- traverse (A.traverse (typeToVariable rank pools)) header
154 let newEnv = Map.union env (Map.map A.toValue locals)
155 state2 <- solve newEnv rank pools state1 subCon
156 foldM occurs state2 $ Map.toList locals
158 CLet rigids flexs header headerCon subCon ->
159 do
160 -- work in the next pool to localize header
161 let nextRank = rank + 1
162 let poolsLength = MVector.length pools
163 nextPools <-
164 if nextRank < poolsLength
165 then return pools
166 else MVector.grow pools poolsLength
168 -- introduce variables
169 let vars = rigids ++ flexs
170 forM_ vars $ \var ->
171 UF.modify var $ \(Descriptor content _ mark copy) ->
172 Descriptor content nextRank mark copy
173 MVector.write nextPools nextRank vars
175 -- run solver in next pool
176 locals <- traverse (A.traverse (typeToVariable nextRank nextPools)) header
177 (State savedEnv mark errors) <-
178 solve env nextRank nextPools state headerCon
180 let youngMark = mark
181 let visitMark = nextMark youngMark
182 let finalMark = nextMark visitMark
184 -- pop pool
185 generalize youngMark visitMark nextRank nextPools
186 MVector.write nextPools nextRank []
188 -- check that things went well
189 mapM_ isGeneric rigids
191 let newEnv = Map.union env (Map.map A.toValue locals)
192 let tempState = State savedEnv finalMark errors
193 newState <- solve newEnv rank nextPools tempState subCon
195 foldM occurs newState (Map.toList locals)
198-- Check that a variable has rank == noRank, meaning that it can be generalized.
199isGeneric :: Variable -> IO ()
200isGeneric var =
201 do (Descriptor _ rank _ _) <- UF.get var
202 if rank == noRank
203 then return ()
204 else
205 do tipe <- Type.toErrorType var
206 error $
207 "You ran into a compiler bug. Here are some details for the developers:\n\n"
208 ++ " " ++ show (ET.toDoc L.empty RT.None tipe) ++ " [rank = " ++ show rank ++ "]\n\n"
209 ++
210 "Please create an <http://sscce.org/> and then report it\n\
211 \at <https://github.com/elm/compiler/issues>\n\n"
215-- EXPECTATIONS TO VARIABLE
218expectedToVariable :: Int -> Pools -> Error.Expected Type -> IO Variable
219expectedToVariable rank pools expectation =
220 typeToVariable rank pools $
221 case expectation of
222 Error.NoExpectation tipe ->
223 tipe
225 Error.FromContext _ _ tipe ->
226 tipe
228 Error.FromAnnotation _ _ _ tipe ->
229 tipe
232patternExpectationToVariable :: Int -> Pools -> Error.PExpected Type -> IO Variable
233patternExpectationToVariable rank pools expectation =
234 typeToVariable rank pools $
235 case expectation of
236 Error.PNoExpectation tipe ->
237 tipe
239 Error.PFromContext _ _ tipe ->
240 tipe
244-- ERROR HELPERS
247addError :: State -> Error.Error -> State
248addError (State savedEnv rank errors) err =
249 State savedEnv rank (err:errors)
253-- OCCURS CHECK
256occurs :: State -> (Name.Name, A.Located Variable) -> IO State
257occurs state (name, A.At region variable) =
258 do hasOccurred <- Occurs.occurs variable
259 if hasOccurred
260 then
261 do errorType <- Type.toErrorType variable
262 (Descriptor _ rank mark copy) <- UF.get variable
263 UF.set variable (Descriptor Error rank mark copy)
264 return $ addError state (Error.InfiniteType region name errorType)
265 else
266 return state
270-- GENERALIZE
273{-| Every variable has rank less than or equal to the maxRank of the pool.
274This sorts variables into the young and old pools accordingly.
275-}
276generalize :: Mark -> Mark -> Int -> Pools -> IO ()
277generalize youngMark visitMark youngRank pools =
278 do youngVars <- MVector.read pools youngRank
279 rankTable <- poolToRankTable youngMark youngRank youngVars
281 -- get the ranks right for each entry.
282 -- start at low ranks so that we only have to pass
283 -- over the information once.
284 Vector.imapM_
285 (\rank table -> mapM_ (adjustRank youngMark visitMark rank) table)
286 rankTable
288 -- For variables that have rank lowerer than youngRank, register them in
289 -- the appropriate old pool if they are not redundant.
290 Vector.forM_ (Vector.unsafeInit rankTable) $ \vars ->
291 forM_ vars $ \var ->
292 do isRedundant <- UF.redundant var
293 if isRedundant
294 then return ()
295 else
296 do (Descriptor _ rank _ _) <- UF.get var
297 MVector.modify pools (var:) rank
299 -- For variables with rank youngRank
300 -- If rank < youngRank: register in oldPool
301 -- otherwise generalize
302 forM_ (Vector.unsafeLast rankTable) $ \var ->
303 do isRedundant <- UF.redundant var
304 if isRedundant
305 then return ()
306 else
307 do (Descriptor content rank mark copy) <- UF.get var
308 if rank < youngRank
309 then MVector.modify pools (var:) rank
310 else UF.set var $ Descriptor content noRank mark copy
313poolToRankTable :: Mark -> Int -> [Variable] -> IO (Vector.Vector [Variable])
314poolToRankTable youngMark youngRank youngInhabitants =
315 do mutableTable <- MVector.replicate (youngRank + 1) []
317 -- Sort the youngPool variables into buckets by rank.
318 forM_ youngInhabitants $ \var ->
319 do (Descriptor content rank _ copy) <- UF.get var
320 UF.set var (Descriptor content rank youngMark copy)
321 MVector.modify mutableTable (var:) rank
323 Vector.unsafeFreeze mutableTable
327-- ADJUST RANK
329--
330-- Adjust variable ranks such that ranks never increase as you move deeper.
331-- This way the outermost rank is representative of the entire structure.
332--
333adjustRank :: Mark -> Mark -> Int -> Variable -> IO Int
334adjustRank youngMark visitMark groupRank var =
335 do (Descriptor content rank mark copy) <- UF.get var
336 if mark == youngMark then
337 do -- Set the variable as marked first because it may be cyclic.
338 UF.set var $ Descriptor content rank visitMark copy
339 maxRank <- adjustRankContent youngMark visitMark groupRank content
340 UF.set var $ Descriptor content maxRank visitMark copy
341 return maxRank
343 else if mark == visitMark then
344 return rank
346 else
347 do let minRank = min groupRank rank
348 -- TODO how can minRank ever be groupRank?
349 UF.set var $ Descriptor content minRank visitMark copy
350 return minRank
353adjustRankContent :: Mark -> Mark -> Int -> Content -> IO Int
354adjustRankContent youngMark visitMark groupRank content =
355 let
356 go = adjustRank youngMark visitMark groupRank
357 in
358 case content of
359 FlexVar _ ->
360 return groupRank
362 FlexSuper _ _ ->
363 return groupRank
365 RigidVar _ ->
366 return groupRank
368 RigidSuper _ _ ->
369 return groupRank
371 Structure flatType ->
372 case flatType of
373 App1 _ _ args ->
374 foldM (\rank arg -> max rank <$> go arg) outermostRank args
376 Fun1 arg result ->
377 max <$> go arg <*> go result
379 EmptyRecord1 ->
380 -- THEORY: an empty record never needs to get generalized
381 return outermostRank
383 Record1 fields extension ->
384 do extRank <- go extension
385 foldM (\rank field -> max rank <$> go field) extRank fields
387 Unit1 ->
388 -- THEORY: a unit never needs to get generalized
389 return outermostRank
391 Tuple1 a b maybeC ->
392 do ma <- go a
393 mb <- go b
394 case maybeC of
395 Nothing ->
396 return (max ma mb)
398 Just c ->
399 max (max ma mb) <$> go c
401 Alias _ _ args _ ->
402 -- THEORY: anything in the realVar would be outermostRank
403 foldM (\rank (_, argVar) -> max rank <$> go argVar) outermostRank args
405 Error ->
406 return groupRank
410-- REGISTER VARIABLES
413introduce :: Int -> Pools -> [Variable] -> IO ()
414introduce rank pools variables =
415 do MVector.modify pools (variables++) rank
416 forM_ variables $ \var ->
417 UF.modify var $ \(Descriptor content _ mark copy) ->
418 Descriptor content rank mark copy
422-- TYPE TO VARIABLE
425typeToVariable :: Int -> Pools -> Type -> IO Variable
426typeToVariable rank pools tipe =
427 typeToVar rank pools Map.empty tipe
430-- PERF working with @mgriffith we noticed that a 784 line entry in a `let` was
431-- causing a ~1.5 second slowdown. Moving it to the top-level to be a function
432-- saved all that time. The slowdown seems to manifest in `typeToVar` and in
433-- `register` in particular. Have not explored further yet. Top-level definitions
434-- are recommended in cases like this anyway, so there is at least a safety
435-- valve for now.
436--
437typeToVar :: Int -> Pools -> Map.Map Name.Name Variable -> Type -> IO Variable
438typeToVar rank pools aliasDict tipe =
439 let go = typeToVar rank pools aliasDict in
440 case tipe of
441 VarN v ->
442 return v
444 AppN home name args ->
445 do argVars <- traverse go args
446 register rank pools (Structure (App1 home name argVars))
448 FunN a b ->
449 do aVar <- go a
450 bVar <- go b
451 register rank pools (Structure (Fun1 aVar bVar))
453 AliasN home name args aliasType ->
454 do argVars <- traverse (traverse go) args
455 aliasVar <- typeToVar rank pools (Map.fromList argVars) aliasType
456 register rank pools (Alias home name argVars aliasVar)
458 PlaceHolder name ->
459 return (aliasDict ! name)
461 RecordN fields ext ->
462 do fieldVars <- traverse go fields
463 extVar <- go ext
464 register rank pools (Structure (Record1 fieldVars extVar))
466 EmptyRecordN ->
467 register rank pools emptyRecord1
469 UnitN ->
470 register rank pools unit1
472 TupleN a b c ->
473 do aVar <- go a
474 bVar <- go b
475 cVar <- traverse go c
476 register rank pools (Structure (Tuple1 aVar bVar cVar))
479register :: Int -> Pools -> Content -> IO Variable
480register rank pools content =
481 do var <- UF.fresh (Descriptor content rank noMark Nothing)
482 MVector.modify pools (var:) rank
483 return var
486{-# NOINLINE emptyRecord1 #-}
487emptyRecord1 :: Content
488emptyRecord1 =
489 Structure EmptyRecord1
492{-# NOINLINE unit1 #-}
493unit1 :: Content
494unit1 =
495 Structure Unit1
499-- SOURCE TYPE TO VARIABLE
502srcTypeToVariable :: Int -> Pools -> Map.Map Name.Name () -> Can.Type -> IO Variable
503srcTypeToVariable rank pools freeVars srcType =
504 let
505 nameToContent name
506 | Name.isNumberType name = FlexSuper Number (Just name)
507 | Name.isComparableType name = FlexSuper Comparable (Just name)
508 | Name.isAppendableType name = FlexSuper Appendable (Just name)
509 | Name.isCompappendType name = FlexSuper CompAppend (Just name)
510 | otherwise = FlexVar (Just name)
512 makeVar name _ =
513 UF.fresh (Descriptor (nameToContent name) rank noMark Nothing)
514 in
515 do flexVars <- Map.traverseWithKey makeVar freeVars
516 MVector.modify pools (Map.elems flexVars ++) rank
517 srcTypeToVar rank pools flexVars srcType
520srcTypeToVar :: Int -> Pools -> Map.Map Name.Name Variable -> Can.Type -> IO Variable
521srcTypeToVar rank pools flexVars srcType =
522 let go = srcTypeToVar rank pools flexVars in
523 case srcType of
524 Can.TLambda argument result ->
525 do argVar <- go argument
526 resultVar <- go result
527 register rank pools (Structure (Fun1 argVar resultVar))
529 Can.TVar name ->
530 return (flexVars ! name)
532 Can.TType home name args ->
533 do argVars <- traverse go args
534 register rank pools (Structure (App1 home name argVars))
536 Can.TRecord fields maybeExt ->
537 do fieldVars <- traverse (srcFieldTypeToVar rank pools flexVars) fields
538 extVar <-
539 case maybeExt of
540 Nothing -> register rank pools emptyRecord1
541 Just ext -> return (flexVars ! ext)
542 register rank pools (Structure (Record1 fieldVars extVar))
544 Can.TUnit ->
545 register rank pools unit1
547 Can.TTuple a b c ->
548 do aVar <- go a
549 bVar <- go b
550 cVar <- traverse go c
551 register rank pools (Structure (Tuple1 aVar bVar cVar))
553 Can.TAlias home name args aliasType ->
554 do argVars <- traverse (traverse go) args
555 aliasVar <-
556 case aliasType of
557 Can.Holey tipe ->
558 srcTypeToVar rank pools (Map.fromList argVars) tipe
560 Can.Filled tipe ->
561 go tipe
563 register rank pools (Alias home name argVars aliasVar)
566srcFieldTypeToVar :: Int -> Pools -> Map.Map Name.Name Variable -> Can.FieldType -> IO Variable
567srcFieldTypeToVar rank pools flexVars (Can.FieldType _ srcTipe) =
568 srcTypeToVar rank pools flexVars srcTipe
572-- COPY
575makeCopy :: Int -> Pools -> Variable -> IO Variable
576makeCopy rank pools var =
577 do copy <- makeCopyHelp rank pools var
578 restore var
579 return copy
582makeCopyHelp :: Int -> Pools -> Variable -> IO Variable
583makeCopyHelp maxRank pools variable =
584 do (Descriptor content rank _ maybeCopy) <- UF.get variable
586 case maybeCopy of
587 Just copy ->
588 return copy
590 Nothing ->
591 if rank /= noRank then
592 return variable
594 else
595 do let makeDescriptor c = Descriptor c maxRank noMark Nothing
596 copy <- UF.fresh $ makeDescriptor content
597 MVector.modify pools (copy:) maxRank
599 -- Link the original variable to the new variable. This lets us
600 -- avoid making multiple copies of the variable we are instantiating.
601 --
602 -- Need to do this before recursively copying to avoid looping.
603 UF.set variable $
604 Descriptor content rank noMark (Just copy)
606 -- Now we recursively copy the content of the variable.
607 -- We have already marked the variable as copied, so we
608 -- will not repeat this work or crawl this variable again.
609 case content of
610 Structure term ->
611 do newTerm <- traverseFlatType (makeCopyHelp maxRank pools) term
612 UF.set copy $ makeDescriptor (Structure newTerm)
613 return copy
615 FlexVar _ ->
616 return copy
618 FlexSuper _ _ ->
619 return copy
621 RigidVar name ->
622 do UF.set copy $ makeDescriptor $ FlexVar (Just name)
623 return copy
625 RigidSuper super name ->
626 do UF.set copy $ makeDescriptor $ FlexSuper super (Just name)
627 return copy
629 Alias home name args realType ->
630 do newArgs <- mapM (traverse (makeCopyHelp maxRank pools)) args
631 newRealType <- makeCopyHelp maxRank pools realType
632 UF.set copy $ makeDescriptor (Alias home name newArgs newRealType)
633 return copy
635 Error ->
636 return copy
640-- RESTORE
643restore :: Variable -> IO ()
644restore variable =
645 do (Descriptor content _ _ maybeCopy) <- UF.get variable
646 case maybeCopy of
647 Nothing ->
648 return ()
650 Just _ ->
651 do UF.set variable $ Descriptor content noRank noMark Nothing
652 restoreContent content
655restoreContent :: Content -> IO ()
656restoreContent content =
657 case content of
658 FlexVar _ ->
659 return ()
661 FlexSuper _ _ ->
662 return ()
664 RigidVar _ ->
665 return ()
667 RigidSuper _ _ ->
668 return ()
670 Structure term ->
671 case term of
672 App1 _ _ args ->
673 mapM_ restore args
675 Fun1 arg result ->
676 do restore arg
677 restore result
679 EmptyRecord1 ->
680 return ()
682 Record1 fields ext ->
683 do mapM_ restore fields
684 restore ext
686 Unit1 ->
687 return ()
689 Tuple1 a b maybeC ->
690 do restore a
691 restore b
692 case maybeC of
693 Nothing -> return ()
694 Just c -> restore c
696 Alias _ _ args var ->
697 do mapM_ (traverse restore) args
698 restore var
700 Error ->
701 return ()
705-- TRAVERSE FLAT TYPE
708traverseFlatType :: (Variable -> IO Variable) -> FlatType -> IO FlatType
709traverseFlatType f flatType =
710 case flatType of
711 App1 home name args ->
712 liftM (App1 home name) (traverse f args)
714 Fun1 a b ->
715 liftM2 Fun1 (f a) (f b)
717 EmptyRecord1 ->
718 pure EmptyRecord1
720 Record1 fields ext ->
721 liftM2 Record1 (traverse f fields) (f ext)
723 Unit1 ->
724 pure Unit1
726 Tuple1 a b cs ->
727 liftM3 Tuple1 (f a) (f b) (traverse f cs)