git.iko.soy/elk
on fcbda99 help sign in
elk/src/Type/State.hs
354 lines 8.7 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)
21import Control.Monad.Trans (MonadIO, liftIO)
22import qualified Data.Map.Strict as Map
23import Data.Map.Strict ((!))
24import Data.Text (Text)
25import qualified Data.Vector.Mutable as MVector
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 Text (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 Text Variable -> Type -> IO Variable
141flattenHelp maxRank pools aliasDict tipe =
142 case tipe of
143 PlaceHolder name ->
144 return (aliasDict ! name)
146 AliasN 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 name flatArgs flatVar)
151 VarN v ->
152 return v
154 AppN name args ->
155 do flatArgs <- traverse (flattenHelp maxRank pools aliasDict) args
156 registerFlatType maxRank pools (Structure (App1 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))
172registerFlatType :: Int -> Pools -> Content -> IO Variable
173registerFlatType maxRank pools content =
174 do var <- UF.fresh (Descriptor content maxRank noMark Nothing)
175 MVector.modify pools (var:) maxRank
176 return var
180-- COPY
183copy :: Variable -> Solver Variable
184copy var =
185 Solver $ \state@(SS _ _ maxRank pools _ _) ->
186 {-# SCC elm_compiler_type_copy #-}
187 do copyVar <- copyHelp maxRank pools var
188 _ <- restore var
189 return ( copyVar, state )
192copyHelp :: Int -> Pools -> Variable -> IO Variable
193copyHelp maxRank pools variable =
194 do (Descriptor content rank _mark maybeCopy) <- UF.descriptor variable
195 case maybeCopy of
196 Just copiedVariable ->
197 return copiedVariable
199 Nothing ->
200 if rank /= noRank then
201 return variable
203 else
204 do let mkCopyDesc cont = Descriptor cont maxRank noMark Nothing
205 newVar <- UF.fresh $ mkCopyDesc content
206 MVector.modify pools (newVar:) maxRank
208 -- Link the original variable to the new variable. This lets us
209 -- avoid making multiple copies of the variable we are instantiating.
210 --
211 -- Need to do this before recursively copying the content of
212 -- the variable to avoid looping on cyclic terms.
213 UF.setDescriptor variable $
214 Descriptor content rank noMark (Just newVar)
216 -- Now we recursively copy the content of the variable.
217 -- We have already marked the variable as copied, so we
218 -- will not repeat this work or crawl this variable again.
219 case content of
220 Structure term ->
221 do newTerm <- traverseFlatType (copyHelp maxRank pools) term
222 UF.setDescriptor newVar $ mkCopyDesc (Structure newTerm)
224 FlexVar _ ->
225 return ()
227 FlexSuper _ _ ->
228 return ()
230 RigidVar name ->
231 UF.setDescriptor newVar $ mkCopyDesc $ FlexVar (Just name)
233 RigidSuper super name ->
234 UF.setDescriptor newVar $ mkCopyDesc $ FlexSuper super (Just name)
236 Alias name args realType ->
237 do newArgs <- mapM (traverse (copyHelp maxRank pools)) args
238 newRealType <- copyHelp maxRank pools realType
239 UF.setDescriptor newVar $ mkCopyDesc (Alias name newArgs newRealType)
241 Error _ ->
242 return ()
244 return newVar
248-- RESTORE
251restore :: Variable -> IO Variable
252restore variable =
253 do (Descriptor content _rank _mark maybeCopy) <- UF.descriptor variable
254 case maybeCopy of
255 Nothing ->
256 return variable
258 Just _ ->
259 do restoredContent <- restoreContent content
260 UF.setDescriptor variable $
261 Descriptor restoredContent noRank noMark Nothing
262 return variable
265restoreContent :: Content -> IO Content
266restoreContent content =
267 case content of
268 FlexVar _ ->
269 return content
271 FlexSuper _ _ ->
272 return content
274 RigidVar _ ->
275 return content
277 RigidSuper _ _ ->
278 return content
280 Structure term ->
281 Structure <$> traverseFlatType restore term
283 Alias name args var ->
284 Alias name
285 <$> mapM (traverse restore) args
286 <*> restore var
288 Error _ ->
289 return content
293-- TRAVERSE FLAT TYPE
296traverseFlatType :: (Variable -> IO Variable) -> FlatType -> IO FlatType
297traverseFlatType f flatType =
298 case flatType of
299 App1 name args ->
300 liftM (App1 name) (traverse f args)
302 Fun1 a b ->
303 liftM2 Fun1 (f a) (f b)
305 EmptyRecord1 ->
306 pure EmptyRecord1
308 Record1 fields ext ->
309 liftM2 Record1 (traverse f fields) (f ext)
313-- INSTANCES
316instance Functor Solver where
317 {-# INLINE fmap #-}
318 fmap f (Solver solver) =
319 Solver $ \s1 ->
320 fmap (\(a, s2) -> (f a, s2)) (solver s1)
323instance Applicative Solver where
324 {-# INLINE pure #-}
325 pure a =
326 Solver $ \s -> return (a, s)
328 {-# INLINE (<*>) #-}
329 Solver solverFunc <*> Solver solverValue =
330 Solver $ \s1 ->
331 do (f, s2) <- solverFunc s1
332 (x, s3) <- solverValue s2
333 return (f x, s3)
336instance Monad Solver where
337 {-# INLINE (>>=) #-}
338 Solver solver >>= k =
339 Solver $ \s1 ->
340 do (a, s2) <- solver s1
341 (b, s3) <- _solve (k a) s2
342 return (b, s3)
344 {-# INLINE fail #-}
345 fail msg =
346 Solver $ \_ -> fail msg
349instance MonadIO Solver where
350 {-# INLINE liftIO #-}
351 liftIO io =
352 Solver $ \state ->
353 do a <- io
354 return (a, state)