git.iko.soy/elk
on master help sign in
Remove some debugging stuff and generally clean up the code.

There was one potential error in which a debug needed to be a liftIO, the computation it performed was not optional.

commit4208b5c9de84f2c9a367459aa3381fdb1402bd51 authorEvan Czaplicki <evan@Evans-MacBook-Air.local> dateFri 12 Jul 2013, 11:05 (13 years ago) parentb038782
3 files changed+34−29
compare with master
unifiedsplit
compiler/Type/Constrain/Expression.hs+3−1 compiler/Type/State.hs+4−17 compiler/Type/Unify.hs+27−11
compiler/Type/Constrain/Expression.hs+3−1
@@ -34,6 +34,7 @@ test str =
3434 env <- Env.initialEnvironment
3535 var <- flexibleVar
3636 constraint <- constrain env expression (VarN var)
37+ print =<< extraPretty constraint
3738 (env,_,_,errors) <- execStateT (solve constraint) TS.initialState
3839 forM (Map.toList env) $ \(n,t) -> do
3940 pt <- extraPretty t
@@ -197,7 +198,8 @@ constrainDef env info (pattern, expr, maybeTipe) =
197198
198199 (PVar name, Nothing) ->
199200 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.
201203 let tipe = VarN var
202204 inserts = zipWith (\arg typ -> Map.insert arg (VarN typ)) qs rigidVars
203205 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
1212import Text.PrettyPrint as P
1313import SourceSyntax.PrettyPrint
1414
15−debug e = {-- liftIO e --} return ()
16−
1715-- Pool
1816-- Holds a bunch of variables
1917-- The rank of each variable is less than or equal to the pool's "maxRank"
@@ -24,7 +22,7 @@ data Pool = Pool {
2422 inhabitants :: [Variable]
2523} deriving Show
2624
27−emptyPool = Pool { maxRank = 0, inhabitants = [] }
25+emptyPool = Pool { maxRank = outermostRank, inhabitants = [] }
2826
2927-- Keeps track of the environment, type variable pool, and a list of errors
3028type 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
3634modifyPool f = modify $ \(env, pool, mark, errors) -> (env, f pool, mark, errors)
3735addError message t1 t2 =
3836 modify $ \(env, pool, mark, errors) -> (env, pool, mark, err : errors)
39−
4037 where
4138 wordify = P.fsep . map P.text . words
4239 msg = wordify message
@@ -113,20 +110,16 @@ makeInstance var = do
113110
114111makeCopy :: Int -> Variable -> StateT SolverState IO Variable
115112makeCopy alreadyCopied variable = do
116− debug $ putStr "Copying: "
117113 desc <- liftIO $ UF.descriptor variable
118114 if | mark desc == alreadyCopied ->
119− do debug $ putStrLn "Already Copied"
120115 case copy desc of
121116 Just v -> return v
122117 Nothing -> error "This should be impossible."
123118
124119 | rank desc /= noRank || flex desc == Constant ->
125− do debug $ putStr "did not make a copy: " >> print (mark desc, noRank, flex desc)
126120 return variable
127121
128122 | otherwise -> do
129− debug $ print "no problems!"
130123 pool <- getPool
131124 newVar <- liftIO $ UF.fresh $ Descriptor {
132125 structure = Nothing,
@@ -162,19 +155,13 @@ makeCopy alreadyCopied variable = do
162155
163156restore :: Int -> Variable -> StateT SolverState IO Variable
164157restore alreadyCopied variable = do
165− debug $ putStr "Restoring: "
166158 desc <- liftIO $ UF.descriptor variable
167159 if mark desc /= alreadyCopied
168− then do
169− debug $ putStrLn "not copied, no need to do anything"
170− return variable
160+ then return variable
171161 else do
172− debug $ putStrLn "restoring"
173162 restoredStructure <-
174− case structure desc of
175− Nothing -> return Nothing
176− Just term -> Just <$> traverseTerm (restore alreadyCopied) term
177− debug $ UF.modifyDescriptor variable $ \desc ->
163+ Traversable.traverse (traverseTerm (restore alreadyCopied)) (structure desc)
164+ liftIO $ UF.modifyDescriptor variable $ \desc ->
178165 desc { mark = noMark, rank = noRank, structure = restoredStructure }
179166 return variable
180167
compiler/Type/Unify.hs+27−11
@@ -37,25 +37,41 @@ actuallyUnify variable1 variable2 = do
3737 rank' = min (rank desc1) (rank desc2)
3838
3939 merge1 :: StateT TS.SolverState IO ()
40− merge1 = liftIO $ do
41− UF.union variable2 variable1
42− UF.setDescriptor variable1 (desc1 {
43− flex = flex', name = name', rank = rank', copy = Nothing, mark = noMark })
40+ merge1 =
41+ if rank desc1 < rank desc2 then
42+ liftIO $ do
43+ UF.union variable2 variable1
44+ UF.modifyDescriptor variable1 (\desc -> desc { flex = flex', name = name' })
45+ else
46+ liftIO $ do
47+ UF.union variable1 variable2
48+ UF.modifyDescriptor variable2 (\desc -> desc {
49+ structure = structure desc1, flex = flex', name = name' })
4450
4551 merge2 :: StateT TS.SolverState IO ()
46− merge2 = liftIO $ do
47− UF.union variable1 variable2
48− UF.setDescriptor variable2 (desc2 {
49− flex = flex', name = name', rank = rank', copy = Nothing, mark = noMark })
52+ merge2 =
53+ if rank desc1 < rank desc2 then
54+ liftIO $ do
55+ UF.union variable2 variable1
56+ UF.modifyDescriptor variable2 (\desc -> desc {
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
5064
5165 fresh :: Maybe (Term1 Variable) -> StateT TS.SolverState IO Variable
5266 fresh structure = do
5367 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
5570 }
5671 TS.register var
5772
5873 case (structure desc1, structure desc2) of
74+ (Nothing, Nothing) | flex desc1 == Flexible && flex desc1 == Flexible -> merge
5975 (Nothing, _) | flex desc1 == Flexible -> merge2
6076 (_, Nothing) | flex desc2 == Flexible -> merge1
6177
@@ -68,11 +84,11 @@ actuallyUnify variable1 variable2 = do
6884 (Just type1, Just type2) ->
6985 case (type1,type2) of
7086 (App1 term1 term2, App1 term1' term2') ->
71− do merge1
87+ do merge
7288 unify term1 term1'
7389 unify term2 term2'
7490 (Fun1 term1 term2, Fun1 term1' term2') ->
75− do merge1
91+ do merge
7692 unify term1 term1'
7793 unify term2 term2'
7894