git.iko.soy/elk
on master help sign in
Create type pools, have an organized model of state to flow through
ca62ee6Evan Czaplicki
compiler/Type/Pool.hsdeleted−45
compare with master
unifiedsplit
@@ -1,45 +0,0 @@
1−module Type.Pool where
2−
3−import Type.Type
4−import qualified Data.UnionFind.IO as UF
5−import Control.Arrow (first)
6−import Control.Monad.State
7−
8−-- Pool
9−-- Holds a bunch of variables
10−-- The rank of each variable is less than or equal to the pool's "maxRank"
11−-- The young pool exists to make it possible to identify these vars in constant time.
12−
13−-- inhabitants :: Pool -> [Variable]
14−
15−data Pool = Pool {
16− maxRank :: Int,
17− inhabitants :: [Variable]
18−}
19−
20−register :: Variable -> StateT (Pool,[String]) IO Variable
21−register variable = do
22− modify . first $ \pool -> pool { inhabitants = variable : inhabitants pool }
23− return variable
24−
25−introduce :: Variable -> StateT (Pool,[String]) IO Variable
26−introduce variable = do
27− (pool, _) <- get
28− liftIO $ UF.modifyDescriptor variable (\desc -> desc { rank = maxRank pool })
29− register variable
30−
31−flatten :: Type -> StateT (Pool,[String]) IO Variable
32−flatten term =
33− case term of
34− VarN v -> return v
35− TermN t -> do
36− flatStructure <- undefined -- chop t
37− (pool, _) <- get
38− var <- liftIO . UF.fresh $ Descriptor {
39− structure = Just flatStructure,
40− rank = maxRank pool,
41− flex = Flexible,
42− name = Nothing,
43− mark = 0
44− }
45− register var
compiler/Type/Solve.hs+44−47
@@ -2,33 +2,24 @@
2module Type.Solve where
2module Type.Solve where
3
3
4import Control.Monad
4import Control.Monad
5+import Control.Monad.State
5import qualified Data.UnionFind.IO as UF
6import qualified Data.UnionFind.IO as UF
6import qualified Data.Array.IO as Array
7import 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
8import qualified Data.Maybe as Maybe
10import qualified Data.Maybe as Maybe
9import Type.Type
11import Type.Type
10import Type.Unify
12import Type.Unify
11−import Type.Environment as Env
13+import qualified Type.Environment as Env
12−
14+import qualified Type.State as TS
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−}
24
15
25register = undefined
16register = undefined
26
17
27−generalize :: Pool -> Pool -> IO [Variable]
18+generalize :: TS.Pool -> TS.Pool -> IO [Variable]
28generalize oldPool youngPool = do
19generalize oldPool youngPool = do
29 let young = 0
20 let young = 0
30 visited = 1
21 visited = 1
31− youngRank = maxRank youngPool
22+ youngRank = TS.maxRank youngPool
32
23
33 array' <- Array.newArray (0, youngRank) []
24 array' <- Array.newArray (0, youngRank) []
34 let array = array' :: Array.IOArray Int [Variable]
25 let array = array' :: Array.IOArray Int [Variable]
@@ -36,7 +27,7 @@ generalize oldPool youngPool = do
36 -- Insert all of the youngPool variables into the array.
27 -- Insert all of the youngPool variables into the array.
37 -- They are placed into a list at the index corresponding
28 -- They are placed into a list at the index corresponding
38 -- to their rank.
29 -- to their rank.
39− forM (inhabitants youngPool) $ \var -> do
30+ forM (TS.inhabitants youngPool) $ \var -> do
40 desc <- UF.descriptor var
31 desc <- UF.descriptor var
41 vars <- Array.readArray array (rank desc)
32 vars <- Array.readArray array (rank desc)
42 Array.writeArray array (rank desc) (var : vars)
33 Array.writeArray array (rank desc) (var : vars)
@@ -86,50 +77,56 @@ traverse young visited k variable =
86 return rank'
77 return rank'
87 else return (rank desc)
78 else return (rank desc)
88
79
89−success = return []
90−
91−chop = undefined
92addTo = undefined
80addTo = undefined
93newPool = undefined
81newPool = undefined
94introduce = undefined
82introduce = undefined
95
83
84+solve :: TypeConstraint -> StateT TS.SolverState IO ()
96−solve env pool constraint =
85+solve constraint =
97− case constraint of
86+ case constraint of
98− CTrue -> success
87+ CTrue -> return ()
88+
89+ CEqual term1 term2 -> do
90+ t1 <- TS.flatten term1
91+ t2 <- TS.flatten term2
92+ unify t1 t2
99
93
100− CEqual term1 term2 ->
94+ CAnd cs -> mapM_ solve cs
101− unify (register pool) term1 term2
102
95
103− CAnd cs -> do
96+ CLet [Scheme [] fqs constraint' _] CTrue -> do
104− results <- mapM (solve env pool) cs
97+ mapM_ introduce fqs
105− return (concat results)
98+ solve constraint'
106
99
107− CLet schemes constraint' -> do
100+ CLet schemes constraint' -> do
108− env' <- foldM (\env' scheme -> addTo env' `liftM` solveScheme env pool scheme) env schemes
101+ mapM solveScheme schemes
109− solve env' pool constraint'
102+ solve constraint'
110
103
111− CInstance name term -> do
104+ CInstance name term -> do
112− let instance' = undefined
105+ let instance' = undefined
113− inst = instance' pool (Env.get env value name)
106+ inst = undefined --instance' pool (Env.get env value name)
114− t <- chop pool term
107+ t <- TS.flatten term
115− unify pool inst t
108+ unify inst t
116
109
117−solveScheme env pool scheme =
110+solveScheme :: TypeScheme -> StateT TS.SolverState IO ()
111+solveScheme scheme =
118 case scheme of
112 case scheme of
119 Scheme [] [] constraint header -> do
113 Scheme [] [] constraint header -> do
120− solve env pool constraint
114+ solve constraint
121− mapM (\(n,t) -> (,) n `liftM` chop pool t) (Map.toList header)
115+ Traversable.traverse TS.flatten header
116+ return ()
122
117
123 Scheme rigidQuantifiers flexibleQuantifiers constraint header -> do
118 Scheme rigidQuantifiers flexibleQuantifiers constraint header -> do
124 let quantifiers = rigidQuantifiers ++ flexibleQuantifiers
119 let quantifiers = rigidQuantifiers ++ flexibleQuantifiers
120+ globalPool <- TS.getPool
125− pool' <- newPool pool
121+ localPool <- TS.newPool
126− mapM (introduce pool') rigidQuantifiers
122+ TS.modifyPool (\_ -> localPool)
127− mapM (introduce pool') flexibleQuantifiers
123+ mapM TS.introduce quantifiers
128− header' <- mapM (\(n,t) -> (,) n `liftM` chop pool t) (Map.toList header)
124+ header' <- Traversable.traverse TS.flatten header
129− solve env pool' constraint
125+ solve constraint
126+ -- distinct variables
130− generalize pool pool'
127+ -- generalize
131− mapM isGeneric rigidQuantifiers
128+ -- generic variables
132− return header'
129+ TS.modifyPool (\_ -> globalPool)
133
130
134isGeneric var =
131isGeneric var =
135 do desc <- UF.descriptor var
132 do desc <- UF.descriptor var
compiler/Type/State.hsnew file+60
@@ -0,0 +1,60 @@
1+module Type.State where
2+
3+import Type.Type
4+import qualified Type.Environment as Env
5+import qualified Data.UnionFind.IO as UF
6+import Control.Monad.State
7+
8+-- Pool
9+-- Holds a bunch of variables
10+-- The rank of each variable is less than or equal to the pool's "maxRank"
11+-- The young pool exists to make it possible to identify these vars in constant time.
12+
13+data Pool = Pool {
14+ maxRank :: Int,
15+ inhabitants :: [Variable]
16+}
17+
18+-- Keeps track of the environment, type variable pool, and a list of errors
19+type SolverState = (Env.Environment, Pool, [String])
20+
21+modifyEnv f = modify $ \(env, pool, errors) -> (f env, pool, errors)
22+modifyPool f = modify $ \(env, pool, errors) -> (env, f pool, errors)
23+addError err = modify $ \(env, pool, errors) -> (env, pool, err:errors)
24+
25+getPool :: StateT SolverState IO Pool
26+getPool = do
27+ (_, pool, _) <- get
28+ return pool
29+
30+newPool :: StateT SolverState IO Pool
31+newPool = do
32+ (_, pool, _) <- get
33+ return $ Pool { maxRank = maxRank pool + 1, inhabitants = [] }
34+
35+register :: Variable -> StateT SolverState IO Variable
36+register variable = do
37+ modifyPool $ \pool -> pool { inhabitants = variable : inhabitants pool }
38+ return variable
39+
40+introduce :: Variable -> StateT SolverState IO Variable
41+introduce variable = do
42+ (_, pool, _) <- get
43+ liftIO $ UF.modifyDescriptor variable (\desc -> desc { rank = maxRank pool })
44+ register variable
45+
46+flatten :: Type -> StateT SolverState IO Variable
47+flatten term =
48+ case term of
49+ VarN v -> return v
50+ TermN t -> do
51+ flatStructure <- undefined -- chop t
52+ (_, pool, _) <- get
53+ var <- liftIO . UF.fresh $ Descriptor {
54+ structure = Just flatStructure,
55+ rank = maxRank pool,
56+ flex = Flexible,
57+ name = Nothing,
58+ mark = 0
59+ }
60+ register var
compiler/Type/Unify.hs+11−14
@@ -2,17 +2,17 @@ module Type.Unify (unify) where
2
2
3import Type.Type
3import Type.Type
4import qualified Data.UnionFind.IO as UF
4import qualified Data.UnionFind.IO as UF
5−import qualified Type.Pool as Pool
5+import qualified Type.State as TS
6import Control.Arrow (first,second)
6import Control.Arrow (first,second)
7import Control.Monad.State
7import Control.Monad.State
8
8
9−unify :: Variable -> Variable -> StateT (Pool.Pool, [String]) IO ()
9+unify :: Variable -> Variable -> StateT TS.SolverState IO ()
10unify variable1 variable2 = do
10unify variable1 variable2 = do
11 equivalent <- liftIO $ UF.equivalent variable1 variable2
11 equivalent <- liftIO $ UF.equivalent variable1 variable2
12 if equivalent then return ()
12 if equivalent then return ()
13 else actuallyUnify variable1 variable2
13 else actuallyUnify variable1 variable2
14
14
15−actuallyUnify :: Variable -> Variable -> StateT (Pool.Pool, [String]) IO ()
15+actuallyUnify :: Variable -> Variable -> StateT TS.SolverState IO ()
16actuallyUnify variable1 variable2 = do
16actuallyUnify variable1 variable2 = do
17 desc1 <- liftIO $ UF.descriptor variable1
17 desc1 <- liftIO $ UF.descriptor variable1
18 desc2 <- liftIO $ UF.descriptor variable2
18 desc2 <- liftIO $ UF.descriptor variable2
@@ -34,25 +34,22 @@ actuallyUnify variable1 variable2 = do
34 rank' :: Int
34 rank' :: Int
35 rank' = min (rank desc1) (rank desc2)
35 rank' = min (rank desc1) (rank desc2)
36
36
37− merge1 :: StateT (Pool.Pool, [String]) IO ()
37+ merge1 :: StateT TS.SolverState IO ()
38 merge1 = liftIO $ do
38 merge1 = liftIO $ do
39 UF.union variable2 variable1
39 UF.union variable2 variable1
40 UF.setDescriptor variable1 (desc1 { flex = flex', name = name', rank = rank', mark = undefined })
40 UF.setDescriptor variable1 (desc1 { flex = flex', name = name', rank = rank', mark = undefined })
41
41
42− merge2 :: StateT (Pool.Pool, [String]) IO ()
42+ merge2 :: StateT TS.SolverState IO ()
43 merge2 = liftIO $ do
43 merge2 = liftIO $ do
44 UF.union variable1 variable2
44 UF.union variable1 variable2
45 UF.setDescriptor variable2 (desc2 { flex = flex', name = name', rank = rank', mark = undefined })
45 UF.setDescriptor variable2 (desc2 { flex = flex', name = name', rank = rank', mark = undefined })
46
46
47− fresh :: Maybe (Term1 Variable) -> StateT (Pool.Pool, [String]) IO Variable
47+ fresh :: Maybe (Term1 Variable) -> StateT TS.SolverState IO Variable
48 fresh structure = do
48 fresh structure = do
49 var <- liftIO . UF.fresh $ Descriptor {
49 var <- liftIO . UF.fresh $ Descriptor {
50 structure = structure, rank = rank', flex = flex', name = name', mark = undefined
50 structure = structure, rank = rank', flex = flex', name = name', mark = undefined
51 }
51 }
52− Pool.register var
52+ TS.register var
53−
54− mistake :: String -> StateT (Pool.Pool, [String]) IO ()
55− mistake err = modify $ second (err:)
56
53
57 case (structure desc1, structure desc2) of
54 case (structure desc1, structure desc2) of
58 (Nothing, _) | flex desc1 == Flexible -> merge2
55 (Nothing, _) | flex desc1 == Flexible -> merge2
@@ -61,8 +58,8 @@ actuallyUnify variable1 variable2 = do
61 (Just (Var1 v), _) -> unify v variable2
58 (Just (Var1 v), _) -> unify v variable2
62 (_, Just (Var1 v)) -> unify v variable1
59 (_, Just (Var1 v)) -> unify v variable1
63
60
64− (Nothing, _) -> mistake "Cannot unify rigid type variable."
61+ (Nothing, _) -> TS.addError "Cannot unify rigid type variable."
65− (_, Nothing) -> mistake "Cannot unify rigid type variable."
62+ (_, Nothing) -> TS.addError "Cannot unify rigid type variable."
66
63
67 (Just type1, Just type2) ->
64 (Just type1, Just type2) ->
68 case (type1,type2) of
65 case (type1,type2) of
@@ -79,6 +76,6 @@ actuallyUnify variable1 variable2 = do
79 return ()
76 return ()
80
77
81 (Record1 fields1 ext1, Record1 fields2 ext2) ->
78 (Record1 fields1 ext1, Record1 fields2 ext2) ->
82− mistake "did not write record unification yet"
79+ TS.addError "did not write record unification yet"
83
80
84− _ -> mistake "Could not unify types"
81+ _ -> TS.addError "Could not unify types"