git.iko.soy/elk
on 51dfa67 help sign in
elk/compiler/Type/State.hs
201 lines 6.9 kB history raw
1module Type.State where
3import Type.Type
4import qualified Data.Map as Map
5import qualified Data.List as List
6import qualified Type.Environment as Env
7import qualified Data.UnionFind.IO as UF
8import Control.Monad.State
9import Control.Applicative ((<$>),(<*>), Applicative)
10import qualified Data.Traversable as Traversable
11import Text.PrettyPrint as P
12import SourceSyntax.PrettyPrint
13import SourceSyntax.Location
15-- Pool
16-- Holds a bunch of variables
17-- The rank of each variable is less than or equal to the pool's "maxRank"
18-- The young pool exists to make it possible to identify these vars in constant time.
20data Pool = Pool {
21 maxRank :: Int,
22 inhabitants :: [Variable]
23} deriving Show
25emptyPool = Pool { maxRank = outermostRank, inhabitants = [] }
27-- Keeps track of the environment, type variable pool, and a list of errors
28data SolverState = SS {
29 sEnv :: Map.Map String Variable,
30 sSavedEnv :: Map.Map String Variable,
31 sPool :: Pool,
32 sMark :: Int,
33 sErrors :: [IO P.Doc]
36initialState = SS {
37 sEnv = Map.empty,
38 sSavedEnv = Map.empty,
39 sPool = emptyPool,
40 sMark = noMark + 1, -- The mark must never be equal to noMark!
41 sErrors = []
44modifyEnv f = modify $ \state -> state { sEnv = f (sEnv state) }
45modifyPool f = modify $ \state -> state { sPool = f (sPool state) }
47addError span message t1 t2 =
48 modify $ \state -> state { sErrors = err : sErrors state }
49 where
50 err = makeError <$> extraPretty t1 <*> extraPretty t2
52 location = case span of
53 NoSpan msg -> ""
54 Span p1 p2 msg ->
55 if line p1 == line p2 then " on line " ++ show (line p1)
56 else " between lines " ++ show (line p1) ++ " and " ++ show (line p2)
58 display msg = if null msg then "\n"
59 else "\n" ++ unlines (map (" "++) $ lines msg)
61 src = case span of
62 NoSpan msg -> display msg
63 Span _ _ msg -> display msg
65 makeError pt1 pt2 =
66 P.vcat [ P.text $ "Type error" ++ location ++ ":"
67 , if null message then empty else P.vcat . map P.text $ lines message
68 , P.text src
69 , P.text " Expected Type:" <+> pt1
70 , P.text " Actual Type:" <+> pt2 <> P.text "\n"
71 ]
73switchToPool pool = modifyPool (\_ -> pool)
75getPool :: StateT SolverState IO Pool
76getPool = sPool <$> get
78getEnv :: StateT SolverState IO (Map.Map String Variable)
79getEnv = sEnv <$> get
81saveLocalEnv :: StateT SolverState IO ()
82saveLocalEnv = do
83 env <- sEnv <$> get
84 modify $ \state -> state { sSavedEnv = env }
86uniqueMark :: StateT SolverState IO Int
87uniqueMark = do
88 state <- get
89 let mark = sMark state
90 put $ state { sMark = mark + 1 }
91 return mark
93nextRankPool :: StateT SolverState IO Pool
94nextRankPool = do
95 pool <- getPool
96 return $ Pool { maxRank = maxRank pool + 1, inhabitants = [] }
98register :: Variable -> StateT SolverState IO Variable
99register variable = do
100 modifyPool $ \pool -> pool { inhabitants = variable : inhabitants pool }
101 return variable
103introduce :: Variable -> StateT SolverState IO Variable
104introduce variable = do
105 pool <- getPool
106 liftIO $ UF.modifyDescriptor variable (\desc -> desc { rank = maxRank pool })
107 register variable
109flatten :: Type -> StateT SolverState IO Variable
110flatten term =
111 case term of
112 VarN v -> return v
113 TermN t -> do
114 flatStructure <- traverseTerm flatten t
115 pool <- getPool
116 var <- liftIO . UF.fresh $ Descriptor {
117 structure = Just flatStructure,
118 rank = maxRank pool,
119 flex = Flexible,
120 name = Nothing,
121 copy = Nothing,
122 mark = noMark
123 }
124 register var
126makeInstance :: Variable -> StateT SolverState IO Variable
127makeInstance var = do
128 alreadyCopied <- uniqueMark
129 freshVar <- makeCopy alreadyCopied var
130 restore alreadyCopied var
131 return freshVar
133makeCopy :: Int -> Variable -> StateT SolverState IO Variable
134makeCopy alreadyCopied variable = do
135 desc <- liftIO $ UF.descriptor variable
136 case () of
137 () | mark desc == alreadyCopied ->
138 case copy desc of
139 Just v -> return v
140 Nothing -> error "This should be impossible."
142 | rank desc /= noRank || flex desc == Constant ->
143 return variable
145 | otherwise -> do
146 pool <- getPool
147 newVar <- liftIO $ UF.fresh $ Descriptor {
148 structure = Nothing,
149 rank = maxRank pool,
150 mark = noMark,
151 flex = case flex desc of
152 Is s -> Is s
153 _ -> Flexible,
154 copy = Nothing,
155 name = case flex desc of
156 Rigid -> Nothing
157 _ -> name desc
158 }
159 register newVar
161 -- Link the original variable to the new variable. This lets us
162 -- avoid making multiple copies of the variable we are instantiating.
163 --
164 -- Need to do this before recursively copying the structure of
165 -- the variable to avoid looping on cyclic terms.
166 liftIO $ UF.modifyDescriptor variable $ \desc ->
167 desc { mark = alreadyCopied, copy = Just newVar }
169 -- Now we recursively copy the structure of the variable.
170 -- We have already marked the variable as copied, so we
171 -- will not repeat this work or crawl this variable again.
172 case structure desc of
173 Nothing -> return newVar
174 Just term -> do
175 newTerm <- traverseTerm (makeCopy alreadyCopied) term
176 liftIO $ UF.modifyDescriptor newVar $ \desc ->
177 desc { structure = Just newTerm }
178 return newVar
180restore :: Int -> Variable -> StateT SolverState IO Variable
181restore alreadyCopied variable = do
182 desc <- liftIO $ UF.descriptor variable
183 if mark desc /= alreadyCopied
184 then return variable
185 else do
186 restoredStructure <-
187 Traversable.traverse (traverseTerm (restore alreadyCopied)) (structure desc)
188 liftIO $ UF.modifyDescriptor variable $ \desc ->
189 desc { mark = noMark, rank = noRank, structure = restoredStructure }
190 return variable
192traverseTerm :: (Monad f, Applicative f) => (a -> f b) -> Term1 a -> f (Term1 b)
193traverseTerm f term =
194 case term of
195 App1 a b -> App1 <$> f a <*> f b
196 Fun1 a b -> Fun1 <$> f a <*> f b
197 Var1 x -> Var1 <$> f x
198 EmptyRecord1 -> return EmptyRecord1
199 Record1 fields ext ->
200 Record1 <$> Traversable.traverse (mapM f) fields <*> f ext