git.iko.soy/elk
on d3fa290 help sign in
elk/src/Type/State.hs
369 lines 9.3 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Type.State
3 ( Solver(..)
4 , run
5 , State(..)
6 , Pools
7 , Env
8 , modifyEnv
9 , addError
10 , getEnv
11 , saveLocalEnv
12 , register
13 , introduce
14 , flatten
15 , copy
16 )
17 where
20import Control.Monad (forM_, liftM, liftM2, liftM3)
21import Control.Monad.Trans (MonadIO, liftIO)
22import qualified Data.Map.Strict as Map
23import Data.Map.Strict ((!))
24import qualified Data.Vector.Mutable as MVector
26import qualified Elm.Name as N
27import qualified Reporting.Annotation as A
28import qualified Reporting.Error.Type as Error
29import qualified Reporting.Region as R
30import Type.Type as Type
31import qualified Type.UnionFind as UF
35-- SOLVER
38newtype Solver a =
39 Solver { _solve :: State -> IO (a, State) }
42data State =
43 SS
44 { _env :: Env
45 , _savedEnv :: Env
46 , _rank :: Int
47 , _pools :: Pools
48 , _mark :: Mark
49 , _errors :: [A.Located Error.Error]
50 }
53type Pools = MVector.IOVector [Variable]
56type Env = Map.Map N.Name (A.Located Variable)
60-- RUN SOLVER
63run :: Solver () -> IO State
64run (Solver solver) =
65 do pools <- MVector.replicate 8 []
66 (_, state) <- solver (SS Map.empty Map.empty outermostRank pools (Type.nextMark noMark) [])
67 return state
71-- HELPERS
74{-# INLINE modifyEnv #-}
75modifyEnv :: (Env -> Env) -> Solver ()
76modifyEnv f =
77 Solver $ \state ->
78 return ( (), state { _env = f (_env state) } )
81{-# INLINE addError #-}
82addError :: R.Region -> Error.Error -> Solver ()
83addError region err =
84 Solver $ \state ->
85 return ( (), state { _errors = A.A region err : _errors state } )
88{-# INLINE getEnv #-}
89getEnv :: Solver Env
90getEnv =
91 Solver $ \state ->
92 return ( _env state, state )
95{-# INLINE saveLocalEnv #-}
96saveLocalEnv :: Solver ()
97saveLocalEnv =
98 Solver $ \state ->
99 return ( (), state { _savedEnv = _env state } )
103-- REGISTER VARIABLES
106register :: Variable -> Solver ()
107register var =
108 Solver $ \state@(SS _ _ maxRank pools _ _) ->
109 {-# SCC elm_compiler_type_register #-}
110 do MVector.modify pools (var:) maxRank
111 return ( (), state )
114introduce :: [Variable] -> Solver ()
115introduce variables =
116 Solver $ \state@(SS _ _ maxRank pools _ _) ->
117 {-# SCC elm_compiler_type_introduce #-}
118 do
119 forM_ variables $ \var ->
120 UF.modifyDescriptor var $ \(Descriptor content _ mark cp) ->
121 Descriptor content maxRank mark cp
123 MVector.modify pools (variables++) maxRank
125 return ( (), state )
129-- FLATTEN
132flatten :: Type -> Solver Variable
133flatten tipe =
134 Solver $ \state@(SS _ _ maxRank pools _ _) ->
135 {-# SCC elm_compiler_type_flatten #-}
136 do var <- flattenHelp maxRank pools Map.empty tipe
137 return (var, state)
140flattenHelp :: Int -> Pools -> Map.Map N.Name Variable -> Type -> IO Variable
141flattenHelp maxRank pools aliasDict tipe =
142 case tipe of
143 PlaceHolder name ->
144 return (aliasDict ! name)
146 AliasN home name args realType ->
147 do flatArgs <- mapM (traverse (flattenHelp maxRank pools aliasDict)) args
148 flatVar <- flattenHelp maxRank pools (Map.fromList flatArgs) realType
149 registerFlatType maxRank pools (Alias home name flatArgs flatVar)
151 VarN v ->
152 return v
154 AppN home name args ->
155 do flatArgs <- traverse (flattenHelp maxRank pools aliasDict) args
156 registerFlatType maxRank pools (Structure (App1 home name flatArgs))
158 FunN a b ->
159 do flatA <- flattenHelp maxRank pools aliasDict a
160 flatB <- flattenHelp maxRank pools aliasDict b
161 registerFlatType maxRank pools (Structure (Fun1 flatA flatB))
163 EmptyRecordN ->
164 registerFlatType maxRank pools (Structure EmptyRecord1)
166 RecordN fields ext ->
167 do flatFields <- traverse (flattenHelp maxRank pools aliasDict) fields
168 flatExt <- flattenHelp maxRank pools aliasDict ext
169 registerFlatType maxRank pools (Structure (Record1 flatFields flatExt))
171 UnitN ->
172 registerFlatType maxRank pools (Structure Unit1)
174 TupleN a b cs ->
175 do flatA <- flattenHelp maxRank pools aliasDict a
176 flatB <- flattenHelp maxRank pools aliasDict b
177 flatCs <- traverse (flattenHelp maxRank pools aliasDict) cs
178 registerFlatType maxRank pools (Structure (Tuple1 flatA flatB flatCs))
181registerFlatType :: Int -> Pools -> Content -> IO Variable
182registerFlatType maxRank pools content =
183 do var <- UF.fresh (Descriptor content maxRank noMark Nothing)
184 MVector.modify pools (var:) maxRank
185 return var
189-- COPY
192copy :: Variable -> Solver Variable
193copy var =
194 Solver $ \state@(SS _ _ maxRank pools _ _) ->
195 {-# SCC elm_compiler_type_copy #-}
196 do copyVar <- copyHelp maxRank pools var
197 _ <- restore var
198 return ( copyVar, state )
201copyHelp :: Int -> Pools -> Variable -> IO Variable
202copyHelp maxRank pools variable =
203 do (Descriptor content rank _mark maybeCopy) <- UF.descriptor variable
204 case maybeCopy of
205 Just copiedVariable ->
206 return copiedVariable
208 Nothing ->
209 if rank /= noRank then
210 return variable
212 else
213 do let mkCopyDesc cont = Descriptor cont maxRank noMark Nothing
214 newVar <- UF.fresh $ mkCopyDesc content
215 MVector.modify pools (newVar:) maxRank
217 -- Link the original variable to the new variable. This lets us
218 -- avoid making multiple copies of the variable we are instantiating.
219 --
220 -- Need to do this before recursively copying the content of
221 -- the variable to avoid looping on cyclic terms.
222 UF.setDescriptor variable $
223 Descriptor content rank noMark (Just newVar)
225 -- Now we recursively copy the content of the variable.
226 -- We have already marked the variable as copied, so we
227 -- will not repeat this work or crawl this variable again.
228 case content of
229 Structure term ->
230 do newTerm <- traverseFlatType (copyHelp maxRank pools) term
231 UF.setDescriptor newVar $ mkCopyDesc (Structure newTerm)
233 FlexVar _ ->
234 return ()
236 FlexSuper _ _ ->
237 return ()
239 RigidVar name ->
240 UF.setDescriptor newVar $ mkCopyDesc $ FlexVar (Just name)
242 RigidSuper super name ->
243 UF.setDescriptor newVar $ mkCopyDesc $ FlexSuper super (Just name)
245 Alias home name args realType ->
246 do newArgs <- mapM (traverse (copyHelp maxRank pools)) args
247 newRealType <- copyHelp maxRank pools realType
248 UF.setDescriptor newVar $ mkCopyDesc (Alias home name newArgs newRealType)
250 Error _ ->
251 return ()
253 return newVar
257-- RESTORE
260restore :: Variable -> IO Variable
261restore variable =
262 do (Descriptor content _rank _mark maybeCopy) <- UF.descriptor variable
263 case maybeCopy of
264 Nothing ->
265 return variable
267 Just _ ->
268 do restoredContent <- restoreContent content
269 UF.setDescriptor variable $
270 Descriptor restoredContent noRank noMark Nothing
271 return variable
274restoreContent :: Content -> IO Content
275restoreContent content =
276 case content of
277 FlexVar _ ->
278 return content
280 FlexSuper _ _ ->
281 return content
283 RigidVar _ ->
284 return content
286 RigidSuper _ _ ->
287 return content
289 Structure term ->
290 Structure <$> traverseFlatType restore term
292 Alias home name args var ->
293 Alias home name
294 <$> mapM (traverse restore) args
295 <*> restore var
297 Error _ ->
298 return content
302-- TRAVERSE FLAT TYPE
305traverseFlatType :: (Variable -> IO Variable) -> FlatType -> IO FlatType
306traverseFlatType f flatType =
307 case flatType of
308 App1 home name args ->
309 liftM (App1 home name) (traverse f args)
311 Fun1 a b ->
312 liftM2 Fun1 (f a) (f b)
314 EmptyRecord1 ->
315 pure EmptyRecord1
317 Record1 fields ext ->
318 liftM2 Record1 (traverse f fields) (f ext)
320 Unit1 ->
321 pure Unit1
323 Tuple1 a b cs ->
324 liftM3 Tuple1 (f a) (f b) (traverse f cs)
328-- INSTANCES
331instance Functor Solver where
332 {-# INLINE fmap #-}
333 fmap f (Solver solver) =
334 Solver $ \s1 ->
335 fmap (\(a, s2) -> (f a, s2)) (solver s1)
338instance Applicative Solver where
339 {-# INLINE pure #-}
340 pure a =
341 Solver $ \s -> return (a, s)
343 {-# INLINE (<*>) #-}
344 Solver solverFunc <*> Solver solverValue =
345 Solver $ \s1 ->
346 do (f, s2) <- solverFunc s1
347 (x, s3) <- solverValue s2
348 return (f x, s3)
351instance Monad Solver where
352 {-# INLINE (>>=) #-}
353 Solver solver >>= k =
354 Solver $ \s1 ->
355 do (a, s2) <- solver s1
356 (b, s3) <- _solve (k a) s2
357 return (b, s3)
359 {-# INLINE fail #-}
360 fail msg =
361 Solver $ \_ -> fail msg
364instance MonadIO Solver where
365 {-# INLINE liftIO #-}
366 liftIO io =
367 Solver $ \state ->
368 do a <- io
369 return (a, state)