git.iko.soy/elk
on 6f75310 help sign in
elk/compiler/Type/State.hs
206 lines 7.0 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
14import qualified SourceSyntax.Type as Src
15import qualified Type.Alias as Alias
17-- Pool
18-- Holds a bunch of variables
19-- The rank of each variable is less than or equal to the pool's "maxRank"
20-- The young pool exists to make it possible to identify these vars in constant time.
22data Pool = Pool {
23 maxRank :: Int,
24 inhabitants :: [Variable]
25} deriving Show
27emptyPool = Pool { maxRank = outermostRank, inhabitants = [] }
29type Env = Map.Map String Variable
31-- Keeps track of the environment, type variable pool, and a list of errors
32data SolverState = SS {
33 sEnv :: Env,
34 sSavedEnv :: Env,
35 sPool :: Pool,
36 sMark :: Int,
37 sErrors :: [Alias.Rules -> IO P.Doc]
40initialState = SS {
41 sEnv = Map.empty,
42 sSavedEnv = Map.empty,
43 sPool = emptyPool,
44 sMark = noMark + 1, -- The mark must never be equal to noMark!
45 sErrors = []
48modifyEnv f = modify $ \state -> state { sEnv = f (sEnv state) }
49modifyPool f = modify $ \state -> state { sPool = f (sPool state) }
51addError span hint t1 t2 =
52 modify $ \state -> state { sErrors = makeError : sErrors state }
53 where
54 makeError rules = do
55 let prettiest = pretty . Alias.realias rules
56 t1' <- prettiest <$> toSrcType t1
57 t2' <- prettiest <$> toSrcType t2
58 return . P.vcat $
59 [ P.text $ "Type error" ++ location ++ ":"
60 , maybe P.empty P.text hint
61 , display $ case span of { NoSpan msg -> msg ; Span _ _ msg -> msg }
62 , P.text " Expected Type:" <+> t1'
63 , P.text " Actual Type:" <+> t2'
64 ]
66 location = case span of
67 NoSpan msg -> ""
68 Span p1 p2 msg ->
69 if line p1 == line p2 then " on line " ++ show (line p1)
70 else " between lines " ++ show (line p1) ++ " and " ++ show (line p2)
72 display msg =
73 P.vcat [ P.text $ concatMap ("\n "++) (lines msg)
74 , P.text " " ]
77switchToPool pool = modifyPool (\_ -> pool)
79getPool :: StateT SolverState IO Pool
80getPool = sPool <$> get
82getEnv :: StateT SolverState IO Env
83getEnv = sEnv <$> get
85saveLocalEnv :: StateT SolverState IO ()
86saveLocalEnv = do
87 env <- sEnv <$> get
88 modify $ \state -> state { sSavedEnv = env }
90uniqueMark :: StateT SolverState IO Int
91uniqueMark = do
92 state <- get
93 let mark = sMark state
94 put $ state { sMark = mark + 1 }
95 return mark
97nextRankPool :: StateT SolverState IO Pool
98nextRankPool = do
99 pool <- getPool
100 return $ Pool { maxRank = maxRank pool + 1, inhabitants = [] }
102register :: Variable -> StateT SolverState IO Variable
103register variable = do
104 modifyPool $ \pool -> pool { inhabitants = variable : inhabitants pool }
105 return variable
107introduce :: Variable -> StateT SolverState IO Variable
108introduce variable = do
109 pool <- getPool
110 liftIO $ UF.modifyDescriptor variable (\desc -> desc { rank = maxRank pool })
111 register variable
113flatten :: Type -> StateT SolverState IO Variable
114flatten term =
115 case term of
116 VarN v -> return v
117 TermN t -> do
118 flatStructure <- traverseTerm flatten t
119 pool <- getPool
120 var <- liftIO . UF.fresh $ Descriptor {
121 structure = Just flatStructure,
122 rank = maxRank pool,
123 flex = Flexible,
124 name = Nothing,
125 copy = Nothing,
126 mark = noMark
127 }
128 register var
130makeInstance :: Variable -> StateT SolverState IO Variable
131makeInstance var = do
132 alreadyCopied <- uniqueMark
133 freshVar <- makeCopy alreadyCopied var
134 restore alreadyCopied var
135 return freshVar
137makeCopy :: Int -> Variable -> StateT SolverState IO Variable
138makeCopy alreadyCopied variable = do
139 desc <- liftIO $ UF.descriptor variable
140 case () of
141 () | mark desc == alreadyCopied ->
142 case copy desc of
143 Just v -> return v
144 Nothing -> error $ "Error copying type variable. This should be impossible." ++
145 " Please report an error to the github repo!"
147 | rank desc /= noRank || flex desc == Constant ->
148 return variable
150 | otherwise -> do
151 pool <- getPool
152 newVar <- liftIO $ UF.fresh $ Descriptor {
153 structure = Nothing,
154 rank = maxRank pool,
155 mark = noMark,
156 flex = case flex desc of
157 Is s -> Is s
158 _ -> Flexible,
159 copy = Nothing,
160 name = case flex desc of
161 Rigid -> Nothing
162 _ -> name desc
163 }
164 register newVar
166 -- Link the original variable to the new variable. This lets us
167 -- avoid making multiple copies of the variable we are instantiating.
168 --
169 -- Need to do this before recursively copying the structure of
170 -- the variable to avoid looping on cyclic terms.
171 liftIO $ UF.modifyDescriptor variable $ \desc ->
172 desc { mark = alreadyCopied, copy = Just newVar }
174 -- Now we recursively copy the structure of the variable.
175 -- We have already marked the variable as copied, so we
176 -- will not repeat this work or crawl this variable again.
177 case structure desc of
178 Nothing -> return newVar
179 Just term -> do
180 newTerm <- traverseTerm (makeCopy alreadyCopied) term
181 liftIO $ UF.modifyDescriptor newVar $ \desc ->
182 desc { structure = Just newTerm }
183 return newVar
185restore :: Int -> Variable -> StateT SolverState IO Variable
186restore alreadyCopied variable = do
187 desc <- liftIO $ UF.descriptor variable
188 if mark desc /= alreadyCopied
189 then return variable
190 else do
191 restoredStructure <-
192 Traversable.traverse (traverseTerm (restore alreadyCopied)) (structure desc)
193 liftIO $ UF.modifyDescriptor variable $ \desc ->
194 desc { mark = noMark, rank = noRank, structure = restoredStructure }
195 return variable
197traverseTerm :: (Monad f, Applicative f) => (a -> f b) -> Term1 a -> f (Term1 b)
198traverseTerm f term =
199 case term of
200 App1 a b -> App1 <$> f a <*> f b
201 Fun1 a b -> Fun1 <$> f a <*> f b
202 Var1 x -> Var1 <$> f x
203 EmptyRecord1 -> return EmptyRecord1
204 Record1 fields ext ->
205 Record1 <$> Traversable.traverse (mapM f) fields <*> f ext