git.iko.soy/elk
on 314be83 help sign in
elk/src/Type/State.hs
355 lines 8.6 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Type.State
3 ( Solver
4 , run
5 , SolverState(..)
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
24import qualified Control.Monad.State as State
25import qualified Data.Map as Map
26import Data.Map ((!))
27import Data.Text (Text)
28import qualified Data.UnionFind.IO as UF
30import qualified Reporting.Annotation as A
31import qualified Reporting.Error.Type as Error
32import qualified Reporting.Region as R
33import Type.Type
36-- SOLVER
39type Solver = State.StateT SolverState IO
42run :: Solver () -> IO SolverState
43run solver =
44 State.execStateT solver $
45 SS
46 { sEnv = Map.empty
47 , sSavedEnv = Map.empty
48 , sPool = Pool outermostRank []
49 , sMark = noMark + 1 -- The mark must never be equal to noMark!
50 , sError = []
51 }
55-- SOLVER STATE
58data SolverState =
59 SS
60 { sEnv :: Env
61 , sSavedEnv :: Env
62 , sPool :: Pool
63 , sMark :: Int
64 , sError :: [A.Located Error.Error]
65 }
68{-| A pool holds a bunch of variables
69The rank of each variable is less than or equal to the pool's "maxRank"
70The young pool exists to make it possible to identify these vars in constant time.
71-}
72data Pool =
73 Pool
74 { maxRank :: Int
75 , inhabitants :: [Variable]
76 }
79type Env = Map.Map Text (A.Located Variable)
83-- HELPERS
86modifyEnv :: (Env -> Env) -> Solver ()
87modifyEnv f =
88 State.modify $ \state -> state { sEnv = f (sEnv state) }
91modifyPool :: (Pool -> Pool) -> Solver ()
92modifyPool f =
93 State.modify $ \state -> state { sPool = f (sPool state) }
96addError :: R.Region -> Error.Error -> Solver ()
97addError region err =
98 State.modify $ \state -> state { sError = A.A region err : sError state }
101switchToPool :: Pool -> Solver ()
102switchToPool pool =
103 modifyPool (\_ -> pool)
106getPool :: Solver Pool
107getPool =
108 State.gets sPool
111getEnv :: Solver Env
112getEnv =
113 State.gets sEnv
116saveLocalEnv :: Solver ()
117saveLocalEnv =
118 do currentEnv <- getEnv
119 State.modify $ \state -> state { sSavedEnv = currentEnv }
122uniqueMark :: Solver Int
123uniqueMark =
124 do state <- State.get
125 let mark = sMark state
126 State.put $ state { sMark = mark + 1 }
127 return mark
130nextRankPool :: Solver Pool
131nextRankPool =
132 do pool <- getPool
133 return $ Pool { maxRank = maxRank pool + 1, inhabitants = [] }
136register :: Variable -> Solver Variable
137register variable =
138 do modifyPool $ \pool -> pool { inhabitants = variable : inhabitants pool }
139 return variable
142introduce :: Variable -> Solver Variable
143introduce variable =
144 do pool <- getPool
145 State.liftIO $ UF.modifyDescriptor variable (\desc -> desc { _rank = maxRank pool })
146 register variable
149flatten :: Type -> Solver Variable
150flatten term =
151 flattenHelp Map.empty term
154flattenHelp :: Map.Map Text Variable -> Type -> Solver Variable
155flattenHelp aliasDict termN =
156 case termN of
157 PlaceHolder name ->
158 return (aliasDict ! name)
160 AliasN name args realType ->
161 do flatArgs <- mapM (traverse (flattenHelp aliasDict)) args
162 flatVar <- flattenHelp (Map.fromList flatArgs) realType
163 pool <- getPool
164 variable <-
165 State.liftIO . UF.fresh $ Descriptor
166 { _content = Alias name flatArgs flatVar
167 , _rank = maxRank pool
168 , _mark = noMark
169 , _copy = Nothing
170 }
171 register variable
173 VarN v ->
174 return v
176 TermN term1 ->
177 do variableTerm <- traverseTerm (flattenHelp aliasDict) term1
178 pool <- getPool
179 variable <-
180 State.liftIO . UF.fresh $ Descriptor
181 { _content = Structure variableTerm
182 , _rank = maxRank pool
183 , _mark = noMark
184 , _copy = Nothing
185 }
186 register variable
189makeInstance :: Variable -> Solver Variable
190makeInstance var =
191 do alreadyCopiedMark <- uniqueMark
192 freshVar <- makeCopy alreadyCopiedMark var
193 _ <- restore alreadyCopiedMark var
194 return freshVar
197makeCopy :: Int -> Variable -> Solver Variable
198makeCopy alreadyCopiedMark variable =
199 do desc <- State.liftIO $ UF.descriptor variable
200 makeCopyHelp desc alreadyCopiedMark variable
203makeCopyHelp :: Descriptor -> Int -> Variable -> Solver Variable
204makeCopyHelp (Descriptor content rank mark copy) alreadyCopiedMark variable =
205 if mark == alreadyCopiedMark then
206 case copy of
207 Just copiedVariable ->
208 return copiedVariable
210 Nothing ->
211 error
212 "Error copying type variable. This should be impossible.\
213 \ Please report this at <https://github.com/elm-lang/elm-compiler/issues>\
214 \ with a <http://sscce.org> and information on your OS, how you installed,\
215 \ and any other configuration information that might be helpful."
217 else if rank /= noRank || not (needsCopy content) then
218 return variable
220 else
221 do pool <- getPool
222 newVar <-
223 State.liftIO $ UF.fresh $ Descriptor
224 { _content = content -- place holder!
225 , _rank = maxRank pool
226 , _mark = noMark
227 , _copy = Nothing
228 }
229 _ <- register newVar
231 -- Link the original variable to the new variable. This lets us
232 -- avoid making multiple copies of the variable we are instantiating.
233 --
234 -- Need to do this before recursively copying the content of
235 -- the variable to avoid looping on cyclic terms.
236 State.liftIO $ UF.modifyDescriptor variable $ \desc ->
237 desc { _mark = alreadyCopiedMark, _copy = Just newVar }
240 let setContent newContent =
241 State.liftIO $ UF.modifyDescriptor newVar $ \desc ->
242 desc { _content = newContent }
244 -- Now we recursively copy the content of the variable.
245 -- We have already marked the variable as copied, so we
246 -- will not repeat this work or crawl this variable again.
247 case content of
248 Structure term ->
249 do newTerm <- traverseTerm (makeCopy alreadyCopiedMark) term
250 setContent (Structure newTerm)
252 Atom _ ->
253 return ()
255 Var Rigid maybeSuper maybeName ->
256 setContent (Var Flex maybeSuper maybeName)
258 Var Flex _ _ ->
259 return ()
261 Alias name args realType ->
262 setContent =<< (
263 Alias name
264 <$> mapM (traverse (makeCopy alreadyCopiedMark)) args
265 <*> makeCopy alreadyCopiedMark realType
266 )
268 Error ->
269 return ()
271 return newVar
274needsCopy :: Content -> Bool
275needsCopy content =
276 case content of
277 Structure _ ->
278 True
280 Atom _ ->
281 False
283 Var _ _ _ ->
284 True
286 Alias _ _ _ ->
287 True
289 Error ->
290 False
294restore :: Int -> Variable -> Solver Variable
295restore alreadyCopiedMark variable =
296 do desc <- State.liftIO $ UF.descriptor variable
297 if _mark desc /= alreadyCopiedMark
298 then
299 return variable
301 else
302 do restoredContent <-
303 restoreContent alreadyCopiedMark (_content desc)
304 State.liftIO $ UF.setDescriptor variable $ Descriptor
305 { _content = restoredContent
306 , _rank = noRank
307 , _mark = noMark
308 , _copy = Nothing
309 }
310 return variable
314restoreContent :: Int -> Content -> Solver Content
315restoreContent alreadyCopiedMark content =
316 let
317 go = restore alreadyCopiedMark
318 in
319 case content of
320 Structure term ->
321 Structure <$> traverseTerm go term
323 Atom _ ->
324 return content
326 Var _ _ _ ->
327 return content
329 Alias name args var ->
330 Alias name
331 <$> mapM (traverse go) args
332 <*> go var
334 Error ->
335 return content
339-- TERM TRAVERSAL
342traverseTerm :: (Monad f, Applicative f) => (a -> f b) -> Term1 a -> f (Term1 b)
343traverseTerm f term =
344 case term of
345 App1 a b ->
346 App1 <$> f a <*> f b
348 Fun1 a b ->
349 Fun1 <$> f a <*> f b
351 EmptyRecord1 ->
352 return EmptyRecord1
354 Record1 fields ext ->
355 Record1 <$> traverse f fields <*> f ext