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