git.iko.soy/elk
on master help sign in
Remove some debugging stuff and generally clean up the code.
4208b5cEvan Czaplicki
compiler/Type/Constrain/Expression.hs+3−1
compare with master
unifiedsplit
@@ -34,6 +34,7 @@ test str =
34 env <- Env.initialEnvironment
34 env <- Env.initialEnvironment
35 var <- flexibleVar
35 var <- flexibleVar
36 constraint <- constrain env expression (VarN var)
36 constraint <- constrain env expression (VarN var)
37+ print =<< extraPretty constraint
37 (env,_,_,errors) <- execStateT (solve constraint) TS.initialState
38 (env,_,_,errors) <- execStateT (solve constraint) TS.initialState
38 forM (Map.toList env) $ \(n,t) -> do
39 forM (Map.toList env) $ \(n,t) -> do
39 pt <- extraPretty t
40 pt <- extraPretty t
@@ -197,7 +198,8 @@ constrainDef env info (pattern, expr, maybeTipe) =
197
198
198 (PVar name, Nothing) ->
199 (PVar name, Nothing) ->
199 do var <- flexibleVar
200 do var <- flexibleVar
200− rigidVars <- mapM (\_ -> rigidVar) qs
201+ rigidVars <- mapM (\_ -> rigidVar) qs -- Some mistake may be happening here.
202+ -- Currently, qs is always the empty list.
201 let tipe = VarN var
203 let tipe = VarN var
202 inserts = zipWith (\arg typ -> Map.insert arg (VarN typ)) qs rigidVars
204 inserts = zipWith (\arg typ -> Map.insert arg (VarN typ)) qs rigidVars
203 env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }
205 env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }
compiler/Type/State.hs+4−17
@@ -12,8 +12,6 @@ import qualified Data.Traversable as Traversable
12import Text.PrettyPrint as P
12import Text.PrettyPrint as P
13import SourceSyntax.PrettyPrint
13import SourceSyntax.PrettyPrint
14
14
15−debug e = {-- liftIO e --} return ()
16−
17-- Pool
15-- Pool
18-- Holds a bunch of variables
16-- Holds a bunch of variables
19-- The rank of each variable is less than or equal to the pool's "maxRank"
17-- The rank of each variable is less than or equal to the pool's "maxRank"
@@ -24,7 +22,7 @@ data Pool = Pool {
24 inhabitants :: [Variable]
22 inhabitants :: [Variable]
25} deriving Show
23} deriving Show
26
24
27−emptyPool = Pool { maxRank = 0, inhabitants = [] }
25+emptyPool = Pool { maxRank = outermostRank, inhabitants = [] }
28
26
29-- Keeps track of the environment, type variable pool, and a list of errors
27-- Keeps track of the environment, type variable pool, and a list of errors
30type SolverState = (Map.Map String Variable, Pool, Int, [IO P.Doc])
28type SolverState = (Map.Map String Variable, Pool, Int, [IO P.Doc])
@@ -36,7 +34,6 @@ modifyEnv f = modify $ \(env, pool, mark, errors) -> (f env, pool, mark, errors
36modifyPool f = modify $ \(env, pool, mark, errors) -> (env, f pool, mark, errors)
34modifyPool f = modify $ \(env, pool, mark, errors) -> (env, f pool, mark, errors)
37addError message t1 t2 =
35addError message t1 t2 =
38 modify $ \(env, pool, mark, errors) -> (env, pool, mark, err : errors)
36 modify $ \(env, pool, mark, errors) -> (env, pool, mark, err : errors)
39−
40 where
37 where
41 wordify = P.fsep . map P.text . words
38 wordify = P.fsep . map P.text . words
42 msg = wordify message
39 msg = wordify message
@@ -113,20 +110,16 @@ makeInstance var = do
113
110
114makeCopy :: Int -> Variable -> StateT SolverState IO Variable
111makeCopy :: Int -> Variable -> StateT SolverState IO Variable
115makeCopy alreadyCopied variable = do
112makeCopy alreadyCopied variable = do
116− debug $ putStr "Copying: "
117 desc <- liftIO $ UF.descriptor variable
113 desc <- liftIO $ UF.descriptor variable
118 if | mark desc == alreadyCopied ->
114 if | mark desc == alreadyCopied ->
119− do debug $ putStrLn "Already Copied"
120 case copy desc of
115 case copy desc of
121 Just v -> return v
116 Just v -> return v
122 Nothing -> error "This should be impossible."
117 Nothing -> error "This should be impossible."
123
118
124 | rank desc /= noRank || flex desc == Constant ->
119 | rank desc /= noRank || flex desc == Constant ->
125− do debug $ putStr "did not make a copy: " >> print (mark desc, noRank, flex desc)
126 return variable
120 return variable
127
121
128 | otherwise -> do
122 | otherwise -> do
129− debug $ print "no problems!"
130 pool <- getPool
123 pool <- getPool
131 newVar <- liftIO $ UF.fresh $ Descriptor {
124 newVar <- liftIO $ UF.fresh $ Descriptor {
132 structure = Nothing,
125 structure = Nothing,
@@ -162,19 +155,13 @@ makeCopy alreadyCopied variable = do
162
155
163restore :: Int -> Variable -> StateT SolverState IO Variable
156restore :: Int -> Variable -> StateT SolverState IO Variable
164restore alreadyCopied variable = do
157restore alreadyCopied variable = do
165− debug $ putStr "Restoring: "
166 desc <- liftIO $ UF.descriptor variable
158 desc <- liftIO $ UF.descriptor variable
167 if mark desc /= alreadyCopied
159 if mark desc /= alreadyCopied
168− then do
169− debug $ putStrLn "not copied, no need to do anything"
170− return variable
160+ then return variable
171 else do
161 else do
172− debug $ putStrLn "restoring"
173 restoredStructure <-
162 restoredStructure <-
174− case structure desc of
175− Nothing -> return Nothing
176− Just term -> Just <$> traverseTerm (restore alreadyCopied) term
163+ Traversable.traverse (traverseTerm (restore alreadyCopied)) (structure desc)
177− debug $ UF.modifyDescriptor variable $ \desc ->
164+ liftIO $ UF.modifyDescriptor variable $ \desc ->
178 desc { mark = noMark, rank = noRank, structure = restoredStructure }
165 desc { mark = noMark, rank = noRank, structure = restoredStructure }
179 return variable
166 return variable
180
167
compiler/Type/Unify.hs+27−11
@@ -37,25 +37,41 @@ actuallyUnify variable1 variable2 = do
37 rank' = min (rank desc1) (rank desc2)
37 rank' = min (rank desc1) (rank desc2)
38
38
39 merge1 :: StateT TS.SolverState IO ()
39 merge1 :: StateT TS.SolverState IO ()
40+ merge1 =
41+ if rank desc1 < rank desc2 then
40− merge1 = liftIO $ do
42+ liftIO $ do
41− UF.union variable2 variable1
43+ UF.union variable2 variable1
42− UF.setDescriptor variable1 (desc1 {
44+ UF.modifyDescriptor variable1 (\desc -> desc { flex = flex', name = name' })
43− flex = flex', name = name', rank = rank', copy = Nothing, mark = noMark })
45+ else
46+ liftIO $ do
47+ UF.union variable1 variable2
48+ UF.modifyDescriptor variable2 (\desc -> desc {
49+ structure = structure desc1, flex = flex', name = name' })
44
50
45 merge2 :: StateT TS.SolverState IO ()
51 merge2 :: StateT TS.SolverState IO ()
52+ merge2 =
53+ if rank desc1 < rank desc2 then
46− merge2 = liftIO $ do
54+ liftIO $ do
47− UF.union variable1 variable2
55+ UF.union variable2 variable1
48− UF.setDescriptor variable2 (desc2 {
56+ UF.modifyDescriptor variable2 (\desc -> desc {
49− flex = flex', name = name', rank = rank', copy = Nothing, mark = noMark })
57+ structure = structure desc2, flex = flex', name = name' })
58+ else
59+ liftIO $ do
60+ UF.union variable1 variable2
61+ UF.modifyDescriptor variable2 (\desc -> desc { flex = flex', name = name' })
62+
63+ merge = if rank desc1 < rank desc2 then merge1 else merge2
50
64
51 fresh :: Maybe (Term1 Variable) -> StateT TS.SolverState IO Variable
65 fresh :: Maybe (Term1 Variable) -> StateT TS.SolverState IO Variable
52 fresh structure = do
66 fresh structure = do
53 var <- liftIO . UF.fresh $ Descriptor {
67 var <- liftIO . UF.fresh $ Descriptor {
54− structure = structure, rank = rank', flex = flex', name = name', copy = Nothing, mark = noMark
68+ structure = structure, rank = rank', flex = flex',
69+ name = name', copy = Nothing, mark = noMark
55 }
70 }
56 TS.register var
71 TS.register var
57
72
58 case (structure desc1, structure desc2) of
73 case (structure desc1, structure desc2) of
74+ (Nothing, Nothing) | flex desc1 == Flexible && flex desc1 == Flexible -> merge
59 (Nothing, _) | flex desc1 == Flexible -> merge2
75 (Nothing, _) | flex desc1 == Flexible -> merge2
60 (_, Nothing) | flex desc2 == Flexible -> merge1
76 (_, Nothing) | flex desc2 == Flexible -> merge1
61
77
@@ -68,11 +84,11 @@ actuallyUnify variable1 variable2 = do
68 (Just type1, Just type2) ->
84 (Just type1, Just type2) ->
69 case (type1,type2) of
85 case (type1,type2) of
70 (App1 term1 term2, App1 term1' term2') ->
86 (App1 term1 term2, App1 term1' term2') ->
71− do merge1
87+ do merge
72 unify term1 term1'
88 unify term1 term1'
73 unify term2 term2'
89 unify term2 term2'
74 (Fun1 term1 term2, Fun1 term1' term2') ->
90 (Fun1 term1 term2, Fun1 term1' term2') ->
75− do merge1
91+ do merge
76 unify term1 term1'
92 unify term1 term1'
77 unify term2 term2'
93 unify term2 term2'
78
94