@@ -1,155 +1,221 @@
11{-# OPTIONS_GHC -Wall #-}
22{-# LANGUAGE OverloadedStrings #-}
3−module Type.Solve (solve) where
3+module Type.Solve
4+ ( run
5+ )
6+ where
7+
48
59import Control.Monad
6−import Control.Monad.Except (ExceptT, liftIO, throwError)
710import qualified Data.Map.Strict as Map
8−import qualified Data.Text as Text
11+import Data.Map.Strict ((!))
912import qualified Data.Vector as Vector
1013import qualified Data.Vector.Mutable as MVector
1114
12−import qualified AST.Module.Name as ModuleName
15+import qualified AST.Canonical as Can
16+import qualified Elm.Name as N
1317import qualified Reporting.Annotation as A
1418import qualified Reporting.Error.Type as Error
1519import qualified Type.Occurs as Occurs
16−import qualified Type.State as TS
17−import Type.Constraint (Constraint(..), Scheme(..))
20+import Type.Constraint as Con
1821import Type.Type as Type
19−import Type.Unify
22+import qualified Type.Unify as Unify
2023import qualified Type.UnionFind as UF
2124
2225
2326
24−-- SOLVER
25−
26−
27−solve :: Constraint -> ExceptT [A.Located Error.Error] IO TS.State
28−solve constraint =
29− {-# SCC elm_compiler_type_solve #-}
30− do state <- liftIO (TS.run (actuallySolve constraint))
31− case TS._errors state of
32− [] ->
33− return state
34−
35− errors ->
36− throwError errors
37−
38−
39−actuallySolve :: Constraint -> TS.Solver ()
40−actuallySolve constraint =
41− case constraint of
42− CTrue ->
43− return ()
44−
45− CSaveEnv ->
46− TS.saveLocalEnv
47−
48− CEqual hint region term1 term2 ->
49− do t1 <- TS.flatten term1
50− t2 <- TS.flatten term2
51− unify hint region t1 t2
27+-- RUN
5228
53− CAnd cs ->
54− mapM_ actuallySolve cs
5529
56− CLet [Scheme [] fqs constraint' _] CTrue ->
57− do oldEnv <- TS.getEnv
58− TS.introduce fqs
59− actuallySolve constraint'
60− TS.modifyEnv (\_ -> oldEnv)
30+run :: Constraint -> IO (Either [Error.Error] Env)
31+run constraint =
32+ do pools <- MVector.replicate 16 []
6133
62− CLet schemes constraint' ->
63− do oldEnv <- TS.getEnv
64− headers <- Map.unions <$> mapM solveScheme schemes
65− TS.modifyEnv $ \env -> Map.union headers env
66− actuallySolve constraint'
67− mapM_ occurs $ Map.toList headers
68− TS.modifyEnv (\_ -> oldEnv)
34+ (State env _ errors) <-
35+ solve Map.empty outermostRank pools emptyState constraint
6936
70− CInstance region name term ->
71− do env <- TS.getEnv
72− freshCopy <-
73− case Map.lookup name env of
74− Just (A.A _ tipe) ->
75− TS.copy tipe
76−
77− Nothing ->
78− if ModuleName.isKernel name then
79− liftIO mkFlexVar
37+ case errors of
38+ [] ->
39+ return $ Right env
8040
81− else
82− error ("Could not find `" ++ Text.unpack name ++ "` when solving type constraints.")
41+ _ ->
42+ return $ Left errors
8343
84− t <- TS.flatten term
85− unify (Error.Instance name) region freshCopy t
8644
8745
46+{-# NOINLINE emptyState #-}
47+emptyState :: State
48+emptyState =
49+ State Map.empty (nextMark noMark) []
8850
89−-- SOLVE SCHEMES
9051
9152
92−solveScheme :: Scheme -> TS.Solver TS.Env
93−solveScheme scheme =
94− let
95− flatten (A.A region term) =
96− A.A region <$> TS.flatten term
97− in
98− case scheme of
99− Scheme [] [] constraint header ->
100− do actuallySolve constraint
101− traverse flatten header
102−
103− Scheme rigidQuantifiers flexQuantifiers constraint header ->
104− -- work in the next pool for this scheme's constraints
105− solveSchemeHelp rigidQuantifiers flexQuantifiers $
106− do flatHeader <- traverse flatten header
107− actuallySolve constraint
108− return flatHeader
109−
53+-- SOLVER
11054
11155
112−solveSchemeHelp :: [Variable] -> [Variable] -> TS.Solver a -> TS.Solver a
113−solveSchemeHelp rigidQuantifiers flexQuantifiers (TS.Solver stepState) =
114− TS.Solver $ \state@(TS.SS _ _ rank oldPools _ _) ->
115− do
116− -- push pool
117− let nextRank = rank + 1
118− let poolsLength = MVector.length oldPools
56+type Env =
57+ Map.Map N.Name Variable
11958
120− pools <-
121− if nextRank < poolsLength
122− then return oldPools
123− else MVector.grow oldPools poolsLength
12459
125− -- introduce quantifiers
126− let allQuantifiers = rigidQuantifiers ++ flexQuantifiers
127− forM_ allQuantifiers $ \var ->
128− UF.modifyDescriptor var $ \(Descriptor content _ mark copy) ->
129− Descriptor content nextRank mark copy
130− MVector.write pools nextRank allQuantifiers
60+type Pools =
61+ MVector.IOVector [Variable]
13162
132− -- run solver in next pool
133− (value, TS.SS env savedEnv _ _ mark errors) <- stepState (state { TS._rank = nextRank })
13463
135− -- pop pool
136− let youngMark = mark
137− let visitMark = nextMark mark
138− let finalMark = nextMark visitMark
139− generalize youngMark visitMark nextRank pools
140− MVector.write pools nextRank []
64+data State =
65+ State
66+ { _env :: Env
67+ , _mark :: Mark
68+ , _errors :: [Error.Error]
69+ }
14170
142− -- check that things went well
143− mapM_ isGeneric rigidQuantifiers
14471
145− -- return result with pool popped
146− return ( value, TS.SS env savedEnv rank pools finalMark errors )
72+solve :: Env -> Int -> Pools -> State -> Constraint -> IO State
73+solve env rank pools state constraint =
74+ case constraint of
75+ CTrue ->
76+ return state
77+
78+ CSaveTheEnvironment ->
79+ return (state { _env = env })
80+
81+ CEqual region category tipe expectation ->
82+ do actual <- typeToVariable rank pools tipe
83+ expected <- expectedToVariable rank pools expectation
84+ answer <- Unify.unify actual expected
85+ case answer of
86+ Unify.Ok vars ->
87+ do introduce rank pools vars
88+ return state
89+
90+ Unify.Err vars problem actualType expectedType ->
91+ do introduce rank pools vars
92+ return $ addError state $
93+ Error.Mismatch
94+ (Error.BadExpr region category actualType)
95+ (Con.typeReplace expectation expectedType)
96+ problem
97+
98+ CLookup region name expectation ->
99+ do actual <- makeCopy rank pools (env ! name)
100+ expected <- expectedToVariable rank pools expectation
101+ answer <- Unify.unify actual expected
102+ case answer of
103+ Unify.Ok vars ->
104+ do introduce rank pools vars
105+ return state
106+
107+ Unify.Err vars problem actualType expectedType ->
108+ do introduce rank pools vars
109+ return $ addError state $
110+ Error.Mismatch
111+ (Error.BadLocal region name actualType)
112+ (Con.typeReplace expectation expectedType)
113+ problem
114+
115+ CInstance region funcName (Can.Forall freeVars srcType) expectation ->
116+ do actual <- srcTypeToVariable rank pools freeVars srcType
117+ expected <- expectedToVariable rank pools expectation
118+ answer <- Unify.unify actual expected
119+ case answer of
120+ Unify.Ok vars ->
121+ do introduce rank pools vars
122+ return state
123+
124+ Unify.Err vars problem actualType expectedType ->
125+ do introduce rank pools vars
126+ return $ addError state $
127+ Error.Mismatch
128+ (Error.BadForeign region funcName actualType)
129+ (Con.typeReplace expectation expectedType)
130+ problem
131+
132+ CPattern region category tipe expectation ->
133+ do actual <- typeToVariable rank pools tipe
134+ expected <- patternExpectationToVariable rank pools expectation
135+ answer <- Unify.unify actual expected
136+ case answer of
137+ Unify.Ok vars ->
138+ do introduce rank pools vars
139+ return state
140+
141+ Unify.Err vars problem actualType expectedType ->
142+ do introduce rank pools vars
143+ return $ addError state $
144+ Error.BadPattern region category actualType
145+ (Con.ptypeReplace expectation expectedType)
146+ problem
147+
148+ CAnd constraints ->
149+ foldM (solve env rank pools) state constraints
150+
151+ CBranch a b eqCon makeNotEqCon ->
152+ do aVar <- typeToVariable rank pools a
153+ bVar <- typeToVariable rank pools b
154+ answer <- Unify.unify aVar bVar
155+ case answer of
156+ Unify.Ok vars ->
157+ do introduce rank pools vars
158+ solve env rank pools state eqCon
159+
160+ Unify.Err vars _ _ _ ->
161+ do introduce rank pools vars
162+ solve env rank pools state =<< makeNotEqCon
163+
164+ CLet [] flexs _ headerCon CTrue ->
165+ do introduce rank pools flexs
166+ solve env rank pools state headerCon
167+
168+ CLet [] [] header headerCon subCon ->
169+ do state1 <- solve env rank pools state headerCon
170+ locals <- traverse (A.traverse (typeToVariable rank pools)) header
171+ let newEnv = Map.union env (Map.map A.drop locals)
172+ state2 <- solve newEnv rank pools state1 subCon
173+ foldM occurs state2 $ Map.toList locals
174+
175+ CLet rigids flexs header headerCon subCon ->
176+ do
177+ -- work in the next pool to localize header
178+ let nextRank = rank + 1
179+ let poolsLength = MVector.length pools
180+ nextPools <-
181+ if nextRank < poolsLength
182+ then return pools
183+ else MVector.grow pools poolsLength
184+
185+ -- introduce variables
186+ let vars = rigids ++ flexs
187+ forM_ vars $ \var ->
188+ UF.modify var $ \(Descriptor content _ mark copy) ->
189+ Descriptor content nextRank mark copy
190+ MVector.write nextPools nextRank vars
191+
192+ -- run solver in next pool
193+ locals <- traverse (A.traverse (typeToVariable rank nextPools)) header
194+ (State savedEnv mark errors) <-
195+ solve env nextRank nextPools state headerCon
196+
197+ let youngMark = mark
198+ let visitMark = nextMark youngMark
199+ let finalMark = nextMark visitMark
200+
201+ -- pop pool
202+ generalize youngMark visitMark nextRank nextPools
203+ MVector.write nextPools nextRank []
204+
205+ -- check that things went well
206+ mapM_ isGeneric rigids
207+
208+ let newEnv = Map.union env (Map.map A.drop locals)
209+ let tempState = State savedEnv finalMark errors
210+ newState <- solve newEnv nextRank nextPools tempState subCon
211+
212+ foldM occurs newState (Map.toList locals)
147213
148214
149215-- Check that a variable has rank == noRank, meaning that it can be generalized.
150216isGeneric :: Variable -> IO ()
151217isGeneric var =
152− do (Descriptor _ rank _ _) <- UF.descriptor var
218+ do (Descriptor _ rank _ _) <- UF.get var
153219 if rank == noRank
154220 then return ()
155221 else crash "Unable to generalize a type variable. It is not unranked."
@@ -165,22 +231,58 @@ crash msg =
165231
166232
167233
168−-- OCCURS CHECK
234+-- EXPECTATIONS TO VARIABLE
235+
236+
237+expectedToVariable :: Int -> Pools -> Expected Type -> IO Variable
238+expectedToVariable rank pools expectation =
239+ typeToVariable rank pools $
240+ case expectation of
241+ NoExpectation tipe ->
242+ tipe
243+
244+ FromContext _ _ tipe ->
245+ tipe
246+
247+ FromAnnotation _ _ _ tipe ->
248+ tipe
249+
250+
251+patternExpectationToVariable :: Int -> Pools -> PExpected Type -> IO Variable
252+patternExpectationToVariable rank pools expectation =
253+ typeToVariable rank pools $
254+ case expectation of
255+ PNoExpectation tipe ->
256+ tipe
257+
258+ PFromContext _ _ tipe ->
259+ tipe
260+
261+
169262
263+-- ERROR HELPERS
170264
171−occurs :: (Text.Text, A.Located Variable) -> TS.Solver ()
172−occurs (name, A.A region variable) =
173− {-# SCC elm_compiler_type_occurs #-}
174− do hasOccurred <- liftIO $ Occurs.occurs variable
175− case hasOccurred of
176− False ->
177− return ()
178265
179− True ->
180− do overallType <- liftIO $ Type.toSrcType variable
181− (Descriptor _ rank mark copy) <- liftIO $ UF.descriptor variable
182− liftIO $ UF.setDescriptor variable (Descriptor (Error "∞") rank mark copy)
183− TS.addError region (Error.InfiniteType (Right name) overallType)
266+addError :: State -> Error.Error -> State
267+addError (State savedEnv rank errors) err =
268+ State savedEnv rank (err:errors)
269+
270+
271+
272+-- OCCURS CHECK
273+
274+
275+occurs :: State -> (N.Name, A.Located Variable) -> IO State
276+occurs state (_name, A.At _region variable) =
277+ do hasOccurred <- Occurs.occurs variable
278+ if hasOccurred
279+ then
280+ do overallType <- Type.toSrcType variable
281+ (Descriptor _ rank mark copy) <- UF.get variable
282+ UF.set variable (Descriptor (Error "∞") rank mark copy)
283+ return $ state { _errors = Error.InfiniteType overallType : _errors state }
284+ else
285+ return state
184286
185287
186288
@@ -190,11 +292,9 @@ occurs (name, A.A region variable) =
190292{-| Every variable has rank less than or equal to the maxRank of the pool.
191293This sorts variables into the young and old pools accordingly.
192294-}
193−generalize :: Mark -> Mark -> Int -> TS.Pools -> IO ()
295+generalize :: Mark -> Mark -> Int -> Pools -> IO ()
194296generalize youngMark visitMark youngRank pools =
195− {-# SCC elm_compiler_type_generalize #-}
196− do
197− youngVars <- MVector.read pools youngRank
297+ do youngVars <- MVector.read pools youngRank
198298 rankTable <- poolToRankTable youngMark youngRank youngVars
199299
200300 -- get the ranks right for each entry.
@@ -210,7 +310,7 @@ generalize youngMark visitMark youngRank pools =
210310 if isRedundant
211311 then return ()
212312 else
213− do (Descriptor _ rank _ _) <- UF.descriptor var
313+ do (Descriptor _ rank _ _) <- UF.get var
214314 MVector.modify pools (var:) rank
215315
216316 -- For variables with rank youngRank
@@ -221,12 +321,10 @@ generalize youngMark visitMark youngRank pools =
221321 if isRedundant
222322 then return ()
223323 else
224− do (Descriptor content rank mark copy) <- liftIO $ UF.descriptor var
324+ do (Descriptor content rank mark copy) <- UF.get var
225325 if rank < youngRank
226− then
227− MVector.modify pools (var:) rank
228− else
229− UF.setDescriptor var $ Descriptor content noRank mark copy
326+ then MVector.modify pools (var:) rank
327+ else UF.set var $ Descriptor content noRank mark copy
230328
231329
232330poolToRankTable :: Mark -> Int -> [Variable] -> IO (Vector.Vector [Variable])
@@ -235,8 +333,8 @@ poolToRankTable youngMark youngRank youngInhabitants =
235333
236334 -- Sort the youngPool variables into buckets by rank.
237335 forM_ youngInhabitants $ \var ->
238− do (Descriptor content rank _ copy) <- UF.descriptor var
239− UF.setDescriptor var (Descriptor content rank youngMark copy)
336+ do (Descriptor content rank _ copy) <- UF.get var
337+ UF.set var (Descriptor content rank youngMark copy)
240338 MVector.modify mutableTable (var:) rank
241339
242340 Vector.unsafeFreeze mutableTable
@@ -252,12 +350,12 @@ poolToRankTable youngMark youngRank youngInhabitants =
252350adjustRank :: Mark -> Mark -> Int -> Variable -> IO Int
253351adjustRank youngMark visitMark groupRank var =
254352 {-# SCC elm_compiler_type_adjust #-}
255− do (Descriptor content rank mark copy) <- UF.descriptor var
353+ do (Descriptor content rank mark copy) <- UF.get var
256354 if mark == youngMark then
257355 do -- Set the variable as marked first because it may be cyclic.
258− UF.setDescriptor var $ Descriptor content rank visitMark copy
356+ UF.set var $ Descriptor content rank visitMark copy
259357 maxRank <- adjustRankContent youngMark visitMark groupRank content
260− UF.setDescriptor var $ Descriptor content maxRank visitMark copy
358+ UF.set var $ Descriptor content maxRank visitMark copy
261359 return maxRank
262360
263361 else if mark == visitMark then
@@ -266,7 +364,7 @@ adjustRank youngMark visitMark groupRank var =
266364 else
267365 do let minRank = min groupRank rank
268366 -- TODO how can minRank ever be groupRank?
269− UF.setDescriptor var $ Descriptor content minRank visitMark copy
367+ UF.set var $ Descriptor content minRank visitMark copy
270368 return minRank
271369
272370
@@ -325,3 +423,282 @@ adjustRankContent youngMark visitMark groupRank content =
325423 Error _ ->
326424 return groupRank
327425
426+
427+
428+-- REGISTER VARIABLES
429+
430+
431+introduce :: Int -> Pools -> [Variable] -> IO ()
432+introduce rank pools variables =
433+ do MVector.modify pools (variables++) rank
434+ forM_ variables $ \var ->
435+ UF.modify var $ \(Descriptor content _ mark copy) ->
436+ Descriptor content rank mark copy
437+
438+
439+
440+-- TYPE TO VARIABLE
441+
442+
443+typeToVariable :: Int -> Pools -> Type -> IO Variable
444+typeToVariable rank pools tipe =
445+ typeToVar rank pools Map.empty tipe
446+
447+
448+typeToVar :: Int -> Pools -> Map.Map N.Name Variable -> Type -> IO Variable
449+typeToVar rank pools aliasDict tipe =
450+ let go = typeToVar rank pools aliasDict in
451+ case tipe of
452+ VarN v ->
453+ return v
454+
455+ AppN home name args ->
456+ do argVars <- traverse go args
457+ register rank pools (Structure (App1 home name argVars))
458+
459+ FunN a b ->
460+ do aVar <- go a
461+ bVar <- go b
462+ register rank pools (Structure (Fun1 aVar bVar))
463+
464+ AliasN home name args aliasType ->
465+ do argVars <- traverse (traverse go) args
466+ aliasVar <- typeToVar rank pools (Map.fromList argVars) aliasType
467+ register rank pools (Alias home name argVars aliasVar)
468+
469+ PlaceHolder name ->
470+ return (aliasDict ! name)
471+
472+ RecordN fields ext ->
473+ do fieldVars <- traverse go fields
474+ extVar <- go ext
475+ register rank pools (Structure (Record1 fieldVars extVar))
476+
477+ EmptyRecordN ->
478+ register rank pools emptyRecord1
479+
480+ UnitN ->
481+ register rank pools unit1
482+
483+ TupleN a b c ->
484+ do aVar <- go a
485+ bVar <- go b
486+ cVar <- traverse go c
487+ register rank pools (Structure (Tuple1 aVar bVar cVar))
488+
489+
490+register :: Int -> Pools -> Content -> IO Variable
491+register rank pools content =
492+ do var <- UF.fresh (Descriptor content rank noMark Nothing)
493+ MVector.modify pools (var:) rank
494+ return var
495+
496+
497+{-# NOINLINE emptyRecord1 #-}
498+emptyRecord1 :: Content
499+emptyRecord1 =
500+ Structure EmptyRecord1
501+
502+
503+{-# NOINLINE unit1 #-}
504+unit1 :: Content
505+unit1 =
506+ Structure Unit1
507+
508+
509+
510+-- SOURCE TYPE TO VARIABLE
511+
512+
513+srcTypeToVariable :: Int -> Pools -> Map.Map N.Name () -> Can.Type -> IO Variable
514+srcTypeToVariable rank pools freeVars srcType =
515+ let
516+ makeVar name _ =
517+ UF.fresh (Descriptor (FlexVar (Just name)) rank noMark Nothing)
518+ in
519+ do flexVars <- Map.traverseWithKey makeVar freeVars
520+ MVector.modify pools (Map.elems flexVars ++) rank
521+ srcTypeToVar rank pools flexVars srcType
522+
523+
524+srcTypeToVar :: Int -> Pools -> Map.Map N.Name Variable -> Can.Type -> IO Variable
525+srcTypeToVar rank pools flexVars srcType =
526+ let go = srcTypeToVar rank pools flexVars in
527+ case srcType of
528+ Can.TLambda argument result ->
529+ do argVar <- go argument
530+ resultVar <- go result
531+ register rank pools (Structure (Fun1 argVar resultVar))
532+
533+ Can.TVar name ->
534+ return (flexVars ! name)
535+
536+ Can.TType home name args ->
537+ do argVars <- traverse go args
538+ register rank pools (Structure (App1 home name argVars))
539+
540+ Can.TRecord fields maybeExt ->
541+ do fieldVars <- traverse go fields
542+ extVar <- maybe (register rank pools emptyRecord1) go maybeExt
543+ register rank pools (Structure (Record1 fieldVars extVar))
544+
545+ Can.TUnit ->
546+ register rank pools unit1
547+
548+ Can.TTuple a b c ->
549+ do aVar <- go a
550+ bVar <- go b
551+ cVar <- traverse go c
552+ register rank pools (Structure (Tuple1 aVar bVar cVar))
553+
554+ Can.TAlias home name args aliasType ->
555+ do argVars <- traverse (traverse go) args
556+ aliasVar <-
557+ case aliasType of
558+ Can.Holey tipe ->
559+ srcTypeToVar rank pools (Map.fromList argVars) tipe
560+
561+ Can.Filled tipe ->
562+ go tipe
563+
564+ register rank pools (Alias home name argVars aliasVar)
565+
566+
567+
568+-- COPY
569+
570+
571+makeCopy :: Int -> Pools -> Variable -> IO Variable
572+makeCopy rank pools var =
573+ do copy <- makeCopyHelp rank pools var
574+ _ <- restore var
575+ return copy
576+
577+
578+makeCopyHelp :: Int -> Pools -> Variable -> IO Variable
579+makeCopyHelp maxRank pools variable =
580+ do (Descriptor content rank _ maybeCopy) <-
581+ UF.get variable
582+
583+ case maybeCopy of
584+ Just copy ->
585+ return copy
586+
587+ Nothing ->
588+ if rank /= noRank then
589+ return variable
590+
591+ else
592+ do let makeDescriptor c = Descriptor c maxRank noMark Nothing
593+ copy <- UF.fresh $ makeDescriptor content
594+ MVector.modify pools (copy:) maxRank
595+
596+ -- Link the original variable to the new variable. This lets us
597+ -- avoid making multiple copies of the variable we are instantiating.
598+ --
599+ -- Need to do this before recursively copying to avoid looping.
600+ UF.set variable $
601+ Descriptor content rank noMark (Just copy)
602+
603+ -- Now we recursively copy the content of the variable.
604+ -- We have already marked the variable as copied, so we
605+ -- will not repeat this work or crawl this variable again.
606+ case content of
607+ Structure term ->
608+ do newTerm <- traverseFlatType (makeCopyHelp maxRank pools) term
609+ UF.set copy $ makeDescriptor (Structure newTerm)
610+ return copy
611+
612+ FlexVar _ ->
613+ return copy
614+
615+ FlexSuper _ _ ->
616+ return copy
617+
618+ RigidVar name ->
619+ do UF.set copy $ makeDescriptor $ FlexVar (Just name)
620+ return copy
621+
622+ RigidSuper super name ->
623+ do UF.set copy $ makeDescriptor $ FlexSuper super (Just name)
624+ return copy
625+
626+ Alias home name args realType ->
627+ do newArgs <- mapM (traverse (makeCopyHelp maxRank pools)) args
628+ newRealType <- makeCopyHelp maxRank pools realType
629+ UF.set copy $ makeDescriptor (Alias home name newArgs newRealType)
630+ return copy
631+
632+ Error _ ->
633+ return copy
634+
635+
636+
637+-- RESTORE
638+
639+
640+restore :: Variable -> IO Variable
641+restore variable =
642+ do (Descriptor content _rank _mark maybeCopy) <- UF.get variable
643+ case maybeCopy of
644+ Nothing ->
645+ return variable
646+
647+ Just _ ->
648+ do restoredContent <- restoreContent content
649+ UF.set variable $
650+ Descriptor restoredContent noRank noMark Nothing
651+ return variable
652+
653+
654+restoreContent :: Content -> IO Content
655+restoreContent content =
656+ case content of
657+ FlexVar _ ->
658+ return content
659+
660+ FlexSuper _ _ ->
661+ return content
662+
663+ RigidVar _ ->
664+ return content
665+
666+ RigidSuper _ _ ->
667+ return content
668+
669+ Structure term ->
670+ Structure <$> traverseFlatType restore term
671+
672+ Alias home name args var ->
673+ Alias home name
674+ <$> mapM (traverse restore) args
675+ <*> restore var
676+
677+ Error _ ->
678+ return content
679+
680+
681+
682+-- TRAVERSE FLAT TYPE
683+
684+
685+traverseFlatType :: (Variable -> IO Variable) -> FlatType -> IO FlatType
686+traverseFlatType f flatType =
687+ case flatType of
688+ App1 home name args ->
689+ liftM (App1 home name) (traverse f args)
690+
691+ Fun1 a b ->
692+ liftM2 Fun1 (f a) (f b)
693+
694+ EmptyRecord1 ->
695+ pure EmptyRecord1
696+
697+ Record1 fields ext ->
698+ liftM2 Record1 (traverse f fields) (f ext)
699+
700+ Unit1 ->
701+ pure Unit1
702+
703+ Tuple1 a b cs ->
704+ liftM3 Tuple1 (f a) (f b) (traverse f cs)