git.iko.soy/elk
on 0765fde help sign in
elk/src/Type/State.hs
339 lines 8.4 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 as Map
23import Data.Map ((!))
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 Var Rigid maybeSuper maybeName ->
225 UF.setDescriptor newVar $ mkCopyDesc $ Var Flex maybeSuper maybeName
227 Var Flex _ _ ->
228 return ()
230 Alias name args realType ->
231 do newArgs <- mapM (traverse (copyHelp maxRank pools)) args
232 newRealType <- copyHelp maxRank pools realType
233 UF.setDescriptor newVar $ mkCopyDesc (Alias name newArgs newRealType)
235 Error _ ->
236 return ()
238 return newVar
242-- RESTORE
245restore :: Variable -> IO Variable
246restore variable =
247 do (Descriptor content _rank _mark maybeCopy) <- UF.descriptor variable
248 case maybeCopy of
249 Nothing ->
250 return variable
252 Just _ ->
253 do restoredContent <- restoreContent content
254 UF.setDescriptor variable $
255 Descriptor restoredContent noRank noMark Nothing
256 return variable
259restoreContent :: Content -> IO Content
260restoreContent content =
261 case content of
262 Structure term ->
263 Structure <$> traverseFlatType restore term
265 Var _ _ _ ->
266 return content
268 Alias name args var ->
269 Alias name
270 <$> mapM (traverse restore) args
271 <*> restore var
273 Error _ ->
274 return content
278-- TRAVERSE FLAT TYPE
281traverseFlatType :: (Variable -> IO Variable) -> FlatType -> IO FlatType
282traverseFlatType f flatType =
283 case flatType of
284 App1 name args ->
285 liftM (App1 name) (traverse f args)
287 Fun1 a b ->
288 liftM2 Fun1 (f a) (f b)
290 EmptyRecord1 ->
291 pure EmptyRecord1
293 Record1 fields ext ->
294 liftM2 Record1 (traverse f fields) (f ext)
298-- INSTANCES
301instance Functor Solver where
302 {-# INLINE fmap #-}
303 fmap f (Solver solver) =
304 Solver $ \s1 ->
305 fmap (\(a, s2) -> (f a, s2)) (solver s1)
308instance Applicative Solver where
309 {-# INLINE pure #-}
310 pure a =
311 Solver $ \s -> return (a, s)
313 {-# INLINE (<*>) #-}
314 Solver solverFunc <*> Solver solverValue =
315 Solver $ \s1 ->
316 do (f, s2) <- solverFunc s1
317 (x, s3) <- solverValue s2
318 return (f x, s3)
321instance Monad Solver where
322 {-# INLINE (>>=) #-}
323 Solver solver >>= k =
324 Solver $ \s1 ->
325 do (a, s2) <- solver s1
326 (b, s3) <- _solve (k a) s2
327 return (b, s3)
329 {-# INLINE fail #-}
330 fail msg =
331 Solver $ \_ -> fail msg
334instance MonadIO Solver where
335 {-# INLINE liftIO #-}
336 liftIO io =
337 Solver $ \state ->
338 do a <- io
339 return (a, state)