git.iko.soy/elk
on 63243ca help sign in
elk/compiler/Type/State.hs
204 lines 6.9 kB history raw
1{-# OPTIONS_GHC -W #-}
2module Type.State where
4import Type.Type
5import qualified Data.Map as Map
6import qualified Data.UnionFind.IO as UF
7import Control.Monad.State
8import Control.Applicative ((<$>),(<*>), Applicative)
9import qualified Data.Traversable as Traversable
10import Text.PrettyPrint as P
11import SourceSyntax.PrettyPrint
12import SourceSyntax.Location
13import qualified Type.Alias as Alias
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 = [] }
27type Env = Map.Map String Variable
29-- Keeps track of the environment, type variable pool, and a list of errors
30data SolverState = SS {
31 sEnv :: Env,
32 sSavedEnv :: Env,
33 sPool :: Pool,
34 sMark :: Int,
35 sErrors :: [Alias.Rules -> IO P.Doc]
38initialState = SS {
39 sEnv = Map.empty,
40 sSavedEnv = Map.empty,
41 sPool = emptyPool,
42 sMark = noMark + 1, -- The mark must never be equal to noMark!
43 sErrors = []
46modifyEnv f = modify $ \state -> state { sEnv = f (sEnv state) }
47modifyPool f = modify $ \state -> state { sPool = f (sPool state) }
49addError span hint t1 t2 =
50 modify $ \state -> state { sErrors = makeError : sErrors state }
51 where
52 makeError rules = do
53 let prettiest = pretty . Alias.realias rules
54 t1' <- prettiest <$> toSrcType t1
55 t2' <- prettiest <$> toSrcType t2
56 return . P.vcat $
57 [ P.text $ "Type error" ++ location ++ ":"
58 , maybe P.empty P.text hint
59 , display $ case span of { NoSpan msg -> msg ; Span _ _ msg -> msg }
60 , P.text " Expected Type:" <+> t1'
61 , P.text " Actual Type:" <+> t2'
62 ]
64 location = case span of
65 NoSpan _ -> ""
66 Span p1 p2 _ ->
67 if line p1 == line p2 then " on line " ++ show (line p1)
68 else " between lines " ++ show (line p1) ++ " and " ++ show (line p2)
70 display msg =
71 P.vcat [ P.text $ concatMap ("\n "++) (lines msg)
72 , P.text " " ]
75switchToPool pool = modifyPool (\_ -> pool)
77getPool :: StateT SolverState IO Pool
78getPool = sPool <$> get
80getEnv :: StateT SolverState IO Env
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