@@ -3,15 +3,17 @@ module Type.State where
33
44import Type.Type
55import qualified Data.Map as Map
6+import qualified Data.List as List
67import qualified Type.Environment as Env
78import qualified Data.UnionFind.IO as UF
89import Control.Monad.State
910import Control.Applicative ((<$>),(<*>), Applicative)
1011import qualified Data.Traversable as Traversable
11−
12−-- todo: remove later
12+import Text.PrettyPrint as P
1313import SourceSyntax.PrettyPrint
1414
15+debug e = {-- liftIO e --} return ()
16+
1517-- Pool
1618-- Holds a bunch of variables
1719-- The rank of each variable is less than or equal to the pool's "maxRank"
@@ -25,14 +27,23 @@ data Pool = Pool {
2527emptyPool = Pool { maxRank = 0, inhabitants = [] }
2628
2729-- 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])
2931
3032-- The mark must never be equal to noMark!
3133initialState = (Map.empty, emptyPool, noMark + 1, [])
3234
3335modifyEnv f = modify $ \(env, pool, mark, errors) -> (f env, pool, mark, errors)
3436modifyPool 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+ ]
3647
3748switchToPool pool = modifyPool (\_ -> pool)
3849
@@ -87,23 +98,30 @@ flatten term =
8798
8899makeInstance :: Variable -> StateT SolverState IO Variable
89100makeInstance var = do
101+-- liftIO $ putStrLn ""
102+-- liftIO $ print $ pretty var
90103 alreadyCopied <- uniqueMark
91104 freshVar <- makeCopy alreadyCopied var
92105 restore alreadyCopied var
106+-- liftIO $ print $ pretty freshVar
93107 return freshVar
94108
95109makeCopy :: Int -> Variable -> StateT SolverState IO Variable
96110makeCopy alreadyCopied variable = do
111+-- liftIO $ putStr "Copying: "
97112 desc <- liftIO $ UF.descriptor variable
98113 if | mark desc == alreadyCopied ->
114+ do debug $ putStrLn "Already Copied"
99115 case copy desc of
100116 Just v -> return v
101117 Nothing -> error "This should be impossible."
102118
103− | mark desc /= noRank || flex desc == Constant ->
104− return variable
119+ | rank desc /= noRank || flex desc == Constant ->
120+ do debug $ putStr "did not make a copy: " >> print (mark desc, noRank, flex desc)
121+ return variable
105122
106123 | otherwise -> do
124+ debug $ print "no problems!"
107125 pool <- getPool
108126 newVar <- liftIO $ UF.fresh $ Descriptor {
109127 structure = Nothing,
@@ -118,12 +136,17 @@ makeCopy alreadyCopied variable = do
118136
119137 register newVar
120138
121− -- Link the original variable to the new variable
122− -- Need to do this before recursively copying to
123− -- avoid looping on cyclic terms.
139+ -- Link the original variable to the new variable. This lets us
140+ -- avoid making multiple copies of the variable we are instantiating.
141+ --
142+ -- Need to do this before recursively copying the structure of
143+ -- the variable to avoid looping on cyclic terms.
124144 liftIO $ UF.modifyDescriptor variable $ \desc ->
125145 desc { mark = alreadyCopied, copy = Just newVar }
126146
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.
127150 case structure desc of
128151 Nothing -> return newVar
129152 Just term -> do
@@ -134,13 +157,19 @@ makeCopy alreadyCopied variable = do
134157
135158restore :: Int -> Variable -> StateT SolverState IO Variable
136159restore alreadyCopied variable = do
160+ debug $ putStr "Restoring: "
137161 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"
139168 restoredStructure <-
140169 case structure desc of
141170 Nothing -> return Nothing
142171 Just term -> Just <$> traverseTerm (restore alreadyCopied) term
143− liftIO $ UF.modifyDescriptor variable $ \desc ->
172+ debug $ UF.modifyDescriptor variable $ \desc ->
144173 desc { mark = noMark, rank = noRank, structure = restoredStructure }
145174 return variable
146175