git.iko.soy/elk
on 8bc9edd help sign in
elk/src/Type/State.hs
325 lines 8.2 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 an error to the github repo!"
190 else if _rank descriptor /= noRank || not (needsCopy (_content descriptor)) then
191 return variable
193 else
194 do pool <- getPool
195 newVar <-
196 State.liftIO $ UF.fresh $ Descriptor
197 { _content = error "will be filled in soon!"
198 , _rank = maxRank pool
199 , _mark = noMark
200 , _copy = Nothing
201 }
202 _ <- register newVar
204 -- Link the original variable to the new variable. This lets us
205 -- avoid making multiple copies of the variable we are instantiating.
206 --
207 -- Need to do this before recursively copying the content of
208 -- the variable to avoid looping on cyclic terms.
209 State.liftIO $ UF.modifyDescriptor variable $ \desc ->
210 desc { _mark = alreadyCopiedMark, _copy = Just newVar }
212 -- Now we recursively copy the content of the variable.
213 -- We have already marked the variable as copied, so we
214 -- will not repeat this work or crawl this variable again.
215 let oldContent = _content descriptor
216 newContent <-
217 case oldContent of
218 Structure term ->
219 Structure <$> traverseTerm (makeCopy alreadyCopiedMark) term
221 Atom _ ->
222 return oldContent
224 Var Rigid maybeSuper _ ->
225 return (Var Flex maybeSuper Nothing)
227 Var Flex _ _ ->
228 return oldContent
230 Alias name args realType ->
231 Alias name
232 <$> mapM (traverse (makeCopy alreadyCopiedMark)) args
233 <*> makeCopy alreadyCopiedMark realType
235 Error ->
236 return oldContent
238 State.liftIO $ UF.modifyDescriptor newVar $ \desc ->
239 desc { _content = newContent }
241 return newVar
244needsCopy :: Content -> Bool
245needsCopy content =
246 case content of
247 Structure _ ->
248 True
250 Atom _ ->
251 False
253 Var _ _ _ ->
254 True
256 Alias _ _ _ ->
257 True
259 Error ->
260 False
264restore :: Int -> Variable -> Solver Variable
265restore alreadyCopiedMark variable =
266 do desc <- State.liftIO $ UF.descriptor variable
267 if _mark desc /= alreadyCopiedMark
268 then
269 return variable
271 else
272 do restoredContent <-
273 restoreContent alreadyCopiedMark (_content desc)
274 State.liftIO $ UF.setDescriptor variable $ Descriptor
275 { _content = restoredContent
276 , _rank = noRank
277 , _mark = noMark
278 , _copy = Nothing
279 }
280 return variable
284restoreContent :: Int -> Content -> Solver Content
285restoreContent alreadyCopiedMark content =
286 let
287 go = restore alreadyCopiedMark
288 in
289 case content of
290 Structure term ->
291 Structure <$> traverseTerm go term
293 Atom _ ->
294 return content
296 Var _ _ _ ->
297 return content
299 Alias name args var ->
300 Alias name
301 <$> mapM (traverse go) args
302 <*> go var
304 Error ->
305 return content
309-- TERM TRAVERSAL
312traverseTerm :: (Monad f, Applicative f) => (a -> f b) -> Term1 a -> f (Term1 b)
313traverseTerm f term =
314 case term of
315 App1 a b ->
316 App1 <$> f a <*> f b
318 Fun1 a b ->
319 Fun1 <$> f a <*> f b
321 EmptyRecord1 ->
322 return EmptyRecord1
324 Record1 fields ext ->
325 Record1 <$> traverse f fields <*> f ext