git.iko.soy/elk
on b02b4aa help sign in
elk/src/Type/State.hs
401 lines 9.5 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Type.State
3 ( Solver
4 , run
5 , State(..)
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 , copy
20 )
21 where
24import Control.Monad (liftM, liftM2)
25import Control.Monad.Trans (MonadIO, liftIO)
26import qualified Data.Map as Map
27import Data.Map ((!))
28import Data.Text (Text)
30import qualified Reporting.Annotation as A
31import qualified Reporting.Error.Type as Error
32import qualified Reporting.Region as R
33import Type.Type
34import qualified Type.UnionFind as UF
38-- SOLVER
41newtype Solver a =
42 Solver { _solve :: State -> IO (a, State) }
46-- RUN SOLVER
49run :: Solver () -> IO State
50run (Solver solver) =
51 do (_, state) <- solver initialState
52 return state
55initialState :: State
56initialState =
57 SS
58 { sEnv = Map.empty
59 , sSavedEnv = Map.empty
60 , sPool = Pool outermostRank []
61 , sMark = noMark + 1 -- The mark must never be equal to noMark!
62 , sError = []
63 }
67-- SOLVER STATE
70data State =
71 SS
72 { sEnv :: Env
73 , sSavedEnv :: Env
74 , sPool :: Pool
75 , sMark :: Int
76 , sError :: [A.Located Error.Error]
77 }
80{-| A pool holds a bunch of variables
81The rank of each variable is less than or equal to the pool's "maxRank"
82The young pool exists to make it possible to identify these vars in constant time.
83-}
84data Pool =
85 Pool
86 { _maxRank :: Int
87 , _inhabitants :: [Variable]
88 }
91type Env = Map.Map Text (A.Located Variable)
95-- HELPERS
98{-# INLINE modifyEnv #-}
99modifyEnv :: (Env -> Env) -> Solver ()
100modifyEnv f =
101 Solver $ \state ->
102 return ( (), state { sEnv = f (sEnv state) } )
105{-# INLINE modifyPool #-}
106modifyPool :: (Pool -> Pool) -> Solver ()
107modifyPool f =
108 Solver $ \state ->
109 return ( (), state { sPool = f (sPool state) } )
112{-# INLINE addError #-}
113addError :: R.Region -> Error.Error -> Solver ()
114addError region err =
115 Solver $ \state ->
116 return ( (), state { sError = A.A region err : sError state } )
119{-# INLINE switchToPool #-}
120switchToPool :: Pool -> Solver ()
121switchToPool pool =
122 modifyPool (\_ -> pool)
125{-# INLINE getPool #-}
126getPool :: Solver Pool
127getPool =
128 Solver $ \state ->
129 return ( sPool state, state )
132{-# INLINE getMaxRank #-}
133getMaxRank :: Solver Int
134getMaxRank =
135 Solver $ \state@(SS _ _ (Pool maxRank _) _ _) ->
136 return ( maxRank, state )
139{-# INLINE getEnv #-}
140getEnv :: Solver Env
141getEnv =
142 Solver $ \state ->
143 return ( sEnv state, state )
146{-# INLINE saveLocalEnv #-}
147saveLocalEnv :: Solver ()
148saveLocalEnv =
149 Solver $ \state ->
150 return ( (), state { sSavedEnv = sEnv state } )
153{-# INLINE uniqueMark #-}
154uniqueMark :: Solver Int
155uniqueMark =
156 Solver $ \(SS env savedEnv pool mark errors) ->
157 return ( mark, SS env savedEnv pool (mark + 1) errors )
160{-# INLINE nextRankPool #-}
161nextRankPool :: Solver Pool
162nextRankPool =
163 Solver $ \state@(SS _ _ (Pool maxRank _) _ _) ->
164 return ( Pool (maxRank + 1) [], state )
168-- REGISTER VARIABLES
171{-# INLINE register #-}
172register :: Variable -> Solver Variable
173register variable =
174 {-# SCC elm_compiler_type_register #-}
175 Solver $ \state ->
176 let
177 (Pool maxRank inhabitants) =
178 sPool state
179 in
180 return ( variable, state { sPool = Pool maxRank (variable : inhabitants) } )
183{-# INLINE introduce #-}
184introduce :: Variable -> Solver Variable
185introduce variable =
186 {-# SCC elm_compiler_type_introduce #-}
187 Solver $ \(SS env savedEnv (Pool maxRank inhabitants) mark errors) ->
188 do UF.modifyDescriptor variable $ \(Descriptor c _ m cp) -> Descriptor c maxRank m cp
189 let newPool = Pool maxRank (variable : inhabitants)
190 return ( variable, SS env savedEnv newPool mark errors )
194-- FLATTEN
197flatten :: Type -> Solver Variable
198flatten term =
199 {-# SCC elm_compiler_type_flatten #-}
200 do maxRank <- getMaxRank
201 flattenHelp maxRank Map.empty term
204flattenHelp :: Int -> Map.Map Text Variable -> Type -> Solver Variable
205flattenHelp maxRank aliasDict termN =
206 case termN of
207 PlaceHolder name ->
208 return (aliasDict ! name)
210 AliasN name args realType ->
211 do flatArgs <- mapM (traverse (flattenHelp maxRank aliasDict)) args
212 flatVar <- flattenHelp maxRank (Map.fromList flatArgs) realType
213 makeFlatType maxRank (Alias name flatArgs flatVar)
215 VarN v ->
216 return v
218 AppN name args ->
219 do flatArgs <- traverse (flattenHelp maxRank aliasDict) args
220 makeFlatType maxRank (Structure (App1 name flatArgs))
222 FunN a b ->
223 do flatA <- flattenHelp maxRank aliasDict a
224 flatB <- flattenHelp maxRank aliasDict b
225 makeFlatType maxRank (Structure (Fun1 flatA flatB))
227 EmptyRecordN ->
228 makeFlatType maxRank (Structure EmptyRecord1)
230 RecordN fields ext ->
231 do flatFields <- traverse (flattenHelp maxRank aliasDict) fields
232 flatExt <- flattenHelp maxRank aliasDict ext
233 makeFlatType maxRank (Structure (Record1 flatFields flatExt))
236makeFlatType :: Int -> Content -> Solver Variable
237makeFlatType maxRank content =
238 register =<< liftIO (UF.fresh (Descriptor content maxRank noMark Nothing))
242-- COPY
245copy :: Variable -> Solver Variable
246copy var =
247 {-# SCC elm_compiler_type_copy #-}
248 do maxRank <- getMaxRank
249 copyVar <- copyHelp maxRank var
250 _ <- restore var
251 return copyVar
254copyHelp :: Int -> Variable -> Solver Variable
255copyHelp maxRank variable =
256 do (Descriptor content rank _mark maybeCopy) <- liftIO $ UF.descriptor variable
257 case maybeCopy of
258 Just copiedVariable ->
259 return copiedVariable
261 Nothing ->
262 if rank /= noRank then
263 return variable
265 else
266 do let mkCopyDesc cont = Descriptor cont maxRank noMark Nothing
267 newVar <- liftIO $ UF.fresh $ mkCopyDesc content
268 _ <- register newVar
270 -- Link the original variable to the new variable. This lets us
271 -- avoid making multiple copies of the variable we are instantiating.
272 --
273 -- Need to do this before recursively copying the content of
274 -- the variable to avoid looping on cyclic terms.
275 liftIO $ UF.setDescriptor variable $
276 Descriptor content rank noMark (Just newVar)
278 -- Now we recursively copy the content of the variable.
279 -- We have already marked the variable as copied, so we
280 -- will not repeat this work or crawl this variable again.
281 case content of
282 Structure term ->
283 do newTerm <- traverseFlatType (copyHelp maxRank) term
284 liftIO $ UF.setDescriptor newVar $ mkCopyDesc (Structure newTerm)
286 Var Rigid maybeSuper maybeName ->
287 liftIO $ UF.setDescriptor newVar $ mkCopyDesc $ Var Flex maybeSuper maybeName
289 Var Flex _ _ ->
290 return ()
292 Alias name args realType ->
293 do newArgs <- mapM (traverse (copyHelp maxRank)) args
294 newRealType <- copyHelp maxRank realType
295 liftIO $ UF.setDescriptor newVar $ mkCopyDesc (Alias name newArgs newRealType)
297 Error _ ->
298 return ()
300 return newVar
304-- RESTORE
307restore :: Variable -> Solver Variable
308restore variable =
309 do (Descriptor content _rank _mark maybeCopy) <- liftIO $ UF.descriptor variable
310 case maybeCopy of
311 Nothing ->
312 return variable
314 Just _ ->
315 do restoredContent <- restoreContent content
316 liftIO $ UF.setDescriptor variable $
317 Descriptor restoredContent noRank noMark Nothing
318 return variable
321restoreContent :: Content -> Solver Content
322restoreContent content =
323 case content of
324 Structure term ->
325 Structure <$> traverseFlatType restore term
327 Var _ _ _ ->
328 return content
330 Alias name args var ->
331 Alias name
332 <$> mapM (traverse restore) args
333 <*> restore var
335 Error _ ->
336 return content
340-- TRAVERSE FLAT TYPE
343traverseFlatType :: (Variable -> Solver Variable) -> FlatType -> Solver FlatType
344traverseFlatType f flatType =
345 case flatType of
346 App1 name args ->
347 liftM (App1 name) (traverse f args)
349 Fun1 a b ->
350 liftM2 Fun1 (f a) (f b)
352 EmptyRecord1 ->
353 pure EmptyRecord1
355 Record1 fields ext ->
356 liftM2 Record1 (traverse f fields) (f ext)
360-- INSTANCES
363instance Functor Solver where
364 {-# INLINE fmap #-}
365 fmap f (Solver solver) =
366 Solver $ \s1 ->
367 fmap (\(a, s2) -> (f a, s2)) (solver s1)
370instance Applicative Solver where
371 {-# INLINE pure #-}
372 pure a =
373 Solver $ \s -> return (a, s)
375 {-# INLINE (<*>) #-}
376 Solver solverFunc <*> Solver solverValue =
377 Solver $ \s1 ->
378 do (f, s2) <- solverFunc s1
379 (x, s3) <- solverValue s2
380 return (f x, s3)
383instance Monad Solver where
384 {-# INLINE (>>=) #-}
385 Solver solver >>= k =
386 Solver $ \s1 ->
387 do (a, s2) <- solver s1
388 (b, s3) <- _solve (k a) s2
389 return (b, s3)
391 {-# INLINE fail #-}
392 fail msg =
393 Solver $ \_ -> fail msg
396instance MonadIO Solver where
397 {-# INLINE liftIO #-}
398 liftIO io =
399 Solver $ \state ->
400 do a <- io
401 return (a, state)