git.iko.soy/elk
on 5a33259 help sign in
elk/src/Type/State.hs
352 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 alreadyCopiedMark variable =
205 if _mark descriptor == alreadyCopiedMark then
206 case _copy descriptor 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 descriptor /= noRank || not (needsCopy (_content descriptor)) then
218 return variable
220 else
221 do pool <- getPool
222 newVar <-
223 State.liftIO $ UF.fresh $ Descriptor
224 { _content = error "will be filled in soon!"
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 }
239 -- Now we recursively copy the content of the variable.
240 -- We have already marked the variable as copied, so we
241 -- will not repeat this work or crawl this variable again.
242 let oldContent = _content descriptor
243 newContent <-
244 case oldContent of
245 Structure term ->
246 Structure <$> traverseTerm (makeCopy alreadyCopiedMark) term
248 Atom _ ->
249 return oldContent
251 Var Rigid maybeSuper maybeName ->
252 return (Var Flex maybeSuper maybeName)
254 Var Flex _ _ ->
255 return oldContent
257 Alias name args realType ->
258 Alias name
259 <$> mapM (traverse (makeCopy alreadyCopiedMark)) args
260 <*> makeCopy alreadyCopiedMark realType
262 Error ->
263 return oldContent
265 State.liftIO $ UF.modifyDescriptor newVar $ \desc ->
266 desc { _content = newContent }
268 return newVar
271needsCopy :: Content -> Bool
272needsCopy content =
273 case content of
274 Structure _ ->
275 True
277 Atom _ ->
278 False
280 Var _ _ _ ->
281 True
283 Alias _ _ _ ->
284 True
286 Error ->
287 False
291restore :: Int -> Variable -> Solver Variable
292restore alreadyCopiedMark variable =
293 do desc <- State.liftIO $ UF.descriptor variable
294 if _mark desc /= alreadyCopiedMark
295 then
296 return variable
298 else
299 do restoredContent <-
300 restoreContent alreadyCopiedMark (_content desc)
301 State.liftIO $ UF.setDescriptor variable $ Descriptor
302 { _content = restoredContent
303 , _rank = noRank
304 , _mark = noMark
305 , _copy = Nothing
306 }
307 return variable
311restoreContent :: Int -> Content -> Solver Content
312restoreContent alreadyCopiedMark content =
313 let
314 go = restore alreadyCopiedMark
315 in
316 case content of
317 Structure term ->
318 Structure <$> traverseTerm go term
320 Atom _ ->
321 return content
323 Var _ _ _ ->
324 return content
326 Alias name args var ->
327 Alias name
328 <$> mapM (traverse go) args
329 <*> go var
331 Error ->
332 return content
336-- TERM TRAVERSAL
339traverseTerm :: (Monad f, Applicative f) => (a -> f b) -> Term1 a -> f (Term1 b)
340traverseTerm f term =
341 case term of
342 App1 a b ->
343 App1 <$> f a <*> f b
345 Fun1 a b ->
346 Fun1 <$> f a <*> f b
348 EmptyRecord1 ->
349 return EmptyRecord1
351 Record1 fields ext ->
352 Record1 <$> traverse f fields <*> f ext