git.iko.soy/elk
on master help sign in
Get type inference working in the basic case. Begin working on
b5887f4Evan Czaplicki
compiler/SourceSyntax/PrettyPrint.hs+3
compare with master
unifiedsplit
@@ -10,6 +10,9 @@ class Pretty a where
10instance Pretty a => Pretty (Located a) where
10instance Pretty a => Pretty (Located a) where
11 pretty (L _ _ e) = pretty e
11 pretty (L _ _ e) = pretty e
12
12
13+instance Pretty () where
14+ pretty () = empty
15+
13commaCat docs = cat (punctuate comma docs)
16commaCat docs = cat (punctuate comma docs)
14
17
15parensIf bool doc = if bool then parens doc else doc
18parensIf bool doc = if bool then parens doc else doc
compiler/Type/Constrain/Expression.hs+6−3
@@ -35,10 +35,13 @@ test str =
35 var <- flexibleVar
35 var <- flexibleVar
36 constraint <- constrain env expression (VarN var)
36 constraint <- constrain env expression (VarN var)
37 prettyNames constraint
37 prettyNames constraint
38− print (pretty constraint)
38+ --print (pretty constraint)
39− print (P.text "Solving for:" <+> pretty var)
39+ --print (P.text "Solving for:" <+> pretty var)
40− (env,_,_,_) <- execStateT (solve constraint) TS.initialState
40+ (env,_,_,errors) <- execStateT (solve constraint) TS.initialState
41 mapM_ (\(n,t) -> print $ P.text n <+> P.text ":" <+> pretty t) $ Map.toList env
41 mapM_ (\(n,t) -> print $ P.text n <+> P.text ":" <+> pretty t) $ Map.toList env
42+ if null errors then return () else do
43+ putStrLn "\n"
44+ mapM_ print errors
42{-- todo: remove testing code --}
45{-- todo: remove testing code --}
43
46
44constrain :: Env.Environment -> LExpr a b -> Type -> IO TypeConstraint
47constrain :: Env.Environment -> LExpr a b -> Type -> IO TypeConstraint
compiler/Type/Solve.hs+32−19
@@ -1,4 +1,4 @@
1−
1+{-# OPTIONS_GHC -XMultiWayIf #-}
2module Type.Solve where
2module Type.Solve where
3
3
4import Control.Monad
4import Control.Monad
@@ -11,6 +11,7 @@ import Type.Type
11import Type.Unify
11import Type.Unify
12import qualified Type.Environment as Env
12import qualified Type.Environment as Env
13import qualified Type.State as TS
13import qualified Type.State as TS
14+import qualified Text.PrettyPrint as P
14
15
15
16
16-- | Every variable has rank less than or equal to the maxRank of the pool.
17-- | Every variable has rank less than or equal to the maxRank of the pool.
@@ -47,11 +48,16 @@ generalize youngPool = do
47 if rank desc < youngRank
48 if rank desc < youngRank
48 then TS.register var >> return ()
49 then TS.register var >> return ()
49 else let flex' = if flex desc == Flexible then Rigid else flex desc
50 else let flex' = if flex desc == Flexible then Rigid else flex desc
50− in liftIO $ UF.setDescriptor var (desc { rank = noRank, flex = flex' })
51+ in do liftIO $ UF.setDescriptor var (desc { rank = noRank, flex = flex' })
52+ TS.debug $ print var
51
53
52 Traversable.traverse (mapM registerIfNotRedundant) rankDict
54 Traversable.traverse (mapM registerIfNotRedundant) rankDict
53 Traversable.traverse (mapM registerIfHigherRank) rankDict
55 Traversable.traverse (mapM registerIfHigherRank) rankDict
54
56
57+ TS.debug $ print youngMark
58+ TS.debug $ print visitedMark
59+-- TS.debug $ mapM print youngVars
60+
55 return ()
61 return ()
56
62
57
63
@@ -63,9 +69,8 @@ adjustRank :: Int -> Int -> Int -> Variable -> StateT TS.SolverState IO Int
63adjustRank youngMark visitedMark groupRank variable =
69adjustRank youngMark visitedMark groupRank variable =
64 let adjust = adjustRank youngMark visitedMark groupRank in
70 let adjust = adjustRank youngMark visitedMark groupRank in
65 do desc <- liftIO $ UF.descriptor variable
71 do desc <- liftIO $ UF.descriptor variable
66− case mark desc == youngMark of
72+ if | mark desc == youngMark -> do
67− True -> do
68− rank' <- case structure desc of
73+ rank' <- case structure desc of
69 Nothing -> return groupRank
74 Nothing -> return groupRank
70 Just term -> case term of
75 Just term -> case term of
71 App1 a b -> max `liftM` adjust a `ap` adjust b
76 App1 a b -> max `liftM` adjust a `ap` adjust b
@@ -75,31 +80,37 @@ adjustRank youngMark visitedMark groupRank variable =
75 Record1 fields extension -> do
80 Record1 fields extension -> do
76 ranks <- mapM adjust (concat (Map.elems fields))
81 ranks <- mapM adjust (concat (Map.elems fields))
77 max (maximum ranks) `liftM` adjust extension
82 max (maximum ranks) `liftM` adjust extension
78− liftIO $ UF.setDescriptor variable (desc { mark = visitedMark, rank = rank' })
83+ liftIO $ UF.setDescriptor variable (desc { mark = visitedMark, rank = rank' })
79− return rank'
84+ return rank'
85+
86+ | mark desc /= visitedMark -> do
87+ let rank' = min groupRank (rank desc)
88+ liftIO $ UF.setDescriptor variable (desc { mark = visitedMark, rank = rank' })
89+ return rank'
90+
91+ | otherwise -> return (rank desc)
80
92
81− False -> do
82− if mark desc == visitedMark then return (rank desc) else do
83− let rank' = min groupRank (rank desc)
84− liftIO $ UF.setDescriptor variable (desc { mark = visitedMark, rank = rank' })
85− return rank'
86
93
87
94
88−solve :: TypeConstraint -> StateT TS.SolverState IO ()
95+solve :: TypeConstraint -> StateT TS.SolverState IO (Map.Map String Variable)
89solve constraint =
96solve constraint =
90 case constraint of
97 case constraint of
91− CTrue -> return ()
98+ CTrue -> TS.getEnv
92
99
93 CEqual term1 term2 -> do
100 CEqual term1 term2 -> do
94 t1 <- TS.flatten term1
101 t1 <- TS.flatten term1
95 t2 <- TS.flatten term2
102 t2 <- TS.flatten term2
96 unify t1 t2
103 unify t1 t2
104+ TS.getEnv
97
105
98− CAnd cs -> mapM_ solve cs
106+ CAnd cs -> mapM solve cs >> TS.getEnv
99
107
100 CLet [Scheme [] fqs constraint' _] CTrue -> do
108 CLet [Scheme [] fqs constraint' _] CTrue -> do
109+ oldEnv <- TS.getEnv
101− mapM_ TS.introduce fqs
110+ mapM TS.introduce fqs
102 solve constraint'
111 solve constraint'
112+ TS.modifyEnv (\_ -> oldEnv)
113+ return oldEnv
103
114
104 CLet schemes constraint' -> do
115 CLet schemes constraint' -> do
105 headers <- mapM solveScheme schemes
116 headers <- mapM solveScheme schemes
@@ -111,6 +122,7 @@ solve constraint =
111 freshCopy <- TS.makeInstance ((Map.!) env name)
122 freshCopy <- TS.makeInstance ((Map.!) env name)
112 t <- TS.flatten term
123 t <- TS.flatten term
113 unify freshCopy t
124 unify freshCopy t
125+ TS.getEnv
114
126
115solveScheme :: TypeScheme -> StateT TS.SolverState IO (Map.Map String Variable)
127solveScheme :: TypeScheme -> StateT TS.SolverState IO (Map.Map String Variable)
116solveScheme scheme =
128solveScheme scheme =
@@ -147,10 +159,11 @@ allDistinct vars = do
147 let check var = do
159 let check var = do
148 desc <- liftIO $ UF.descriptor var
160 desc <- liftIO $ UF.descriptor var
149 case structure desc of
161 case structure desc of
162+ Just _ ->
150− Just _ -> TS.addError "Cannot generalize something that is not a type variable."
163+ TS.addError "Cannot generalize something that is not a type variable" () var
151 Nothing -> do
164 Nothing -> do
152 if mark desc == seen
165 if mark desc == seen
153− then TS.addError "Duplicate variable during generalization"
166+ then TS.addError "Duplicate variable during generalization" var ()
154 else return ()
167 else return ()
155 liftIO $ UF.setDescriptor var (desc { mark = seen })
168 liftIO $ UF.setDescriptor var (desc { mark = seen })
156 mapM_ check vars
169 mapM_ check vars
@@ -161,4 +174,4 @@ isGeneric var = do
161 desc <- liftIO $ UF.descriptor var
174 desc <- liftIO $ UF.descriptor var
162 if rank desc == noRank
175 if rank desc == noRank
163 then return ()
176 then return ()
164− else TS.addError "Cannot generalize. Variable must have not have a rank."
177+ else TS.addError "Cannot generalize. Variable must have not have a rank." () var
compiler/Type/State.hs+40−11
@@ -3,15 +3,17 @@ module Type.State where
3
3
4import Type.Type
4import Type.Type
5import qualified Data.Map as Map
5import qualified Data.Map as Map
6+import qualified Data.List as List
6import qualified Type.Environment as Env
7import qualified Type.Environment as Env
7import qualified Data.UnionFind.IO as UF
8import qualified Data.UnionFind.IO as UF
8import Control.Monad.State
9import Control.Monad.State
9import Control.Applicative ((<$>),(<*>), Applicative)
10import Control.Applicative ((<$>),(<*>), Applicative)
10import qualified Data.Traversable as Traversable
11import qualified Data.Traversable as Traversable
11−
12+import Text.PrettyPrint as P
12−-- todo: remove later
13import SourceSyntax.PrettyPrint
13import SourceSyntax.PrettyPrint
14
14
15+debug e = {-- liftIO e --} return ()
16+
15-- Pool
17-- Pool
16-- Holds a bunch of variables
18-- Holds a bunch of variables
17-- The rank of each variable is less than or equal to the pool's "maxRank"
19-- The rank of each variable is less than or equal to the pool's "maxRank"
@@ -25,14 +27,23 @@ data Pool = Pool {
25emptyPool = Pool { maxRank = 0, inhabitants = [] }
27emptyPool = Pool { maxRank = 0, inhabitants = [] }
26
28
27-- Keeps track of the environment, type variable pool, and a list of errors
29-- Keeps track of the environment, type variable pool, and a list of errors
28−type SolverState = (Map.Map String Variable, Pool, Int, [String])
30+type SolverState = (Map.Map String Variable, Pool, Int, [P.Doc])
29
31
30-- The mark must never be equal to noMark!
32-- The mark must never be equal to noMark!
31initialState = (Map.empty, emptyPool, noMark + 1, [])
33initialState = (Map.empty, emptyPool, noMark + 1, [])
32
34
33modifyEnv f = modify $ \(env, pool, mark, errors) -> (f env, pool, mark, errors)
35modifyEnv f = modify $ \(env, pool, mark, errors) -> (f env, pool, mark, errors)
34modifyPool f = modify $ \(env, pool, mark, errors) -> (env, f pool, mark, errors)
36modifyPool f = modify $ \(env, pool, mark, errors) -> (env, f pool, mark, errors)
35−addError err = modify $ \(env, pool, mark, errors) -> (env, pool, mark, err:errors)
37+addError message t1 t2 = modify $ \(env, pool, mark, errors) -> (env, pool, mark, err:errors)
38+ where
39+ msg = P.fsep . map P.text $ words message
40+ width = maximum . map length . lines $ render msg
41+ err = P.vcat [ P.text $ "Type error on line ???"
42+ , P.text (List.replicate width '-')
43+ , msg <> P.text "\n"
44+ , P.text " Expected Type:" <+> pretty t1
45+ , P.text " Actual Type:" <+> pretty t2 <> P.text "\n"
46+ ]
36
47
37switchToPool pool = modifyPool (\_ -> pool)
48switchToPool pool = modifyPool (\_ -> pool)
38
49
@@ -87,23 +98,30 @@ flatten term =
87
98
88makeInstance :: Variable -> StateT SolverState IO Variable
99makeInstance :: Variable -> StateT SolverState IO Variable
89makeInstance var = do
100makeInstance var = do
101+-- liftIO $ putStrLn ""
102+-- liftIO $ print $ pretty var
90 alreadyCopied <- uniqueMark
103 alreadyCopied <- uniqueMark
91 freshVar <- makeCopy alreadyCopied var
104 freshVar <- makeCopy alreadyCopied var
92 restore alreadyCopied var
105 restore alreadyCopied var
106+-- liftIO $ print $ pretty freshVar
93 return freshVar
107 return freshVar
94
108
95makeCopy :: Int -> Variable -> StateT SolverState IO Variable
109makeCopy :: Int -> Variable -> StateT SolverState IO Variable
96makeCopy alreadyCopied variable = do
110makeCopy alreadyCopied variable = do
111+-- liftIO $ putStr "Copying: "
97 desc <- liftIO $ UF.descriptor variable
112 desc <- liftIO $ UF.descriptor variable
98 if | mark desc == alreadyCopied ->
113 if | mark desc == alreadyCopied ->
114+ do debug $ putStrLn "Already Copied"
99 case copy desc of
115 case copy desc of
100 Just v -> return v
116 Just v -> return v
101 Nothing -> error "This should be impossible."
117 Nothing -> error "This should be impossible."
102
118
103− | mark desc /= noRank || flex desc == Constant ->
119+ | rank desc /= noRank || flex desc == Constant ->
120+ do debug $ putStr "did not make a copy: " >> print (mark desc, noRank, flex desc)
104− return variable
121+ return variable
105
122
106 | otherwise -> do
123 | otherwise -> do
124+ debug $ print "no problems!"
107 pool <- getPool
125 pool <- getPool
108 newVar <- liftIO $ UF.fresh $ Descriptor {
126 newVar <- liftIO $ UF.fresh $ Descriptor {
109 structure = Nothing,
127 structure = Nothing,
@@ -118,12 +136,17 @@ makeCopy alreadyCopied variable = do
118
136
119 register newVar
137 register newVar
120
138
121− -- Link the original variable to the new variable
139+ -- Link the original variable to the new variable. This lets us
140+ -- avoid making multiple copies of the variable we are instantiating.
141+ --
122− -- Need to do this before recursively copying to
142+ -- Need to do this before recursively copying the structure of
123− -- avoid looping on cyclic terms.
143+ -- the variable to avoid looping on cyclic terms.
124 liftIO $ UF.modifyDescriptor variable $ \desc ->
144 liftIO $ UF.modifyDescriptor variable $ \desc ->
125 desc { mark = alreadyCopied, copy = Just newVar }
145 desc { mark = alreadyCopied, copy = Just newVar }
126
146
147+ -- Now we recursively copy the structure of the variable.
148+ -- We have already marked the variable as copied, so we
149+ -- will not repeat this work or crawl this variable again.
127 case structure desc of
150 case structure desc of
128 Nothing -> return newVar
151 Nothing -> return newVar
129 Just term -> do
152 Just term -> do
@@ -134,13 +157,19 @@ makeCopy alreadyCopied variable = do
134
157
135restore :: Int -> Variable -> StateT SolverState IO Variable
158restore :: Int -> Variable -> StateT SolverState IO Variable
136restore alreadyCopied variable = do
159restore alreadyCopied variable = do
160+ debug $ putStr "Restoring: "
137 desc <- liftIO $ UF.descriptor variable
161 desc <- liftIO $ UF.descriptor variable
138− if mark desc /= alreadyCopied then return variable else do
162+ if mark desc /= alreadyCopied
163+ then do
164+ debug $ putStrLn "not copied, no need to do anything"
165+ return variable
166+ else do
167+ debug $ putStrLn "restoring"
139 restoredStructure <-
168 restoredStructure <-
140 case structure desc of
169 case structure desc of
141 Nothing -> return Nothing
170 Nothing -> return Nothing
142 Just term -> Just <$> traverseTerm (restore alreadyCopied) term
171 Just term -> Just <$> traverseTerm (restore alreadyCopied) term
143− liftIO $ UF.modifyDescriptor variable $ \desc ->
172+ debug $ UF.modifyDescriptor variable $ \desc ->
144 desc { mark = noMark, rank = noRank, structure = restoredStructure }
173 desc { mark = noMark, rank = noRank, structure = restoredStructure }
145 return variable
174 return variable
146
175
compiler/Type/Unify.hs+6−4
@@ -5,6 +5,8 @@ import qualified Data.UnionFind.IO as UF
5import qualified Type.State as TS
5import qualified Type.State as TS
6import Control.Arrow (first,second)
6import Control.Arrow (first,second)
7import Control.Monad.State
7import Control.Monad.State
8+import SourceSyntax.PrettyPrint
9+import qualified Text.PrettyPrint as P
8
10
9unify :: Variable -> Variable -> StateT TS.SolverState IO ()
11unify :: Variable -> Variable -> StateT TS.SolverState IO ()
10unify variable1 variable2 = do
12unify variable1 variable2 = do
@@ -60,8 +62,8 @@ actuallyUnify variable1 variable2 = do
60 (Just (Var1 v), _) -> unify v variable2
62 (Just (Var1 v), _) -> unify v variable2
61 (_, Just (Var1 v)) -> unify v variable1
63 (_, Just (Var1 v)) -> unify v variable1
62
64
63− (Nothing, _) -> TS.addError "Cannot unify rigid type variable."
65+ (Nothing, _) -> TS.addError "The following types are not equal" variable1 variable2
64− (_, Nothing) -> TS.addError "Cannot unify rigid type variable."
66+ (_, Nothing) -> TS.addError "The following types are not equal" variable1 variable2
65
67
66 (Just type1, Just type2) ->
68 (Just type1, Just type2) ->
67 case (type1,type2) of
69 case (type1,type2) of
@@ -78,6 +80,6 @@ actuallyUnify variable1 variable2 = do
78 return ()
80 return ()
79
81
80 (Record1 fields1 ext1, Record1 fields2 ext2) ->
82 (Record1 fields1 ext1, Record1 fields2 ext2) ->
81− TS.addError "did not write record unification yet"
83+ TS.addError "did not write record unification yet" variable1 variable2
82
84
83− _ -> TS.addError "Could not unify types"
85+ _ -> TS.addError "could not unify types" variable1 variable2