git.iko.soy/elk
on master help sign in
Update for new Type representation
e00a3f3Evan Czaplicki
src/Type/State.hs+38−27
compare with master
unifiedsplit
@@ -27,12 +27,12 @@ import Control.Monad.Trans (MonadIO, liftIO)
27import qualified Data.Map as Map
27import qualified Data.Map as Map
28import Data.Map ((!))
28import Data.Map ((!))
29import Data.Text (Text)
29import Data.Text (Text)
30−import qualified Data.UnionFind.IO as UF
31
30
32import qualified Reporting.Annotation as A
31import qualified Reporting.Annotation as A
33import qualified Reporting.Error.Type as Error
32import qualified Reporting.Error.Type as Error
34import qualified Reporting.Region as R
33import qualified Reporting.Region as R
35import Type.Type
34import Type.Type
35+import qualified Type.UnionFind as UF
36
36
37
37
38
38
@@ -214,30 +214,41 @@ flattenHelp aliasDict termN =
214 AliasN name args realType ->
214 AliasN name args realType ->
215 do flatArgs <- mapM (traverse (flattenHelp aliasDict)) args
215 do flatArgs <- mapM (traverse (flattenHelp aliasDict)) args
216 flatVar <- flattenHelp (Map.fromList flatArgs) realType
216 flatVar <- flattenHelp (Map.fromList flatArgs) realType
217− pool <- getPool
218− variable <-
219− liftIO $ UF.fresh $ Descriptor
220− { _content = Alias name flatArgs flatVar
217+ makeFlatType (Alias name flatArgs flatVar)
221− , _rank = _maxRank pool
222− , _mark = noMark
223− , _copy = Nothing
224− }
225− register variable
226
218
227 VarN v ->
219 VarN v ->
228 return v
220 return v
229
221
230− TermN term1 ->
222+ AppN a b ->
223+ do flatA <- flattenHelp aliasDict a
224+ flatB <- flattenHelp aliasDict b
225+ makeFlatType (Structure (App1 flatA flatB))
226+
227+ FunN a b ->
231− do variableTerm <- traverseTerm (flattenHelp aliasDict) term1
228+ do flatA <- flattenHelp aliasDict a
229+ flatB <- flattenHelp aliasDict b
230+ makeFlatType (Structure (Fun1 flatA flatB))
231+
232+ EmptyRecordN ->
233+ makeFlatType (Structure EmptyRecord1)
234+
235+ RecordN fields ext ->
236+ do flatFields <- traverse (flattenHelp aliasDict) fields
237+ flatExt <- flattenHelp aliasDict ext
238+ makeFlatType (Structure (Record1 flatFields flatExt))
239+
240+
241+makeFlatType :: Content -> Solver Variable
242+makeFlatType content =
232− pool <- getPool
243+ do pool <- getPool
233− variable <-
244+ variable <- liftIO $ UF.fresh $
234− liftIO $ UF.fresh $ Descriptor
245+ Descriptor
235− { _content = Structure variableTerm
246+ { _content = content
236− , _rank = _maxRank pool
247+ , _rank = _maxRank pool
237− , _mark = noMark
248+ , _mark = noMark
238− , _copy = Nothing
249+ , _copy = Nothing
239− }
250+ }
240− register variable
251+ register variable
241
252
242
253
243
254
@@ -309,7 +320,7 @@ makeCopyHelp (Descriptor content rank mark copy) alreadyCopiedMark variable =
309 -- will not repeat this work or crawl this variable again.
320 -- will not repeat this work or crawl this variable again.
310 case content of
321 case content of
311 Structure term ->
322 Structure term ->
312− do newTerm <- traverseTerm (makeCopy alreadyCopiedMark) term
323+ do newTerm <- traverseFlatType (makeCopy alreadyCopiedMark) term
313 setContent (Structure newTerm)
324 setContent (Structure newTerm)
314
325
315 Atom _ ->
326 Atom _ ->
@@ -384,7 +395,7 @@ restoreContent alreadyCopiedMark content =
384 in
395 in
385 case content of
396 case content of
386 Structure term ->
397 Structure term ->
387− Structure <$> traverseTerm go term
398+ Structure <$> traverseFlatType go term
388
399
389 Atom _ ->
400 Atom _ ->
390 return content
401 return content
@@ -402,12 +413,12 @@ restoreContent alreadyCopiedMark content =
402
413
403
414
404
415
405−-- TERM TRAVERSAL
416+-- TRAVERSE FLAT TYPE
406
417
407
418
408−traverseTerm :: (a -> Solver b) -> Term1 a -> Solver (Term1 b)
419+traverseFlatType :: (Variable -> Solver Variable) -> FlatType -> Solver FlatType
409−traverseTerm f term =
420+traverseFlatType f flatType =
410− case term of
421+ case flatType of
411 App1 a b ->
422 App1 a b ->
412 liftM2 App1 (f a) (f b)
423 liftM2 App1 (f a) (f b)
413
424