@@ -2,33 +2,24 @@
22module Type.Solve where
33
44import Control.Monad
5+import Control.Monad.State
56import qualified Data.UnionFind.IO as UF
67import qualified Data.Array.IO as Array
7−import Data.Map as Map
8+import qualified Data.Map as Map
9+import qualified Data.Traversable as Traversable
810import qualified Data.Maybe as Maybe
911import Type.Type
1012import Type.Unify
11−import Type.Environment as Env
12−
13−-- Pool
14−-- Holds a bunch of variables
15−-- The rank of each variable is less than or equal to the pool's "number"
16−-- The young pool exists to make it possible to identify these vars in constant time.
17−
18−-- inhabitants :: Pool -> [Variable]
19−
20−data Pool = Pool {
21− maxRank :: Int,
22− inhabitants :: [Variable]
23−}
13+import qualified Type.Environment as Env
14+import qualified Type.State as TS
2415
2516register = undefined
2617
27−generalize :: Pool -> Pool -> IO [Variable]
18+generalize :: TS.Pool -> TS.Pool -> IO [Variable]
2819generalize oldPool youngPool = do
2920 let young = 0
3021 visited = 1
31− youngRank = maxRank youngPool
22+ youngRank = TS.maxRank youngPool
3223
3324 array' <- Array.newArray (0, youngRank) []
3425 let array = array' :: Array.IOArray Int [Variable]
@@ -36,7 +27,7 @@ generalize oldPool youngPool = do
3627 -- Insert all of the youngPool variables into the array.
3728 -- They are placed into a list at the index corresponding
3829 -- to their rank.
39− forM (inhabitants youngPool) $ \var -> do
30+ forM (TS.inhabitants youngPool) $ \var -> do
4031 desc <- UF.descriptor var
4132 vars <- Array.readArray array (rank desc)
4233 Array.writeArray array (rank desc) (var : vars)
@@ -86,50 +77,56 @@ traverse young visited k variable =
8677 return rank'
8778 else return (rank desc)
8879
89−success = return []
90−
91−chop = undefined
9280addTo = undefined
9381newPool = undefined
9482introduce = undefined
9583
96−solve env pool constraint =
97− case constraint of
98− CTrue -> success
84+solve :: TypeConstraint -> StateT TS.SolverState IO ()
85+solve constraint =
86+ case constraint of
87+ CTrue -> return ()
88+
89+ CEqual term1 term2 -> do
90+ t1 <- TS.flatten term1
91+ t2 <- TS.flatten term2
92+ unify t1 t2
9993
100− CEqual term1 term2 ->
101− unify (register pool) term1 term2
94+ CAnd cs -> mapM_ solve cs
10295
103− CAnd cs -> do
104− results <- mapM (solve env pool) cs
105− return (concat results)
96+ CLet [Scheme [] fqs constraint' _] CTrue -> do
97+ mapM_ introduce fqs
98+ solve constraint'
10699
107− CLet schemes constraint' -> do
108− env' <- foldM (\env' scheme -> addTo env' `liftM` solveScheme env pool scheme) env schemes
109− solve env' pool constraint'
100+ CLet schemes constraint' -> do
101+ mapM solveScheme schemes
102+ solve constraint'
110103
111− CInstance name term -> do
112− let instance' = undefined
113− inst = instance' pool (Env.get env value name)
114− t <- chop pool term
115− unify pool inst t
104+ CInstance name term -> do
105+ let instance' = undefined
106+ inst = undefined --instance' pool (Env.get env value name)
107+ t <- TS.flatten term
108+ unify inst t
116109
117−solveScheme env pool scheme =
110+solveScheme :: TypeScheme -> StateT TS.SolverState IO ()
111+solveScheme scheme =
118112 case scheme of
119113 Scheme [] [] constraint header -> do
120− solve env pool constraint
121− mapM (\(n,t) -> (,) n `liftM` chop pool t) (Map.toList header)
114+ solve constraint
115+ Traversable.traverse TS.flatten header
116+ return ()
122117
123118 Scheme rigidQuantifiers flexibleQuantifiers constraint header -> do
124119 let quantifiers = rigidQuantifiers ++ flexibleQuantifiers
125− pool' <- newPool pool
126− mapM (introduce pool') rigidQuantifiers
127− mapM (introduce pool') flexibleQuantifiers
128− header' <- mapM (\(n,t) -> (,) n `liftM` chop pool t) (Map.toList header)
129− solve env pool' constraint
130− generalize pool pool'
131− mapM isGeneric rigidQuantifiers
132− return header'
120+ globalPool <- TS.getPool
121+ localPool <- TS.newPool
122+ TS.modifyPool (\_ -> localPool)
123+ mapM TS.introduce quantifiers
124+ header' <- Traversable.traverse TS.flatten header
125+ solve constraint
126+ -- distinct variables
127+ -- generalize
128+ -- generic variables
129+ TS.modifyPool (\_ -> globalPool)
133130
134131isGeneric var =
135132 do desc <- UF.descriptor var