git.iko.soy/elk
on d228087 help sign in
elk/src/Type/Solve.hs
286 lines 9.0 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Type.Solve (solve) where
5import Control.Monad
6import Control.Monad.Except (ExceptT, liftIO, throwError)
7import qualified Data.Foldable as F
8import qualified Data.Map as Map
9import qualified Data.Text as Text
10import qualified Data.Vector as Vector
11import qualified Data.Vector.Mutable as MVector
13import qualified AST.Module.Name as ModuleName
14import qualified Reporting.Annotation as A
15import qualified Reporting.Error.Type as Error
16import qualified Type.Occurs as Occurs
17import qualified Type.State as TS
18import Type.Type as Type
19import Type.Unify
20import qualified Type.UnionFind as UF
24{-| Every variable has rank less than or equal to the maxRank of the pool.
25This sorts variables into the young and old pools accordingly.
26-}
27generalize :: TS.Pool -> TS.Solver ()
28generalize pool@(TS.Pool youngRank _) =
29 {-# SCC elm_compiler_type_generalize #-}
30 do youngMark <- TS.uniqueMark
32 rankTable <- liftIO $ poolToRankTable youngMark pool
34 -- get the ranks right for each entry.
35 -- start at low ranks so that we only have to pass
36 -- over the information once.
37 visitedMark <- TS.uniqueMark
38 let adjust poolRank vars =
39 F.traverse_ (adjustRank youngMark visitedMark poolRank) vars
40 liftIO $ Vector.imapM_ adjust rankTable
42 -- For variables that have rank lowerer than youngRank, register them in
43 -- the old pool if they are not redundant.
44 Vector.forM_ (Vector.unsafeInit rankTable) $ \vars ->
45 forM_ vars $ \var ->
46 do isRedundant <- liftIO $ UF.redundant var
47 if isRedundant then return var else TS.register var
49 -- For variables with rank youngRank
50 -- If rank < youngRank: register in oldPool
51 -- otherwise generalize
52 forM_ (Vector.unsafeLast rankTable) $ \var ->
53 {-# SCC elm_compiler_type_register #-}
54 do isRedundant <- liftIO $ UF.redundant var
55 if isRedundant
56 then return ()
57 else do
58 (Descriptor content rank mark copy) <- liftIO $ UF.descriptor var
59 if rank < youngRank
60 then
61 TS.register var >> return ()
62 else
63 liftIO $ UF.setDescriptor var $ Descriptor (rigidify content) noRank mark copy
66poolToRankTable :: Int -> TS.Pool -> IO (Vector.Vector [Variable])
67poolToRankTable youngMark (TS.Pool youngRank youngInhabitants) =
68 do mutableTable <- MVector.replicate (youngRank + 1) []
70 -- Sort the youngPool variables by rank.
71 forM_ youngInhabitants $ \var ->
72 do (Descriptor content rank _ copy) <- UF.descriptor var
73 UF.setDescriptor var (Descriptor content rank youngMark copy)
74 MVector.modify mutableTable (var:) rank
76 Vector.unsafeFreeze mutableTable
79rigidify :: Content -> Content
80rigidify content =
81 case content of
82 Var Flex maybeSuper maybeName ->
83 Var Rigid maybeSuper maybeName
85 _ ->
86 content
89-- adjust the ranks of variables such that ranks never increase as you
90-- move deeper into a variable.
91adjustRank :: Int -> Int -> Int -> Variable -> IO Int
92adjustRank youngMark visitedMark groupRank var =
93 {-# SCC elm_compiler_type_adjust #-}
94 do descriptor <- UF.descriptor var
95 adjustRankHelp youngMark visitedMark groupRank var descriptor
98adjustRankHelp :: Int -> Int -> Int -> Variable -> Descriptor -> IO Int
99adjustRankHelp youngMark visitedMark groupRank var descriptor@(Descriptor content rank mark _) =
100 if mark == youngMark then
102 do -- Set the variable as marked first because it may be cyclic.
103 UF.modifyDescriptor var $ \desc -> desc { _mark = visitedMark }
104 maxRank <- adjustRankContent youngMark visitedMark groupRank content
105 UF.modifyDescriptor var $ \desc -> desc { _rank = maxRank }
106 return maxRank
108 else if mark /= visitedMark then
110 do let minRank = min groupRank rank
111 UF.setDescriptor var (descriptor { _mark = visitedMark, _rank = minRank })
112 return minRank
114 else
116 return rank
119adjustRankContent :: Int -> Int -> Int -> Content -> IO Int
120adjustRankContent youngMark visitedMark groupRank content =
121 let
122 go = adjustRank youngMark visitedMark groupRank
123 in
124 case content of
125 Error _ ->
126 return groupRank
128 Var _ _ _ ->
129 return groupRank
131 Alias _ args realVar ->
132 -- TODO do you have to crawl the args?
133 do realRank <- go realVar
134 foldM (\rank (_, argVar) -> max rank <$> go argVar) realRank args
136 Structure (App1 _ []) ->
137 return groupRank
139 Structure (App1 _ (first:rest)) ->
140 do firstRank <- go first
141 foldM (\rank arg -> max rank <$> go arg) firstRank rest
143 Structure (Fun1 arg result) ->
144 max <$> go arg <*> go result
146 Structure EmptyRecord1 ->
147 return outermostRank
149 Structure (Record1 fields extension) ->
150 do extRank <- go extension
151 foldM (\rank field -> max rank <$> go field) extRank fields
155-- SOLVER
158solve :: Constraint -> ExceptT [A.Located Error.Error] IO TS.State
159solve constraint =
160 {-# SCC elm_compiler_type_solve #-}
161 do state <- liftIO (TS.run (actuallySolve constraint))
162 case TS.sError state of
163 [] ->
164 return state
165 errors ->
166 throwError errors
169actuallySolve :: Constraint -> TS.Solver ()
170actuallySolve constraint =
171 case constraint of
172 CTrue ->
173 return ()
175 CSaveEnv ->
176 TS.saveLocalEnv
178 CEqual hint region term1 term2 ->
179 do t1 <- TS.flatten term1
180 t2 <- TS.flatten term2
181 unify hint region t1 t2
183 CAnd cs ->
184 mapM_ actuallySolve cs
186 CLet [Scheme [] fqs constraint' _] CTrue ->
187 do oldEnv <- TS.getEnv
188 mapM_ TS.introduce fqs
189 actuallySolve constraint'
190 TS.modifyEnv (\_ -> oldEnv)
192 CLet schemes constraint' ->
193 do oldEnv <- TS.getEnv
194 headers <- Map.unions <$> mapM solveScheme schemes
195 TS.modifyEnv $ \env -> Map.union headers env
196 actuallySolve constraint'
197 mapM_ occurs $ Map.toList headers
198 TS.modifyEnv (\_ -> oldEnv)
200 CInstance region name term ->
201 do env <- TS.getEnv
202 freshCopy <-
203 case Map.lookup name env of
204 Just (A.A _ tipe) ->
205 TS.makeInstance tipe
207 Nothing ->
208 if ModuleName.isKernel name then
209 liftIO (mkVar Nothing)
211 else
212 error ("Could not find `" ++ Text.unpack name ++ "` when solving type constraints.")
214 t <- TS.flatten term
215 unify (Error.Instance name) region freshCopy t
218solveScheme :: Scheme -> TS.Solver TS.Env
219solveScheme scheme =
220 let
221 flatten (A.A region term) =
222 A.A region <$> TS.flatten term
223 in
224 case scheme of
225 Scheme [] [] constraint header ->
226 do actuallySolve constraint
227 traverse flatten header
229 Scheme rigidQuantifiers flexibleQuantifiers constraint header ->
230 do let quantifiers = rigidQuantifiers ++ flexibleQuantifiers
231 oldPool <- TS.getPool
233 -- fill in a new pool when working on this scheme's constraints
234 freshPool <- TS.nextRankPool
235 TS.switchToPool freshPool
236 mapM_ TS.introduce quantifiers
237 header' <- traverse flatten header
238 actuallySolve constraint
240 youngPool <- TS.getPool
241 TS.switchToPool oldPool
242 generalize youngPool
243 mapM_ isGeneric rigidQuantifiers
244 return header'
248-- ADDITIONAL CHECKS
251-- Check that a variable has rank == noRank, meaning that it can be generalized.
252isGeneric :: Variable -> TS.Solver ()
253isGeneric var =
254 do desc <- liftIO $ UF.descriptor var
255 if _rank desc == noRank
256 then return ()
257 else crash "Unable to generalize a type variable. It is not unranked."
260crash :: String -> a
261crash msg =
262 error $
263 "It looks like something went wrong with the type inference algorithm.\n\n"
264 ++ msg ++ "\n\n"
265 ++ "Please create a minimal example that triggers this problem and report it to\n"
266 ++ "<https://github.com/elm-lang/elm-compiler/issues>"
270-- OCCURS CHECK
273occurs :: (Text.Text, A.Located Variable) -> TS.Solver ()
274occurs (name, A.A region variable) =
275 {-# SCC elm_compiler_type_occurs #-}
276 do hasOccurred <- liftIO $ Occurs.occurs variable
277 case hasOccurred of
278 False ->
279 return ()
281 True ->
282 do overallType <- liftIO $ Type.toSrcType variable
283 infiniteDescriptor <- liftIO $ UF.descriptor variable
284 liftIO $ UF.setDescriptor variable (infiniteDescriptor { _content = Error "∞" })
285 TS.addError region (Error.InfiniteType (Right name) overallType)