git.iko.soy/elk
on 696ee0a help sign in
elk/src/Type/State.hs
402 lines 9.6 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 as 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 = Type.nextMark noMark -- 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 :: Mark
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 Mark
155uniqueMark =
156 Solver $ \(SS env savedEnv pool mark errors) ->
157 return ( mark, SS env savedEnv pool (Type.nextMark mark) 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 ()
185introduce variables =
186 {-# SCC elm_compiler_type_introduce #-}
187 Solver $ \(SS env savedEnv (Pool maxRank inhabitants) mark errors) ->
188 do let toMaxRank (Descriptor c _ m cp) = Descriptor c maxRank m cp
189 mapM_ (\var -> UF.modifyDescriptor var toMaxRank) variables
190 let newPool = Pool maxRank (variables ++ inhabitants)
191 return ( (), SS env savedEnv newPool mark errors )
195-- FLATTEN
198flatten :: Type -> Solver Variable
199flatten term =
200 {-# SCC elm_compiler_type_flatten #-}
201 do maxRank <- getMaxRank
202 flattenHelp maxRank Map.empty term
205flattenHelp :: Int -> Map.Map Text Variable -> Type -> Solver Variable
206flattenHelp maxRank aliasDict termN =
207 case termN of
208 PlaceHolder name ->
209 return (aliasDict ! name)
211 AliasN name args realType ->
212 do flatArgs <- mapM (traverse (flattenHelp maxRank aliasDict)) args
213 flatVar <- flattenHelp maxRank (Map.fromList flatArgs) realType
214 makeFlatType maxRank (Alias name flatArgs flatVar)
216 VarN v ->
217 return v
219 AppN name args ->
220 do flatArgs <- traverse (flattenHelp maxRank aliasDict) args
221 makeFlatType maxRank (Structure (App1 name flatArgs))
223 FunN a b ->
224 do flatA <- flattenHelp maxRank aliasDict a
225 flatB <- flattenHelp maxRank aliasDict b
226 makeFlatType maxRank (Structure (Fun1 flatA flatB))
228 EmptyRecordN ->
229 makeFlatType maxRank (Structure EmptyRecord1)
231 RecordN fields ext ->
232 do flatFields <- traverse (flattenHelp maxRank aliasDict) fields
233 flatExt <- flattenHelp maxRank aliasDict ext
234 makeFlatType maxRank (Structure (Record1 flatFields flatExt))
237makeFlatType :: Int -> Content -> Solver Variable
238makeFlatType maxRank content =
239 register =<< liftIO (UF.fresh (Descriptor content maxRank noMark Nothing))
243-- COPY
246copy :: Variable -> Solver Variable
247copy var =
248 {-# SCC elm_compiler_type_copy #-}
249 do maxRank <- getMaxRank
250 copyVar <- copyHelp maxRank var
251 _ <- restore var
252 return copyVar
255copyHelp :: Int -> Variable -> Solver Variable
256copyHelp maxRank variable =
257 do (Descriptor content rank _mark maybeCopy) <- liftIO $ UF.descriptor variable
258 case maybeCopy of
259 Just copiedVariable ->
260 return copiedVariable
262 Nothing ->
263 if rank /= noRank then
264 return variable
266 else
267 do let mkCopyDesc cont = Descriptor cont maxRank noMark Nothing
268 newVar <- liftIO $ UF.fresh $ mkCopyDesc content
269 _ <- register newVar
271 -- Link the original variable to the new variable. This lets us
272 -- avoid making multiple copies of the variable we are instantiating.
273 --
274 -- Need to do this before recursively copying the content of
275 -- the variable to avoid looping on cyclic terms.
276 liftIO $ UF.setDescriptor variable $
277 Descriptor content rank noMark (Just newVar)
279 -- Now we recursively copy the content of the variable.
280 -- We have already marked the variable as copied, so we
281 -- will not repeat this work or crawl this variable again.
282 case content of
283 Structure term ->
284 do newTerm <- traverseFlatType (copyHelp maxRank) term
285 liftIO $ UF.setDescriptor newVar $ mkCopyDesc (Structure newTerm)
287 Var Rigid maybeSuper maybeName ->
288 liftIO $ UF.setDescriptor newVar $ mkCopyDesc $ Var Flex maybeSuper maybeName
290 Var Flex _ _ ->
291 return ()
293 Alias name args realType ->
294 do newArgs <- mapM (traverse (copyHelp maxRank)) args
295 newRealType <- copyHelp maxRank realType
296 liftIO $ UF.setDescriptor newVar $ mkCopyDesc (Alias name newArgs newRealType)
298 Error _ ->
299 return ()
301 return newVar
305-- RESTORE
308restore :: Variable -> Solver Variable
309restore variable =
310 do (Descriptor content _rank _mark maybeCopy) <- liftIO $ UF.descriptor variable
311 case maybeCopy of
312 Nothing ->
313 return variable
315 Just _ ->
316 do restoredContent <- restoreContent content
317 liftIO $ UF.setDescriptor variable $
318 Descriptor restoredContent noRank noMark Nothing
319 return variable
322restoreContent :: Content -> Solver Content
323restoreContent content =
324 case content of
325 Structure term ->
326 Structure <$> traverseFlatType restore term
328 Var _ _ _ ->
329 return content
331 Alias name args var ->
332 Alias name
333 <$> mapM (traverse restore) args
334 <*> restore var
336 Error _ ->
337 return content
341-- TRAVERSE FLAT TYPE
344traverseFlatType :: (Variable -> Solver Variable) -> FlatType -> Solver FlatType
345traverseFlatType f flatType =
346 case flatType of
347 App1 name args ->
348 liftM (App1 name) (traverse f args)
350 Fun1 a b ->
351 liftM2 Fun1 (f a) (f b)
353 EmptyRecord1 ->
354 pure EmptyRecord1
356 Record1 fields ext ->
357 liftM2 Record1 (traverse f fields) (f ext)
361-- INSTANCES
364instance Functor Solver where
365 {-# INLINE fmap #-}
366 fmap f (Solver solver) =
367 Solver $ \s1 ->
368 fmap (\(a, s2) -> (f a, s2)) (solver s1)
371instance Applicative Solver where
372 {-# INLINE pure #-}
373 pure a =
374 Solver $ \s -> return (a, s)
376 {-# INLINE (<*>) #-}
377 Solver solverFunc <*> Solver solverValue =
378 Solver $ \s1 ->
379 do (f, s2) <- solverFunc s1
380 (x, s3) <- solverValue s2
381 return (f x, s3)
384instance Monad Solver where
385 {-# INLINE (>>=) #-}
386 Solver solver >>= k =
387 Solver $ \s1 ->
388 do (a, s2) <- solver s1
389 (b, s3) <- _solve (k a) s2
390 return (b, s3)
392 {-# INLINE fail #-}
393 fail msg =
394 Solver $ \_ -> fail msg
397instance MonadIO Solver where
398 {-# INLINE liftIO #-}
399 liftIO io =
400 Solver $ \state ->
401 do a <- io
402 return (a, state)