git.iko.soy/elk
on 5a9bb97 help sign in
elk/src/Type/State.hs
460 lines 10 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)
30import qualified Data.UnionFind.IO as UF
32import qualified Reporting.Annotation as A
33import qualified Reporting.Error.Type as Error
34import qualified Reporting.Region as R
35import Type.Type
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 Solver $ \state ->
177 let
178 (Pool maxRank inhabitants) =
179 sPool state
180 in
181 return ( variable, state { sPool = Pool maxRank (variable : inhabitants) } )
184{-# INLINE introduce #-}
185introduce :: Variable -> Solver Variable
186introduce variable =
187 Solver $ \state ->
188 let
189 (Pool maxRank inhabitants) =
190 sPool state
191 in
192 do UF.modifyDescriptor variable (\desc -> desc { _rank = maxRank })
193 return ( variable, state { sPool = Pool maxRank (variable : inhabitants) } )
197-- FLATTEN
200flatten :: Type -> Solver Variable
201flatten term =
202 flattenHelp Map.empty term
205flattenHelp :: Map.Map Text Variable -> Type -> Solver Variable
206flattenHelp aliasDict termN =
207 case termN of
208 PlaceHolder name ->
209 return (aliasDict ! name)
211 AliasN name args realType ->
212 do flatArgs <- mapM (traverse (flattenHelp aliasDict)) args
213 flatVar <- flattenHelp (Map.fromList flatArgs) realType
214 pool <- getPool
215 variable <-
216 liftIO . UF.fresh $ Descriptor
217 { _content = Alias name flatArgs flatVar
218 , _rank = _maxRank pool
219 , _mark = noMark
220 , _copy = Nothing
221 }
222 register variable
224 VarN v ->
225 return v
227 TermN term1 ->
228 do variableTerm <- traverseTerm (flattenHelp aliasDict) term1
229 pool <- getPool
230 variable <-
231 liftIO . UF.fresh $ Descriptor
232 { _content = Structure variableTerm
233 , _rank = _maxRank pool
234 , _mark = noMark
235 , _copy = Nothing
236 }
237 register variable
241-- MAKE INSTANCE
244makeInstance :: Variable -> Solver Variable
245makeInstance var =
246 do alreadyCopiedMark <- uniqueMark
247 freshVar <- makeCopy alreadyCopiedMark var
248 _ <- restore alreadyCopiedMark var
249 return freshVar
253-- MAKE COPY
256makeCopy :: Int -> Variable -> Solver Variable
257makeCopy alreadyCopiedMark variable =
258 do desc <- liftIO $ UF.descriptor variable
259 makeCopyHelp desc alreadyCopiedMark variable
262makeCopyHelp :: Descriptor -> Int -> Variable -> Solver Variable
263makeCopyHelp (Descriptor content rank mark copy) alreadyCopiedMark variable =
264 if mark == alreadyCopiedMark then
265 case copy of
266 Just copiedVariable ->
267 return copiedVariable
269 Nothing ->
270 error
271 "Error copying type variable. This should be impossible.\
272 \ Please report this at <https://github.com/elm-lang/elm-compiler/issues>\
273 \ with a <http://sscce.org> and information on your OS, how you installed,\
274 \ and any other configuration information that might be helpful."
276 else if rank /= noRank || not (needsCopy content) then
277 return variable
279 else
280 do pool <- getPool
281 newVar <-
282 liftIO $ UF.fresh $ Descriptor
283 { _content = content -- place holder!
284 , _rank = _maxRank pool
285 , _mark = noMark
286 , _copy = Nothing
287 }
288 _ <- register newVar
290 -- Link the original variable to the new variable. This lets us
291 -- avoid making multiple copies of the variable we are instantiating.
292 --
293 -- Need to do this before recursively copying the content of
294 -- the variable to avoid looping on cyclic terms.
295 liftIO $ UF.modifyDescriptor variable $ \desc ->
296 desc { _mark = alreadyCopiedMark, _copy = Just newVar }
299 let setContent newContent =
300 liftIO $ UF.modifyDescriptor newVar $ \desc ->
301 desc { _content = newContent }
303 -- Now we recursively copy the content of the variable.
304 -- We have already marked the variable as copied, so we
305 -- will not repeat this work or crawl this variable again.
306 case content of
307 Structure term ->
308 do newTerm <- traverseTerm (makeCopy alreadyCopiedMark) term
309 setContent (Structure newTerm)
311 Atom _ ->
312 return ()
314 Var Rigid maybeSuper maybeName ->
315 setContent (Var Flex maybeSuper maybeName)
317 Var Flex _ _ ->
318 return ()
320 Alias name args realType ->
321 setContent =<< (
322 Alias name
323 <$> mapM (traverse (makeCopy alreadyCopiedMark)) args
324 <*> makeCopy alreadyCopiedMark realType
325 )
327 Error ->
328 return ()
330 return newVar
333needsCopy :: Content -> Bool
334needsCopy content =
335 case content of
336 Structure _ ->
337 True
339 Atom _ ->
340 False
342 Var _ _ _ ->
343 True
345 Alias _ _ _ ->
346 True
348 Error ->
349 False
353-- RESTORE
356restore :: Int -> Variable -> Solver Variable
357restore alreadyCopiedMark variable =
358 do desc <- liftIO $ UF.descriptor variable
359 if _mark desc /= alreadyCopiedMark
360 then
361 return variable
363 else
364 do restoredContent <-
365 restoreContent alreadyCopiedMark (_content desc)
366 liftIO $ UF.setDescriptor variable $ Descriptor
367 { _content = restoredContent
368 , _rank = noRank
369 , _mark = noMark
370 , _copy = Nothing
371 }
372 return variable
376restoreContent :: Int -> Content -> Solver Content
377restoreContent alreadyCopiedMark content =
378 let
379 go = restore alreadyCopiedMark
380 in
381 case content of
382 Structure term ->
383 Structure <$> traverseTerm go term
385 Atom _ ->
386 return content
388 Var _ _ _ ->
389 return content
391 Alias name args var ->
392 Alias name
393 <$> mapM (traverse go) args
394 <*> go var
396 Error ->
397 return content
401-- TERM TRAVERSAL
404traverseTerm :: (a -> Solver b) -> Term1 a -> Solver (Term1 b)
405traverseTerm f term =
406 case term of
407 App1 a b ->
408 liftM2 App1 (f a) (f b)
410 Fun1 a b ->
411 liftM2 Fun1 (f a) (f b)
413 EmptyRecord1 ->
414 pure EmptyRecord1
416 Record1 fields ext ->
417 liftM2 Record1 (traverse f fields) (f ext)
421-- INSTANCES
424instance Functor Solver where
425 {-# INLINE fmap #-}
426 fmap f (Solver solver) = Solver $ \s1 ->
427 fmap (\(a, s2) -> (f a, s2)) (solver s1)
430instance Applicative Solver where
431 {-# INLINE pure #-}
432 pure a = Solver $ \s -> return (a, s)
434 {-# INLINE (<*>) #-}
435 Solver solverFunc <*> Solver solverValue =
436 Solver $ \s1 ->
437 do (f, s2) <- solverFunc s1
438 (x, s3) <- solverValue s2
439 return (f x, s3)
442instance Monad Solver where
443 {-# INLINE (>>=) #-}
444 Solver solver >>= k =
445 Solver $ \s1 ->
446 do (a, s2) <- solver s1
447 (b, s3) <- _solve (k a) s2
448 return (b, s3)
450 {-# INLINE fail #-}
451 fail msg =
452 Solver $ \_ -> fail msg
455instance MonadIO Solver where
456 {-# INLINE liftIO #-}
457 liftIO io =
458 Solver $ \state ->
459 do a <- io
460 return (a, state)