@@ -127,15 +127,16 @@ flatten term =
127127 TermN maybeAlias t ->
128128 do flatStructure <- traverseTerm flatten t
129129 pool <- getPool
130− var <- liftIO . UF.fresh $ Descriptor
131− { structure = Just flatStructure
132− , rank = maxRank pool
133− , flex = Flexible
134− , name = Nothing
135− , copy = Nothing
136− , mark = noMark
137− , alias = maybeAlias
138− }
130+ var <-
131+ liftIO . UF.fresh $ Descriptor
132+ { structure = Just flatStructure
133+ , rank = maxRank pool
134+ , flex = Flexible
135+ , name = Nothing
136+ , copy = Nothing
137+ , mark = noMark
138+ , alias = maybeAlias
139+ }
139140 register var
140141
141142
@@ -151,50 +152,58 @@ makeCopy :: Int -> Variable -> StateT SolverState IO Variable
151152makeCopy alreadyCopied variable = do
152153 desc <- liftIO $ UF.descriptor variable
153154 case () of
154− () | mark desc == alreadyCopied ->
155− case copy desc of
156− Just v -> return v
157− Nothing -> error $ "Error copying type variable. This should be impossible." ++
158− " Please report an error to the github repo!"
159−
160− | rank desc /= noRank || flex desc == Constant ->
161− return variable
162−
163− | otherwise -> do
164− pool <- getPool
165− newVar <- liftIO $ UF.fresh $ Descriptor
166− { structure = Nothing
167− , rank = maxRank pool
168− , mark = noMark
169− , flex = case flex desc of
170− Is s -> Is s
171− _ -> Flexible
172− , copy = Nothing
173− , name = case flex desc of
174− Rigid -> Nothing
175− _ -> name desc
176− , alias = Nothing
177− }
178− register newVar
179−
180− -- Link the original variable to the new variable. This lets us
181− -- avoid making multiple copies of the variable we are instantiating.
182− --
183− -- Need to do this before recursively copying the structure of
184− -- the variable to avoid looping on cyclic terms.
185− liftIO $ UF.modifyDescriptor variable $ \desc ->
186− desc { mark = alreadyCopied, copy = Just newVar }
187−
188− -- Now we recursively copy the structure of the variable.
189− -- We have already marked the variable as copied, so we
190− -- will not repeat this work or crawl this variable again.
191− case structure desc of
192− Nothing -> return newVar
193− Just term -> do
194− newTerm <- traverseTerm (makeCopy alreadyCopied) term
195− liftIO $ UF.modifyDescriptor newVar $ \desc ->
196− desc { structure = Just newTerm }
197− return newVar
155+ () | mark desc == alreadyCopied ->
156+ case copy desc of
157+ Just v ->
158+ return v
159+ Nothing ->
160+ error $
161+ "Error copying type variable. This should be impossible." ++
162+ " Please report an error to the github repo!"
163+
164+ | rank desc /= noRank || flex desc == Constant ->
165+ return variable
166+
167+ | otherwise ->
168+ do pool <- getPool
169+ newVar <-
170+ liftIO $ UF.fresh $ Descriptor
171+ { structure = Nothing
172+ , rank = maxRank pool
173+ , mark = noMark
174+ , flex =
175+ case flex desc of
176+ Is s -> Is s
177+ _ -> Flexible
178+ , copy = Nothing
179+ , name =
180+ case flex desc of
181+ Rigid -> Nothing
182+ _ -> name desc
183+ , alias = Nothing
184+ }
185+ register newVar
186+
187+ -- Link the original variable to the new variable. This lets us
188+ -- avoid making multiple copies of the variable we are instantiating.
189+ --
190+ -- Need to do this before recursively copying the structure of
191+ -- the variable to avoid looping on cyclic terms.
192+ liftIO $ UF.modifyDescriptor variable $ \desc ->
193+ desc { mark = alreadyCopied, copy = Just newVar }
194+
195+ -- Now we recursively copy the structure of the variable.
196+ -- We have already marked the variable as copied, so we
197+ -- will not repeat this work or crawl this variable again.
198+ case structure desc of
199+ Nothing ->
200+ return newVar
201+
202+ Just term ->
203+ do newTerm <- traverseTerm (makeCopy alreadyCopied) term
204+ liftIO $ UF.modifyDescriptor newVar $ \desc ->
205+ desc { structure = Just newTerm }
206+ return newVar
198207
199208
200209restore :: Int -> Variable -> StateT SolverState IO Variable
@@ -213,10 +222,19 @@ restore alreadyCopied variable =
213222traverseTerm :: (Monad f, Applicative f) => (a -> f b) -> Term1 a -> f (Term1 b)
214223traverseTerm f term =
215224 case term of
216− App1 a b -> App1 <$> f a <*> f b
217− Fun1 a b -> Fun1 <$> f a <*> f b
218− Var1 x -> Var1 <$> f x
219− EmptyRecord1 -> return EmptyRecord1
220− Record1 fields ext ->
221− Record1 <$> Traversable.traverse (mapM f) fields <*> f ext
225+ App1 a b ->
226+ App1 <$> f a <*> f b
222227
228+ Fun1 a b ->
229+ Fun1 <$> f a <*> f b
230+
231+ Var1 x ->
232+ Var1 <$> f x
233+
234+ EmptyRecord1 ->
235+ return EmptyRecord1
236+
237+ Record1 fields ext ->
238+ Record1
239+ <$> Traversable.traverse (mapM f) fields
240+ <*> f ext