git.iko.soy/elk
on master help sign in
Create a Type.Pool module specifically for variable pools. Start using

a state transformer to thread the pool and errors through.

commit4c51159f2ad24ab411f465de32b686082b48eb11 authorEvan Czaplicki <evan@Evans-MacBook-Air.local> dateMon 8 Jul 2013, 20:03 (13 years ago) parent2ef1882
2 files changed+121−52
compare with master
unifiedsplit
compiler/Type/Pool.hs+45 compiler/Type/Unify.hs+76−52
compiler/Type/Pool.hsnew file+45
@@ -0,0 +1,45 @@
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/Unify.hs+76−52
@@ -2,59 +2,83 @@ module Type.Unify (unify) where
22
33import Type.Type
44import qualified Data.UnionFind.IO as UF
5+import qualified Type.Pool as Pool
6+import Control.Arrow (first,second)
7+import Control.Monad.State
58
6−success = return []
7−
8−unify register variable1 variable2 =
9− do equivalent <- UF.equivalent variable1 variable2
10− if equivalent then success else do
11− desc1 <- UF.descriptor variable1
12− desc2 <- UF.descriptor variable2
13− let name' = case (name desc1, name desc2) of
14− (Just name1, Just name2)
15− | name1 == name2 -> Just name1
16− | flex desc1 /= Flexible -> Just name1
17− | flex desc2 /= Flexible -> Just name2
18− | otherwise -> Nothing
19− (Just name1, _) -> Just name1
20− (_, Just name2) -> Just name2
21− _ -> Nothing
22−
23− flex' = if flex desc1 /= Flexible then flex desc1 else
24− if flex desc2 /= Flexible then flex desc2 else Flexible
25−
26− rank' = min (rank desc1) (rank desc2)
27−
28− merge1 = do
29− UF.union variable2 variable1
30− UF.setDescriptor variable1 (desc1 { flex = flex', name = name', rank = rank', mark = undefined })
31−
32− merge2 = do
33− UF.union variable1 variable2
34− UF.setDescriptor variable2 (desc2 { flex = flex', name = name', rank = rank', mark = undefined })
35−
36− fresh structure = -- gotta register this
37− UF.fresh $ Descriptor {
9+unify :: Variable -> Variable -> StateT (Pool.Pool, [String]) IO ()
10+unify variable1 variable2 = do
11+ equivalent <- liftIO $ UF.equivalent variable1 variable2
12+ if equivalent then return ()
13+ else actuallyUnify variable1 variable2
14+
15+actuallyUnify :: Variable -> Variable -> StateT (Pool.Pool, [String]) IO ()
16+actuallyUnify variable1 variable2 = do
17+ desc1 <- liftIO $ UF.descriptor variable1
18+ desc2 <- liftIO $ UF.descriptor variable2
19+ let name' :: Maybe String
20+ name' = case (name desc1, name desc2) of
21+ (Just name1, Just name2)
22+ | name1 == name2 -> Just name1
23+ | flex desc1 /= Flexible -> Just name1
24+ | flex desc2 /= Flexible -> Just name2
25+ | otherwise -> Nothing
26+ (Just name1, _) -> Just name1
27+ (_, Just name2) -> Just name2
28+ _ -> Nothing
29+
30+ flex' :: Flex
31+ flex' = if flex desc1 /= Flexible then flex desc1 else
32+ if flex desc2 /= Flexible then flex desc2 else Flexible
33+
34+ rank' :: Int
35+ rank' = min (rank desc1) (rank desc2)
36+
37+ merge1 :: StateT (Pool.Pool, [String]) IO ()
38+ merge1 = liftIO $ do
39+ UF.union variable2 variable1
40+ UF.setDescriptor variable1 (desc1 { flex = flex', name = name', rank = rank', mark = undefined })
41+
42+ merge2 :: StateT (Pool.Pool, [String]) IO ()
43+ merge2 = liftIO $ do
44+ UF.union variable1 variable2
45+ UF.setDescriptor variable2 (desc2 { flex = flex', name = name', rank = rank', mark = undefined })
46+
47+ fresh :: Maybe (Term1 Variable) -> StateT (Pool.Pool, [String]) IO Variable
48+ fresh structure = do
49+ var <- liftIO . UF.fresh $ Descriptor {
3850 structure = structure, rank = rank', flex = flex', name = name', mark = undefined
3951 }
52+ Pool.register var
53+
54+ mistake :: String -> StateT (Pool.Pool, [String]) IO ()
55+ mistake err = modify $ second (err:)
56+
57+ case (structure desc1, structure desc2) of
58+ (Nothing, _) | flex desc1 == Flexible -> merge2
59+ (_, Nothing) | flex desc2 == Flexible -> merge1
60+
61+ (Just (Var1 v), _) -> unify v variable2
62+ (_, Just (Var1 v)) -> unify v variable1
63+
64+ (Nothing, _) -> mistake "Cannot unify rigid type variable."
65+ (_, Nothing) -> mistake "Cannot unify rigid type variable."
66+
67+ (Just type1, Just type2) ->
68+ case (type1,type2) of
69+ (App1 term1 term2, App1 term1' term2') ->
70+ do merge1
71+ unify term1 term1'
72+ unify term2 term2'
73+ (Fun1 term1 term2, Fun1 term1' term2') ->
74+ do merge1
75+ unify term1 term1'
76+ unify term2 term2'
77+
78+ (EmptyRecord1, EmptyRecord1) ->
79+ return ()
80+
81+ (Record1 fields1 ext1, Record1 fields2 ext2) ->
82+ mistake "did not write record unification yet"
4083
41− case (structure desc1, structure desc2) of
42− (Nothing, _) | flex desc1 == Flexible -> merge2 >> success
43− (_, Nothing) | flex desc2 == Flexible -> merge1 >> success
44− (Just (Var1 v), _) -> unify register v variable2
45− (_, Just (Var1 v)) -> unify register v variable1
46− (Nothing, _) -> return ["Cannot unify rigid type variable."]
47− (_, Nothing) -> return ["Cannot unify rigid type variable."]
48− (Just type1, Just type2) ->
49− case (type1,type2) of
50− (App1 term1 term2, App1 term1' term2') ->
51− do merge1
52− ok1 <- unify register term1 term1'
53− ok2 <- unify register term2 term2'
54− return (ok1 ++ ok2)
55− (Fun1 term1 term2, Fun1 term1' term2') ->
56− do merge1
57− ok1 <- unify register term1 term1'
58− ok2 <- unify register term2 term2'
59− return (ok1 ++ ok2)
60−
84+ _ -> mistake "Could not unify types"