@@ -16,180 +16,186 @@ import qualified AST.Annotation as A
16-- | Every variable has rank less than or equal to the maxRank of the pool.
16-- | Every variable has rank less than or equal to the maxRank of the pool.
17-- This sorts variables into the young and old pools accordingly.
17-- This sorts variables into the young and old pools accordingly.
18generalize :: TS.Pool -> StateT TS.SolverState IO ()
18generalize :: TS.Pool -> StateT TS.SolverState IO ()
19−generalize youngPool = do
19+generalize youngPool =
20− youngMark <- TS.uniqueMark
20+ do youngMark <- TS.uniqueMark
21− let youngRank = TS.maxRank youngPool
21+ let youngRank = TS.maxRank youngPool
22− insert dict var = do
22+ insert dict var = do
23− descriptor <- liftIO $ UF.descriptor var
23+ descriptor <- liftIO $ UF.descriptor var
24− liftIO $ UF.modifyDescriptor var (\desc -> desc { mark = youngMark })
24+ liftIO $ UF.modifyDescriptor var (\desc -> desc { mark = youngMark })
25− return $ Map.insertWith (++) (rank descriptor) [var] dict
25+ return $ Map.insertWith (++) (rank descriptor) [var] dict
27− -- Sort the youngPool variables by rank.
27+ -- Sort the youngPool variables by rank.
28− rankDict <- foldM insert Map.empty (TS.inhabitants youngPool)
28+ rankDict <- foldM insert Map.empty (TS.inhabitants youngPool)
30− -- get the ranks right for each entry.
30+ -- get the ranks right for each entry.
31− -- start at low ranks so that we only have to pass
31+ -- start at low ranks so that we only have to pass
32− -- over the information once.
32+ -- over the information once.
33− visitedMark <- TS.uniqueMark
33+ visitedMark <- TS.uniqueMark
34− forM (Map.toList rankDict) $ \(poolRank, vars) ->
34+ forM (Map.toList rankDict) $ \(poolRank, vars) ->
35− mapM (adjustRank youngMark visitedMark poolRank) vars
35+ mapM (adjustRank youngMark visitedMark poolRank) vars
37− -- For variables that have rank lowerer than youngRank, register them in
37+ -- For variables that have rank lowerer than youngRank, register them in
38− -- the old pool if they are not redundant.
38+ -- the old pool if they are not redundant.
39− let registerIfNotRedundant var = do
39+ let registerIfNotRedundant var = do
40− isRedundant <- liftIO $ UF.redundant var
40+ isRedundant <- liftIO $ UF.redundant var
41− if isRedundant then return var else TS.register var
41+ if isRedundant then return var else TS.register var
43− let rankDict' = Map.delete youngRank rankDict
43+ let rankDict' = Map.delete youngRank rankDict
44− Traversable.traverse (mapM registerIfNotRedundant) rankDict'
44+ Traversable.traverse (mapM registerIfNotRedundant) rankDict'
46− -- For variables with rank youngRank
46+ -- For variables with rank youngRank
47− -- If rank < youngRank: register in oldPool
47+ -- If rank < youngRank: register in oldPool
48− -- otherwise generalize
48+ -- otherwise generalize
49− let registerIfLowerRank var = do
49+ let registerIfLowerRank var = do
50− isRedundant <- liftIO $ UF.redundant var
50+ isRedundant <- liftIO $ UF.redundant var
51− case isRedundant of
51+ case isRedundant of
54− desc <- liftIO $ UF.descriptor var
55− case rank desc < youngRank of
56− True -> TS.register var >> return ()
52+ True -> return ()
57 False -> do
53 False -> do
54+ desc <- liftIO $ UF.descriptor var
55+ case rank desc < youngRank of
56+ True -> TS.register var >> return ()
58− let flex' = case flex desc of { Flexible -> Rigid ; other -> other }
58+ let flex' = case flex desc of { Flexible -> Rigid ; other -> other }
59− liftIO $ UF.setDescriptor var (desc { rank = noRank, flex = flex' })
59+ liftIO $ UF.setDescriptor var (desc { rank = noRank, flex = flex' })
61− mapM_ registerIfLowerRank (Map.findWithDefault [] youngRank rankDict)
61+ mapM_ registerIfLowerRank (Map.findWithDefault [] youngRank rankDict)
64-- adjust the ranks of variables such that ranks never increase as you
64-- adjust the ranks of variables such that ranks never increase as you
65-- move deeper into a variable.
65-- move deeper into a variable.
66adjustRank :: Int -> Int -> Int -> Variable -> StateT TS.SolverState IO Int
66adjustRank :: Int -> Int -> Int -> Variable -> StateT TS.SolverState IO Int
67adjustRank youngMark visitedMark groupRank var =
67adjustRank youngMark visitedMark groupRank var =
68− do descriptor <- liftIO $ UF.descriptor var
68+ do descriptor <- liftIO $ UF.descriptor var
69− case () of
69+ case () of
70− () | mark descriptor == youngMark ->
70+ () | mark descriptor == youngMark ->
71− do -- Set the variable as marked first because it may be cyclic.
71+ do -- Set the variable as marked first because it may be cyclic.
72− liftIO $ UF.modifyDescriptor var $ \desc ->
72+ liftIO $ UF.modifyDescriptor var $ \desc ->
73− desc { mark = visitedMark }
73+ desc { mark = visitedMark }
74− rank' <- maybe (return groupRank) adjustTerm (structure descriptor)
74+ rank' <- maybe (return groupRank) adjustTerm (structure descriptor)
75− liftIO $ UF.modifyDescriptor var $ \desc ->
75+ liftIO $ UF.modifyDescriptor var $ \desc ->
76− desc { rank = rank' }
76+ desc { rank = rank' }
77− return rank'
77+ return rank'
79 | mark descriptor /= visitedMark ->
79 | mark descriptor /= visitedMark ->
80− do let rank' = min groupRank (rank descriptor)
80+ do let rank' = min groupRank (rank descriptor)
81− liftIO $ UF.setDescriptor var (descriptor { mark = visitedMark, rank = rank' })
81+ liftIO $ UF.setDescriptor var (descriptor { mark = visitedMark, rank = rank' })
82− return rank'
82+ return rank'
84− | otherwise -> return (rank descriptor)
85+ return (rank descriptor)
87− adjust = adjustRank youngMark visitedMark groupRank
87+ adjust = adjustRank youngMark visitedMark groupRank
89− adjustTerm term =
89+ adjustTerm term =
90− case term of
90+ case term of
91− App1 a b -> max `liftM` adjust a `ap` adjust b
91+ App1 a b -> max `liftM` adjust a `ap` adjust b
92− Fun1 a b -> max `liftM` adjust a `ap` adjust b
92+ Fun1 a b -> max `liftM` adjust a `ap` adjust b
93− Var1 x -> adjust x
93+ Var1 x -> adjust x
94− EmptyRecord1 -> return outermostRank
94+ EmptyRecord1 -> return outermostRank
95− Record1 fields extension ->
95+ Record1 fields extension ->
96− do ranks <- mapM adjust (concat (Map.elems fields))
96+ do ranks <- mapM adjust (concat (Map.elems fields))
97− rnk <- adjust extension
97+ rnk <- adjust extension
98− return . maximum $ rnk : ranks
98+ return . maximum $ rnk : ranks
101solve :: TypeConstraint -> StateT TS.SolverState IO ()
101solve :: TypeConstraint -> StateT TS.SolverState IO ()
102solve (A.A region constraint) =
102solve (A.A region constraint) =
103 case constraint of
103 case constraint of
104− CTrue -> return ()
105+ return ()
106− CSaveEnv -> TS.saveLocalEnv
108+ TS.saveLocalEnv
108− CEqual term1 term2 -> do
110+ CEqual term1 term2 ->
109− t1 <- TS.flatten term1
111+ do t1 <- TS.flatten term1
110− t2 <- TS.flatten term2
112+ t2 <- TS.flatten term2
111− unify region t1 t2
113+ unify region t1 t2
113− CAnd cs -> mapM_ solve cs
116+ mapM_ solve cs
115− CLet [Scheme [] fqs constraint' _] (A.A _ CTrue) -> do
118+ CLet [Scheme [] fqs constraint' _] (A.A _ CTrue) ->
116− oldEnv <- TS.getEnv
119+ do oldEnv <- TS.getEnv
117− mapM TS.introduce fqs
120+ mapM TS.introduce fqs
118− solve constraint'
121+ solve constraint'
119− TS.modifyEnv (\_ -> oldEnv)
122+ TS.modifyEnv (\_ -> oldEnv)
121− CLet schemes constraint' -> do
124+ CLet schemes constraint' ->
122− oldEnv <- TS.getEnv
125+ do oldEnv <- TS.getEnv
123− headers <- Map.unions `fmap` mapM (solveScheme region) schemes
126+ headers <- Map.unions `fmap` mapM (solveScheme region) schemes
124− TS.modifyEnv $ \env -> Map.union headers env
127+ TS.modifyEnv $ \env -> Map.union headers env
125− solve constraint'
128+ solve constraint'
126− mapM Check.occurs $ Map.toList headers
129+ mapM Check.occurs $ Map.toList headers
127− TS.modifyEnv (\_ -> oldEnv)
130+ TS.modifyEnv (\_ -> oldEnv)
129− CInstance name term -> do
132+ CInstance name term ->
130− env <- TS.getEnv
133+ do env <- TS.getEnv
131− freshCopy <-
134+ freshCopy <-
132− case Map.lookup name env of
135+ case Map.lookup name env of
133− Just tipe -> TS.makeInstance tipe
136+ Just tipe -> TS.makeInstance tipe
135− | List.isPrefixOf "Native." name -> liftIO (variable Flexible)
138+ | List.isPrefixOf "Native." name -> liftIO (variable Flexible)
136− | otherwise ->
139+ | otherwise ->
137− error ("Could not find '" ++ name ++ "' when solving type constraints.")
140+ error ("Could not find '" ++ name ++ "' when solving type constraints.")
139− t <- TS.flatten term
142+ t <- TS.flatten term
140− unify region freshCopy t
143+ unify region freshCopy t
142solveScheme :: A.Region -> TypeScheme -> StateT TS.SolverState IO (Map.Map String Variable)
146solveScheme :: A.Region -> TypeScheme -> StateT TS.SolverState IO (Map.Map String Variable)
143solveScheme region scheme =
147solveScheme region scheme =
144 case scheme of
148 case scheme of
145− Scheme [] [] constraint header -> do
149+ Scheme [] [] constraint header ->
146− solve constraint
150+ do solve constraint
147− Traversable.traverse TS.flatten header
151+ Traversable.traverse TS.flatten header
149− Scheme rigidQuantifiers flexibleQuantifiers constraint header -> do
153+ Scheme rigidQuantifiers flexibleQuantifiers constraint header ->
150− let quantifiers = rigidQuantifiers ++ flexibleQuantifiers
154+ do let quantifiers = rigidQuantifiers ++ flexibleQuantifiers
151− oldPool <- TS.getPool
155+ oldPool <- TS.getPool
153− -- fill in a new pool when working on this scheme's constraints
157+ -- fill in a new pool when working on this scheme's constraints
154− freshPool <- TS.nextRankPool
158+ freshPool <- TS.nextRankPool
155− TS.switchToPool freshPool
159+ TS.switchToPool freshPool
156− mapM TS.introduce quantifiers
160+ mapM TS.introduce quantifiers
157− header' <- Traversable.traverse TS.flatten header
161+ header' <- Traversable.traverse TS.flatten header
158− solve constraint
162+ solve constraint
160− allDistinct region rigidQuantifiers
164+ allDistinct region rigidQuantifiers
161− youngPool <- TS.getPool
165+ youngPool <- TS.getPool
162− TS.switchToPool oldPool
166+ TS.switchToPool oldPool
163− generalize youngPool
167+ generalize youngPool
164− mapM (isGeneric region) rigidQuantifiers
168+ mapM (isGeneric region) rigidQuantifiers
165− return header'
169+ return header'
168-- Checks that all of the given variables belong to distinct equivalence classes.
172-- Checks that all of the given variables belong to distinct equivalence classes.
169-- Also checks that their structure is Nothing, so they represent a variable, not
173-- Also checks that their structure is Nothing, so they represent a variable, not
170-- a more complex term.
174-- a more complex term.
171allDistinct :: A.Region -> [Variable] -> StateT TS.SolverState IO ()
175allDistinct :: A.Region -> [Variable] -> StateT TS.SolverState IO ()
172−allDistinct region vars = do
176+allDistinct region vars =
173− seen <- TS.uniqueMark
177+ do seen <- TS.uniqueMark
174− let check var = do
178+ let check var = do
175− desc <- liftIO $ UF.descriptor var
179+ desc <- liftIO $ UF.descriptor var
176− case structure desc of
180+ case structure desc of
177− Just _ -> TS.addError region (Just msg) var var
181+ Just _ -> TS.addError region (Just msg) var var
178− where msg = "Cannot generalize something that is not a type variable."
182+ where msg = "Cannot generalize something that is not a type variable."
180− Nothing -> do
184+ Nothing -> do
181− if mark desc == seen
185+ if mark desc == seen
182− then let msg = "Duplicate variable during generalization."
186+ then let msg = "Duplicate variable during generalization."
183− in TS.addError region (Just msg) var var
187+ in TS.addError region (Just msg) var var
184− else return ()
188+ else return ()
185− liftIO $ UF.setDescriptor var (desc { mark = seen })
189+ liftIO $ UF.setDescriptor var (desc { mark = seen })
186− mapM_ check vars
190+ mapM_ check vars
188-- Check that a variable has rank == noRank, meaning that it can be generalized.
193-- Check that a variable has rank == noRank, meaning that it can be generalized.
189isGeneric :: A.Region -> Variable -> StateT TS.SolverState IO ()
194isGeneric :: A.Region -> Variable -> StateT TS.SolverState IO ()
190−isGeneric region var = do
195+isGeneric region var =
191− desc <- liftIO $ UF.descriptor var
196+ do desc <- liftIO $ UF.descriptor var
192− if rank desc == noRank
197+ if rank desc == noRank
193− then return ()
198+ then return ()
194− else let msg = "Unable to generalize a type variable. It is not unranked."
200+ let msg = "Unable to generalize a type variable. It is not unranked."
195− in TS.addError region (Just msg) var var
201+ in TS.addError region (Just msg) var var