git.iko.soy/elk
on 003ebfd help sign in
elk/compiler/Type/State.hs
177 lines 6.1 kB history raw
1{-# OPTIONS_GHC -XMultiWayIf #-}
2module Type.State where
4import Type.Type
5import qualified Data.Map as Map
6import qualified Data.List as List
7import qualified Type.Environment as Env
8import qualified Data.UnionFind.IO as UF
9import Control.Monad.State
10import Control.Applicative ((<$>),(<*>), Applicative)
11import qualified Data.Traversable as Traversable
12import Text.PrettyPrint as P
13import SourceSyntax.PrettyPrint
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
28type SolverState = (Map.Map String Variable, Pool, Int, [IO P.Doc])
30-- The mark must never be equal to noMark!
31initialState = (Map.empty, emptyPool, noMark + 1, [])
33modifyEnv f = modify $ \(env, pool, mark, errors) -> (f env, pool, mark, errors)
34modifyPool f = modify $ \(env, pool, mark, errors) -> (env, f pool, mark, errors)
35addError message t1 t2 =
36 modify $ \(env, pool, mark, errors) -> (env, pool, mark, err : errors)
37 where
38 wordify = P.fsep . map P.text . words
39 msg = wordify message
40 width = maximum . map length . lines $ render msg
41 spaces = List.replicate (width - 15 - 3) ' '
42 err = makeError <$> extraPretty t1 <*> extraPretty t2
43 makeError pt1 pt2 =
44 P.vcat [ P.text $ "Type error" ++ spaces ++ "line ???"
45 , P.text (List.replicate width '-')
46 , msg <> P.text "\n"
47 , P.text " Expected Type:" <+> pt1
48 , P.text " Actual Type:" <+> pt2 <> P.text "\n"
49 , wordify "The error comes from:" <> P.text "\n"
50 , P.nest 3 (P.text "???")
51 ]
53switchToPool pool = modifyPool (\_ -> pool)
55getPool :: StateT SolverState IO Pool
56getPool = do
57 (_, pool, _, _) <- get
58 return pool
60getEnv :: StateT SolverState IO (Map.Map String Variable)
61getEnv = do
62 (env, _, _, _) <- get
63 return env
65uniqueMark :: StateT SolverState IO Int
66uniqueMark = do
67 (env, pool, mark, errs) <- get
68 put (env, pool, mark+1, errs)
69 return mark
71nextRankPool :: StateT SolverState IO Pool
72nextRankPool = do
73 pool <- getPool
74 return $ Pool { maxRank = maxRank pool + 1, inhabitants = [] }
76register :: Variable -> StateT SolverState IO Variable
77register variable = do
78 modifyPool $ \pool -> pool { inhabitants = variable : inhabitants pool }
79 return variable
81introduce :: Variable -> StateT SolverState IO Variable
82introduce variable = do
83 pool <- getPool
84 liftIO $ UF.modifyDescriptor variable (\desc -> desc { rank = maxRank pool })
85 register variable
87flatten :: Type -> StateT SolverState IO Variable
88flatten term =
89 case term of
90 VarN v -> return v
91 TermN t -> do
92 flatStructure <- traverseTerm flatten t
93 pool <- getPool
94 var <- liftIO . UF.fresh $ Descriptor {
95 structure = Just flatStructure,
96 rank = maxRank pool,
97 flex = Flexible,
98 name = Nothing,
99 copy = Nothing,
100 mark = noMark
101 }
102 register var
104makeInstance :: Variable -> StateT SolverState IO Variable
105makeInstance var = do
106 alreadyCopied <- uniqueMark
107 freshVar <- makeCopy alreadyCopied var
108 restore alreadyCopied var
109 return freshVar
111makeCopy :: Int -> Variable -> StateT SolverState IO Variable
112makeCopy alreadyCopied variable = do
113 desc <- liftIO $ UF.descriptor variable
114 if | mark desc == alreadyCopied ->
115 case copy desc of
116 Just v -> return v
117 Nothing -> error "This should be impossible."
119 | rank desc /= noRank || flex desc == Constant ->
120 return variable
122 | otherwise -> do
123 pool <- getPool
124 newVar <- liftIO $ UF.fresh $ Descriptor {
125 structure = Nothing,
126 rank = maxRank pool,
127 mark = noMark,
128 flex = Flexible,
129 copy = Nothing,
130 name = case flex desc of
131 Rigid -> Nothing
132 _ -> name desc
133 }
135 register newVar
137 -- Link the original variable to the new variable. This lets us
138 -- avoid making multiple copies of the variable we are instantiating.
139 --
140 -- Need to do this before recursively copying the structure of
141 -- the variable to avoid looping on cyclic terms.
142 liftIO $ UF.modifyDescriptor variable $ \desc ->
143 desc { mark = alreadyCopied, copy = Just newVar }
145 -- Now we recursively copy the structure of the variable.
146 -- We have already marked the variable as copied, so we
147 -- will not repeat this work or crawl this variable again.
148 case structure desc of
149 Nothing -> return newVar
150 Just term -> do
151 newTerm <- traverseTerm (makeCopy alreadyCopied) term
152 liftIO $ UF.modifyDescriptor newVar $ \desc ->
153 desc { structure = Just newTerm }
154 return newVar
156restore :: Int -> Variable -> StateT SolverState IO Variable
157restore alreadyCopied variable = do
158 desc <- liftIO $ UF.descriptor variable
159 if mark desc /= alreadyCopied
160 then return variable
161 else do
162 restoredStructure <-
163 Traversable.traverse (traverseTerm (restore alreadyCopied)) (structure desc)
164 liftIO $ UF.modifyDescriptor variable $ \desc ->
165 desc { mark = noMark, rank = noRank, structure = restoredStructure }
166 return variable
168traverseTerm :: (Monad f, Applicative f) => (a -> f b) -> Term1 a -> f (Term1 b)
169traverseTerm f term =
170 case term of
171 App1 a b -> App1 <$> f a <*> f b
172 Fun1 a b -> Fun1 <$> f a <*> f b
173 Var1 x -> Var1 <$> f x
174 EmptyRecord1 -> return EmptyRecord1
175 Record1 fields ext ->
176 Record1 <$> Traversable.traverse (mapM f) fields <*> f ext