git.iko.soy/elk
on fbad8ea help sign in
elk/compiler/Type/State.hs
204 lines 7.1 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 defaultMessage = "Something weird is happening with this value:"
67 makeError pt1 pt2 =
68 P.vcat [ P.text $ "Type error" ++ location ++ ":"
69 , P.vcat . map P.text . lines $ if null message then defaultMessage else message
70 , P.text src
71 , P.text " Expected Type:" <+> pt1
72 , P.text " Actual Type:" <+> pt2 <> P.text "\n"
73 ]
75switchToPool pool = modifyPool (\_ -> pool)
77getPool :: StateT SolverState IO Pool
78getPool = sPool <$> get
80getEnv :: StateT SolverState IO (Map.Map String Variable)
81getEnv = sEnv <$> get
83saveLocalEnv :: StateT SolverState IO ()
84saveLocalEnv = do
85 env <- sEnv <$> get
86 modify $ \state -> state { sSavedEnv = env }
88uniqueMark :: StateT SolverState IO Int
89uniqueMark = do
90 state <- get
91 let mark = sMark state
92 put $ state { sMark = mark + 1 }
93 return mark
95nextRankPool :: StateT SolverState IO Pool
96nextRankPool = do
97 pool <- getPool
98 return $ Pool { maxRank = maxRank pool + 1, inhabitants = [] }
100register :: Variable -> StateT SolverState IO Variable
101register variable = do
102 modifyPool $ \pool -> pool { inhabitants = variable : inhabitants pool }
103 return variable
105introduce :: Variable -> StateT SolverState IO Variable
106introduce variable = do
107 pool <- getPool
108 liftIO $ UF.modifyDescriptor variable (\desc -> desc { rank = maxRank pool })
109 register variable
111flatten :: Type -> StateT SolverState IO Variable
112flatten term =
113 case term of
114 VarN v -> return v
115 TermN t -> do
116 flatStructure <- traverseTerm flatten t
117 pool <- getPool
118 var <- liftIO . UF.fresh $ Descriptor {
119 structure = Just flatStructure,
120 rank = maxRank pool,
121 flex = Flexible,
122 name = Nothing,
123 copy = Nothing,
124 mark = noMark
125 }
126 register var
128makeInstance :: Variable -> StateT SolverState IO Variable
129makeInstance var = do
130 alreadyCopied <- uniqueMark
131 freshVar <- makeCopy alreadyCopied var
132 restore alreadyCopied var
133 return freshVar
135makeCopy :: Int -> Variable -> StateT SolverState IO Variable
136makeCopy alreadyCopied variable = do
137 desc <- liftIO $ UF.descriptor variable
138 case () of
139 () | mark desc == alreadyCopied ->
140 case copy desc of
141 Just v -> return v
142 Nothing -> error $ "Error copying type variable. This should be impossible." ++
143 " Please report an error to the github repo!"
145 | rank desc /= noRank || flex desc == Constant ->
146 return variable
148 | otherwise -> do
149 pool <- getPool
150 newVar <- liftIO $ UF.fresh $ Descriptor {
151 structure = Nothing,
152 rank = maxRank pool,
153 mark = noMark,
154 flex = case flex desc of
155 Is s -> Is s
156 _ -> Flexible,
157 copy = Nothing,
158 name = case flex desc of
159 Rigid -> Nothing
160 _ -> name desc
161 }
162 register newVar
164 -- Link the original variable to the new variable. This lets us
165 -- avoid making multiple copies of the variable we are instantiating.
166 --
167 -- Need to do this before recursively copying the structure of
168 -- the variable to avoid looping on cyclic terms.
169 liftIO $ UF.modifyDescriptor variable $ \desc ->
170 desc { mark = alreadyCopied, copy = Just newVar }
172 -- Now we recursively copy the structure of the variable.
173 -- We have already marked the variable as copied, so we
174 -- will not repeat this work or crawl this variable again.
175 case structure desc of
176 Nothing -> return newVar
177 Just term -> do
178 newTerm <- traverseTerm (makeCopy alreadyCopied) term
179 liftIO $ UF.modifyDescriptor newVar $ \desc ->
180 desc { structure = Just newTerm }
181 return newVar
183restore :: Int -> Variable -> StateT SolverState IO Variable
184restore alreadyCopied variable = do
185 desc <- liftIO $ UF.descriptor variable
186 if mark desc /= alreadyCopied
187 then return variable
188 else do
189 restoredStructure <-
190 Traversable.traverse (traverseTerm (restore alreadyCopied)) (structure desc)
191 liftIO $ UF.modifyDescriptor variable $ \desc ->
192 desc { mark = noMark, rank = noRank, structure = restoredStructure }
193 return variable
195traverseTerm :: (Monad f, Applicative f) => (a -> f b) -> Term1 a -> f (Term1 b)
196traverseTerm f term =
197 case term of
198 App1 a b -> App1 <$> f a <*> f b
199 Fun1 a b -> Fun1 <$> f a <*> f b
200 Var1 x -> Var1 <$> f x
201 EmptyRecord1 -> return EmptyRecord1
202 Record1 fields ext ->
203 Record1 <$> Traversable.traverse (mapM f) fields <*> f ext