git.iko.soy/elk
on bbb6583 help sign in
elk/src/Type/State.hs
327 lines 8.4 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Type.State where
4import qualified Control.Monad.State as State
5import Data.Map ((!))
6import qualified Data.Map as Map
7import qualified Data.UnionFind.IO as UF
9import qualified Reporting.Annotation as A
10import qualified Reporting.Error.Type as Error
11import qualified Reporting.Region as R
12import Type.Type
15-- Pool
16-- Holds a bunch of variables
17-- The rank of each variable is less than or equal to the pool's "maxRank"
18-- The young pool exists to make it possible to identify these vars in constant time.
20data Pool = Pool
21 { maxRank :: Int
22 , inhabitants :: [Variable]
23 }
26emptyPool :: Pool
27emptyPool =
28 Pool
29 { maxRank = outermostRank
30 , inhabitants = []
31 }
34type Env = Map.Map String (A.Located Variable)
37type Solver = State.StateT SolverState IO
40-- Keeps track of the environment, type variable pool, and a list of errors
41data SolverState = SS
42 { sEnv :: Env
43 , sSavedEnv :: Env
44 , sPool :: Pool
45 , sMark :: Int
46 , sError :: [A.Located Error.Error]
47 }
50initialState :: SolverState
51initialState =
52 SS
53 { sEnv = Map.empty
54 , sSavedEnv = Map.empty
55 , sPool = emptyPool
56 , sMark = noMark + 1 -- The mark must never be equal to noMark!
57 , sError = []
58 }
61modifyEnv :: (Env -> Env) -> Solver ()
62modifyEnv f =
63 State.modify $ \state -> state { sEnv = f (sEnv state) }
66modifyPool :: (Pool -> Pool) -> Solver ()
67modifyPool f =
68 State.modify $ \state -> state { sPool = f (sPool state) }
71addError :: R.Region -> Error.Error -> Solver ()
72addError region err =
73 State.modify $ \state -> state { sError = A.A region err : sError state }
76switchToPool :: Pool -> Solver ()
77switchToPool pool =
78 modifyPool (\_ -> pool)
81getPool :: Solver Pool
82getPool =
83 State.gets sPool
86getEnv :: Solver Env
87getEnv =
88 State.gets sEnv
91saveLocalEnv :: Solver ()
92saveLocalEnv =
93 do currentEnv <- getEnv
94 State.modify $ \state -> state { sSavedEnv = currentEnv }
97uniqueMark :: Solver Int
98uniqueMark =
99 do state <- State.get
100 let mark = sMark state
101 State.put $ state { sMark = mark + 1 }
102 return mark
105nextRankPool :: Solver Pool
106nextRankPool =
107 do pool <- getPool
108 return $ Pool { maxRank = maxRank pool + 1, inhabitants = [] }
111register :: Variable -> Solver Variable
112register variable =
113 do modifyPool $ \pool -> pool { inhabitants = variable : inhabitants pool }
114 return variable
117introduce :: Variable -> Solver Variable
118introduce variable =
119 do pool <- getPool
120 State.liftIO $ UF.modifyDescriptor variable (\desc -> desc { _rank = maxRank pool })
121 register variable
124flatten :: Type -> Solver Variable
125flatten term =
126 flattenHelp Map.empty term
129flattenHelp :: Map.Map String Variable -> Type -> Solver Variable
130flattenHelp aliasDict termN =
131 case termN of
132 PlaceHolder name ->
133 return (aliasDict ! name)
135 AliasN name args realType ->
136 do flatArgs <- mapM (traverse (flattenHelp aliasDict)) args
137 flatVar <- flattenHelp (Map.fromList flatArgs) realType
138 pool <- getPool
139 variable <-
140 State.liftIO . UF.fresh $ Descriptor
141 { _content = Alias name flatArgs flatVar
142 , _rank = maxRank pool
143 , _mark = noMark
144 , _copy = Nothing
145 }
146 register variable
148 VarN v ->
149 return v
151 TermN term1 ->
152 do variableTerm <- traverseTerm (flattenHelp aliasDict) term1
153 pool <- getPool
154 variable <-
155 State.liftIO . UF.fresh $ Descriptor
156 { _content = Structure variableTerm
157 , _rank = maxRank pool
158 , _mark = noMark
159 , _copy = Nothing
160 }
161 register variable
164makeInstance :: Variable -> Solver Variable
165makeInstance var =
166 do alreadyCopiedMark <- uniqueMark
167 freshVar <- makeCopy alreadyCopiedMark var
168 _ <- restore alreadyCopiedMark var
169 return freshVar
172makeCopy :: Int -> Variable -> Solver Variable
173makeCopy alreadyCopiedMark variable =
174 do desc <- State.liftIO $ UF.descriptor variable
175 makeCopyHelp desc alreadyCopiedMark variable
178makeCopyHelp :: Descriptor -> Int -> Variable -> Solver Variable
179makeCopyHelp descriptor alreadyCopiedMark variable =
180 if _mark descriptor == alreadyCopiedMark then
181 case _copy descriptor of
182 Just copiedVariable ->
183 return copiedVariable
185 Nothing ->
186 error
187 "Error copying type variable. This should be impossible.\
188 \ Please report this at <https://github.com/elm-lang/elm-compiler/issues>\
189 \ with a <http://sscce.org> and information on your OS, how you installed,\
190 \ and any other configuration information that might be helpful."
192 else if _rank descriptor /= noRank || not (needsCopy (_content descriptor)) then
193 return variable
195 else
196 do pool <- getPool
197 newVar <-
198 State.liftIO $ UF.fresh $ Descriptor
199 { _content = error "will be filled in soon!"
200 , _rank = maxRank pool
201 , _mark = noMark
202 , _copy = Nothing
203 }
204 _ <- register newVar
206 -- Link the original variable to the new variable. This lets us
207 -- avoid making multiple copies of the variable we are instantiating.
208 --
209 -- Need to do this before recursively copying the content of
210 -- the variable to avoid looping on cyclic terms.
211 State.liftIO $ UF.modifyDescriptor variable $ \desc ->
212 desc { _mark = alreadyCopiedMark, _copy = Just newVar }
214 -- Now we recursively copy the content of the variable.
215 -- We have already marked the variable as copied, so we
216 -- will not repeat this work or crawl this variable again.
217 let oldContent = _content descriptor
218 newContent <-
219 case oldContent of
220 Structure term ->
221 Structure <$> traverseTerm (makeCopy alreadyCopiedMark) term
223 Atom _ ->
224 return oldContent
226 Var Rigid maybeSuper _ ->
227 return (Var Flex maybeSuper Nothing)
229 Var Flex _ _ ->
230 return oldContent
232 Alias name args realType ->
233 Alias name
234 <$> mapM (traverse (makeCopy alreadyCopiedMark)) args
235 <*> makeCopy alreadyCopiedMark realType
237 Error ->
238 return oldContent
240 State.liftIO $ UF.modifyDescriptor newVar $ \desc ->
241 desc { _content = newContent }
243 return newVar
246needsCopy :: Content -> Bool
247needsCopy content =
248 case content of
249 Structure _ ->
250 True
252 Atom _ ->
253 False
255 Var _ _ _ ->
256 True
258 Alias _ _ _ ->
259 True
261 Error ->
262 False
266restore :: Int -> Variable -> Solver Variable
267restore alreadyCopiedMark variable =
268 do desc <- State.liftIO $ UF.descriptor variable
269 if _mark desc /= alreadyCopiedMark
270 then
271 return variable
273 else
274 do restoredContent <-
275 restoreContent alreadyCopiedMark (_content desc)
276 State.liftIO $ UF.setDescriptor variable $ Descriptor
277 { _content = restoredContent
278 , _rank = noRank
279 , _mark = noMark
280 , _copy = Nothing
281 }
282 return variable
286restoreContent :: Int -> Content -> Solver Content
287restoreContent alreadyCopiedMark content =
288 let
289 go = restore alreadyCopiedMark
290 in
291 case content of
292 Structure term ->
293 Structure <$> traverseTerm go term
295 Atom _ ->
296 return content
298 Var _ _ _ ->
299 return content
301 Alias name args var ->
302 Alias name
303 <$> mapM (traverse go) args
304 <*> go var
306 Error ->
307 return content
311-- TERM TRAVERSAL
314traverseTerm :: (Monad f, Applicative f) => (a -> f b) -> Term1 a -> f (Term1 b)
315traverseTerm f term =
316 case term of
317 App1 a b ->
318 App1 <$> f a <*> f b
320 Fun1 a b ->
321 Fun1 <$> f a <*> f b
323 EmptyRecord1 ->
324 return EmptyRecord1
326 Record1 fields ext ->
327 Record1 <$> traverse f fields <*> f ext