git.iko.soy/elk
on 8aec074 help sign in
elk/src/Type/State.hs
264 lines 7.6 kB history raw
1{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE MultiParamTypeClasses #-}
3module Type.State where
5import Control.Applicative ((<|>))
6import Control.Monad.State
7import Data.Map ((!))
8import qualified Data.Map as Map
9import qualified Data.Traversable as Traversable
10import qualified Data.UnionFind.IO as UF
12import qualified Reporting.Annotation as A
13import qualified Reporting.Error.Type as Error
14import qualified Reporting.Region as R
15import Type.Type
18-- Pool
19-- Holds a bunch of variables
20-- The rank of each variable is less than or equal to the pool's "maxRank"
21-- The young pool exists to make it possible to identify these vars in constant time.
23data Pool = Pool
24 { maxRank :: Int
25 , inhabitants :: [Variable]
26 }
29emptyPool :: Pool
30emptyPool =
31 Pool
32 { maxRank = outermostRank
33 , inhabitants = []
34 }
37type Env = Map.Map String (A.Located Variable)
40-- Keeps track of the environment, type variable pool, and a list of errors
41data SolverState = SS
42 { sEnv :: Env
43 , sSavedEnv :: Env
44 , sPool :: Pool
45 , sMark :: Int
46 , sError :: [A.Located Error.Error]
47 }
50initialState :: SolverState
51initialState =
52 SS
53 { sEnv = Map.empty
54 , sSavedEnv = Map.empty
55 , sPool = emptyPool
56 , sMark = noMark + 1 -- The mark must never be equal to noMark!
57 , sError = []
58 }
61modifyEnv :: (MonadState SolverState m) => (Env -> Env) -> m ()
62modifyEnv f =
63 modify $ \state -> state { sEnv = f (sEnv state) }
66modifyPool :: (MonadState SolverState m) => (Pool -> Pool) -> m ()
67modifyPool f =
68 modify $ \state -> state { sPool = f (sPool state) }
71addError :: R.Region -> Error.Error -> StateT SolverState IO ()
72addError region err =
73 modify $ \state -> state { sError = A.A region err : sError state }
76switchToPool :: (MonadState SolverState m) => Pool -> m ()
77switchToPool pool =
78 modifyPool (\_ -> pool)
81getPool :: StateT SolverState IO Pool
82getPool =
83 gets sPool
86getEnv :: StateT SolverState IO Env
87getEnv =
88 gets sEnv
91saveLocalEnv :: StateT SolverState IO ()
92saveLocalEnv =
93 do currentEnv <- getEnv
94 modify $ \state -> state { sSavedEnv = currentEnv }
97uniqueMark :: StateT SolverState IO Int
98uniqueMark =
99 do state <- get
100 let mark = sMark state
101 put $ state { sMark = mark + 1 }
102 return mark
105nextRankPool :: StateT SolverState IO Pool
106nextRankPool =
107 do pool <- getPool
108 return $ Pool { maxRank = maxRank pool + 1, inhabitants = [] }
111register :: Variable -> StateT SolverState IO Variable
112register variable =
113 do modifyPool $ \pool -> pool { inhabitants = variable : inhabitants pool }
114 return variable
117introduce :: Variable -> StateT SolverState IO Variable
118introduce variable =
119 do pool <- getPool
120 liftIO $ UF.modifyDescriptor variable (\desc -> desc { rank = maxRank pool })
121 register variable
124flatten :: Type -> StateT SolverState IO Variable
125flatten term =
126 flattenHelp Map.empty term
129flattenHelp :: Map.Map String Variable -> Type -> StateT SolverState IO Variable
130flattenHelp aliasDict term =
131 case term of
132 PlaceHolder name ->
133 return (aliasDict ! name)
135 VarN maybeAlias v ->
136 do maybeAlias' <- Traversable.traverse flattenAlias maybeAlias
137 liftIO $ UF.modifyDescriptor v $ \desc ->
138 desc { alias = maybeAlias' <|> alias desc }
139 return v
141 TermN maybeAlias subTerm ->
142 do maybeAlias' <- Traversable.traverse flattenAlias maybeAlias
143 let localDict = maybe aliasDict (Map.fromList . snd) maybeAlias'
144 flatStructure <- traverseTerm (flattenHelp localDict) subTerm
145 pool <- getPool
146 var <-
147 liftIO . UF.fresh $ Descriptor
148 { structure = Just flatStructure
149 , rank = maxRank pool
150 , flex = Flexible
151 , name = Nothing
152 , copy = Nothing
153 , mark = noMark
154 , alias = maybeAlias'
155 }
156 register var
157 where
158 flattenAlias (name, args) =
159 let flattenPair (arg, subTerm) =
160 (,) arg <$> flattenHelp aliasDict subTerm
161 in
162 (,) name <$> mapM flattenPair args
167makeInstance :: Variable -> StateT SolverState IO Variable
168makeInstance var =
169 do alreadyCopied <- uniqueMark
170 freshVar <- makeCopy alreadyCopied var
171 restore alreadyCopied var
172 return freshVar
175makeCopy :: Int -> Variable -> StateT SolverState IO Variable
176makeCopy alreadyCopied variable = do
177 desc <- liftIO $ UF.descriptor variable
178 case () of
179 () | mark desc == alreadyCopied ->
180 case copy desc of
181 Just v ->
182 return v
183 Nothing ->
184 error $
185 "Error copying type variable. This should be impossible." ++
186 " Please report an error to the github repo!"
188 | rank desc /= noRank || flex desc == Constant ->
189 return variable
191 | otherwise ->
192 do pool <- getPool
193 newVar <-
194 liftIO $ UF.fresh $ Descriptor
195 { structure = Nothing
196 , rank = maxRank pool
197 , mark = noMark
198 , flex =
199 case flex desc of
200 Is s -> Is s
201 _ -> Flexible
202 , copy = Nothing
203 , name =
204 case flex desc of
205 Rigid -> Nothing
206 _ -> name desc
207 , alias = Nothing
208 }
209 register newVar
211 -- Link the original variable to the new variable. This lets us
212 -- avoid making multiple copies of the variable we are instantiating.
213 --
214 -- Need to do this before recursively copying the structure of
215 -- the variable to avoid looping on cyclic terms.
216 liftIO $ UF.modifyDescriptor variable $ \desc ->
217 desc { mark = alreadyCopied, copy = Just newVar }
219 -- Now we recursively copy the structure of the variable.
220 -- We have already marked the variable as copied, so we
221 -- will not repeat this work or crawl this variable again.
222 case structure desc of
223 Nothing ->
224 return newVar
226 Just term ->
227 do newTerm <- traverseTerm (makeCopy alreadyCopied) term
228 liftIO $ UF.modifyDescriptor newVar $ \desc ->
229 desc { structure = Just newTerm }
230 return newVar
233restore :: Int -> Variable -> StateT SolverState IO Variable
234restore alreadyCopied variable =
235 do desc <- liftIO $ UF.descriptor variable
236 case mark desc /= alreadyCopied of
237 True -> return variable
238 False ->
239 do restoredStructure <-
240 Traversable.traverse (traverseTerm (restore alreadyCopied)) (structure desc)
241 liftIO $ UF.modifyDescriptor variable $ \desc ->
242 desc { mark = noMark, rank = noRank, structure = restoredStructure }
243 return variable
246traverseTerm :: (Monad f, Applicative f) => (a -> f b) -> Term1 a -> f (Term1 b)
247traverseTerm f term =
248 case term of
249 App1 a b ->
250 App1 <$> f a <*> f b
252 Fun1 a b ->
253 Fun1 <$> f a <*> f b
255 Var1 x ->
256 Var1 <$> f x
258 EmptyRecord1 ->
259 return EmptyRecord1
261 Record1 fields ext ->
262 Record1
263 <$> Traversable.traverse (mapM f) fields
264 <*> f ext