git.iko.soy/elk
on bb35d68 help sign in
elk/src/Type/State.hs
330 lines 8.5 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Type.State where
4import qualified Control.Monad.State as State
5import qualified Data.Map as Map
6import Data.Map ((!))
7import Data.Text (Text)
8import qualified Data.UnionFind.IO as UF
10import qualified Reporting.Annotation as A
11import qualified Reporting.Error.Type as Error
12import qualified Reporting.Region as R
13import Type.Type
16-- Pool
17-- Holds a bunch of variables
18-- The rank of each variable is less than or equal to the pool's "maxRank"
19-- The young pool exists to make it possible to identify these vars in constant time.
21data Pool =
22 Pool
23 { maxRank :: Int
24 , inhabitants :: [Variable]
25 }
28emptyPool :: Pool
29emptyPool =
30 Pool
31 { maxRank = outermostRank
32 , inhabitants = []
33 }
36type Env = Map.Map Text (A.Located Variable)
39type Solver = State.StateT SolverState IO
42-- Keeps track of the environment, type variable pool, and a list of errors
43data SolverState =
44 SS
45 { sEnv :: Env
46 , sSavedEnv :: Env
47 , sPool :: Pool
48 , sMark :: Int
49 , sError :: [A.Located Error.Error]
50 }
53initialState :: SolverState
54initialState =
55 SS
56 { sEnv = Map.empty
57 , sSavedEnv = Map.empty
58 , sPool = emptyPool
59 , sMark = noMark + 1 -- The mark must never be equal to noMark!
60 , sError = []
61 }
64modifyEnv :: (Env -> Env) -> Solver ()
65modifyEnv f =
66 State.modify $ \state -> state { sEnv = f (sEnv state) }
69modifyPool :: (Pool -> Pool) -> Solver ()
70modifyPool f =
71 State.modify $ \state -> state { sPool = f (sPool state) }
74addError :: R.Region -> Error.Error -> Solver ()
75addError region err =
76 State.modify $ \state -> state { sError = A.A region err : sError state }
79switchToPool :: Pool -> Solver ()
80switchToPool pool =
81 modifyPool (\_ -> pool)
84getPool :: Solver Pool
85getPool =
86 State.gets sPool
89getEnv :: Solver Env
90getEnv =
91 State.gets sEnv
94saveLocalEnv :: Solver ()
95saveLocalEnv =
96 do currentEnv <- getEnv
97 State.modify $ \state -> state { sSavedEnv = currentEnv }
100uniqueMark :: Solver Int
101uniqueMark =
102 do state <- State.get
103 let mark = sMark state
104 State.put $ state { sMark = mark + 1 }
105 return mark
108nextRankPool :: Solver Pool
109nextRankPool =
110 do pool <- getPool
111 return $ Pool { maxRank = maxRank pool + 1, inhabitants = [] }
114register :: Variable -> Solver Variable
115register variable =
116 do modifyPool $ \pool -> pool { inhabitants = variable : inhabitants pool }
117 return variable
120introduce :: Variable -> Solver Variable
121introduce variable =
122 do pool <- getPool
123 State.liftIO $ UF.modifyDescriptor variable (\desc -> desc { _rank = maxRank pool })
124 register variable
127flatten :: Type -> Solver Variable
128flatten term =
129 flattenHelp Map.empty term
132flattenHelp :: Map.Map Text Variable -> Type -> Solver Variable
133flattenHelp aliasDict termN =
134 case termN of
135 PlaceHolder name ->
136 return (aliasDict ! name)
138 AliasN name args realType ->
139 do flatArgs <- mapM (traverse (flattenHelp aliasDict)) args
140 flatVar <- flattenHelp (Map.fromList flatArgs) realType
141 pool <- getPool
142 variable <-
143 State.liftIO . UF.fresh $ Descriptor
144 { _content = Alias name flatArgs flatVar
145 , _rank = maxRank pool
146 , _mark = noMark
147 , _copy = Nothing
148 }
149 register variable
151 VarN v ->
152 return v
154 TermN term1 ->
155 do variableTerm <- traverseTerm (flattenHelp aliasDict) term1
156 pool <- getPool
157 variable <-
158 State.liftIO . UF.fresh $ Descriptor
159 { _content = Structure variableTerm
160 , _rank = maxRank pool
161 , _mark = noMark
162 , _copy = Nothing
163 }
164 register variable
167makeInstance :: Variable -> Solver Variable
168makeInstance var =
169 do alreadyCopiedMark <- uniqueMark
170 freshVar <- makeCopy alreadyCopiedMark var
171 _ <- restore alreadyCopiedMark var
172 return freshVar
175makeCopy :: Int -> Variable -> Solver Variable
176makeCopy alreadyCopiedMark variable =
177 do desc <- State.liftIO $ UF.descriptor variable
178 makeCopyHelp desc alreadyCopiedMark variable
181makeCopyHelp :: Descriptor -> Int -> Variable -> Solver Variable
182makeCopyHelp descriptor alreadyCopiedMark variable =
183 if _mark descriptor == alreadyCopiedMark then
184 case _copy descriptor of
185 Just copiedVariable ->
186 return copiedVariable
188 Nothing ->
189 error
190 "Error copying type variable. This should be impossible.\
191 \ Please report this at <https://github.com/elm-lang/elm-compiler/issues>\
192 \ with a <http://sscce.org> and information on your OS, how you installed,\
193 \ and any other configuration information that might be helpful."
195 else if _rank descriptor /= noRank || not (needsCopy (_content descriptor)) then
196 return variable
198 else
199 do pool <- getPool
200 newVar <-
201 State.liftIO $ UF.fresh $ Descriptor
202 { _content = error "will be filled in soon!"
203 , _rank = maxRank pool
204 , _mark = noMark
205 , _copy = Nothing
206 }
207 _ <- register newVar
209 -- Link the original variable to the new variable. This lets us
210 -- avoid making multiple copies of the variable we are instantiating.
211 --
212 -- Need to do this before recursively copying the content of
213 -- the variable to avoid looping on cyclic terms.
214 State.liftIO $ UF.modifyDescriptor variable $ \desc ->
215 desc { _mark = alreadyCopiedMark, _copy = Just newVar }
217 -- Now we recursively copy the content of the variable.
218 -- We have already marked the variable as copied, so we
219 -- will not repeat this work or crawl this variable again.
220 let oldContent = _content descriptor
221 newContent <-
222 case oldContent of
223 Structure term ->
224 Structure <$> traverseTerm (makeCopy alreadyCopiedMark) term
226 Atom _ ->
227 return oldContent
229 Var Rigid maybeSuper maybeName ->
230 return (Var Flex maybeSuper maybeName)
232 Var Flex _ _ ->
233 return oldContent
235 Alias name args realType ->
236 Alias name
237 <$> mapM (traverse (makeCopy alreadyCopiedMark)) args
238 <*> makeCopy alreadyCopiedMark realType
240 Error ->
241 return oldContent
243 State.liftIO $ UF.modifyDescriptor newVar $ \desc ->
244 desc { _content = newContent }
246 return newVar
249needsCopy :: Content -> Bool
250needsCopy content =
251 case content of
252 Structure _ ->
253 True
255 Atom _ ->
256 False
258 Var _ _ _ ->
259 True
261 Alias _ _ _ ->
262 True
264 Error ->
265 False
269restore :: Int -> Variable -> Solver Variable
270restore alreadyCopiedMark variable =
271 do desc <- State.liftIO $ UF.descriptor variable
272 if _mark desc /= alreadyCopiedMark
273 then
274 return variable
276 else
277 do restoredContent <-
278 restoreContent alreadyCopiedMark (_content desc)
279 State.liftIO $ UF.setDescriptor variable $ Descriptor
280 { _content = restoredContent
281 , _rank = noRank
282 , _mark = noMark
283 , _copy = Nothing
284 }
285 return variable
289restoreContent :: Int -> Content -> Solver Content
290restoreContent alreadyCopiedMark content =
291 let
292 go = restore alreadyCopiedMark
293 in
294 case content of
295 Structure term ->
296 Structure <$> traverseTerm go term
298 Atom _ ->
299 return content
301 Var _ _ _ ->
302 return content
304 Alias name args var ->
305 Alias name
306 <$> mapM (traverse go) args
307 <*> go var
309 Error ->
310 return content
314-- TERM TRAVERSAL
317traverseTerm :: (Monad f, Applicative f) => (a -> f b) -> Term1 a -> f (Term1 b)
318traverseTerm f term =
319 case term of
320 App1 a b ->
321 App1 <$> f a <*> f b
323 Fun1 a b ->
324 Fun1 <$> f a <*> f b
326 EmptyRecord1 ->
327 return EmptyRecord1
329 Record1 fields ext ->
330 Record1 <$> traverse f fields <*> f ext