git.iko.soy/elk
on 4bec310 help sign in
elk/compiler/Type/State.hs
196 lines 6.6 kB history raw
1{-# OPTIONS_GHC -W #-}
2module Type.State where
4import Control.Applicative ((<$>),(<*>), Applicative)
5import Control.Monad.State
6import qualified Data.Map as Map
7import qualified Data.Traversable as Traversable
8import qualified Data.UnionFind.IO as UF
10import qualified SourceSyntax.Annotation as A
11import SourceSyntax.PrettyPrint
12import Text.PrettyPrint as P
13import qualified Type.Alias as Alias
14import Type.Type
16-- Pool
17-- Holds a bunch of variables
18-- The rank of each variable is less than or equal to the pool's "maxRank"
19-- The young pool exists to make it possible to identify these vars in constant time.
21data Pool = Pool {
22 maxRank :: Int,
23 inhabitants :: [Variable]
24} deriving Show
26emptyPool = Pool { maxRank = outermostRank, inhabitants = [] }
28type Env = Map.Map String Variable
30-- Keeps track of the environment, type variable pool, and a list of errors
31data SolverState = SS {
32 sEnv :: Env,
33 sSavedEnv :: Env,
34 sPool :: Pool,
35 sMark :: Int,
36 sErrors :: [Alias.Rules -> IO P.Doc]
39initialState = SS {
40 sEnv = Map.empty,
41 sSavedEnv = Map.empty,
42 sPool = emptyPool,
43 sMark = noMark + 1, -- The mark must never be equal to noMark!
44 sErrors = []
47modifyEnv f = modify $ \state -> state { sEnv = f (sEnv state) }
48modifyPool f = modify $ \state -> state { sPool = f (sPool state) }
50addError region hint t1 t2 =
51 modify $ \state -> state { sErrors = makeError : sErrors state }
52 where
53 makeError rules = do
54 let prettiest = pretty . Alias.realias rules
55 t1' <- prettiest <$> toSrcType t1
56 t2' <- prettiest <$> toSrcType t2
57 return . P.vcat $
58 [ P.text "Type error" <+> pretty region <> P.colon
59 , maybe P.empty P.text hint
60 , P.text ""
61 , P.nest 8 $ A.getRegionDocs region
62 , P.text ""
63 , P.text " Expected Type:" <+> t1'
64 , P.text " Actual Type:" <+> t2'
65 ]
67switchToPool pool = modifyPool (\_ -> pool)
69getPool :: StateT SolverState IO Pool
70getPool = sPool <$> get
72getEnv :: StateT SolverState IO Env
73getEnv = sEnv <$> get
75saveLocalEnv :: StateT SolverState IO ()
76saveLocalEnv = do
77 env <- sEnv <$> get
78 modify $ \state -> state { sSavedEnv = env }
80uniqueMark :: StateT SolverState IO Int
81uniqueMark = do
82 state <- get
83 let mark = sMark state
84 put $ state { sMark = mark + 1 }
85 return mark
87nextRankPool :: StateT SolverState IO Pool
88nextRankPool = do
89 pool <- getPool
90 return $ Pool { maxRank = maxRank pool + 1, inhabitants = [] }
92register :: Variable -> StateT SolverState IO Variable
93register variable = do
94 modifyPool $ \pool -> pool { inhabitants = variable : inhabitants pool }
95 return variable
97introduce :: Variable -> StateT SolverState IO Variable
98introduce variable = do
99 pool <- getPool
100 liftIO $ UF.modifyDescriptor variable (\desc -> desc { rank = maxRank pool })
101 register variable
103flatten :: Type -> StateT SolverState IO Variable
104flatten term =
105 case term of
106 VarN v -> return v
107 TermN t -> do
108 flatStructure <- traverseTerm flatten t
109 pool <- getPool
110 var <- liftIO . UF.fresh $ Descriptor {
111 structure = Just flatStructure,
112 rank = maxRank pool,
113 flex = Flexible,
114 name = Nothing,
115 copy = Nothing,
116 mark = noMark
117 }
118 register var
120makeInstance :: Variable -> StateT SolverState IO Variable
121makeInstance var = do
122 alreadyCopied <- uniqueMark
123 freshVar <- makeCopy alreadyCopied var
124 restore alreadyCopied var
125 return freshVar
127makeCopy :: Int -> Variable -> StateT SolverState IO Variable
128makeCopy alreadyCopied variable = do
129 desc <- liftIO $ UF.descriptor variable
130 case () of
131 () | mark desc == alreadyCopied ->
132 case copy desc of
133 Just v -> return v
134 Nothing -> error $ "Error copying type variable. This should be impossible." ++
135 " Please report an error to the github repo!"
137 | rank desc /= noRank || flex desc == Constant ->
138 return variable
140 | otherwise -> do
141 pool <- getPool
142 newVar <- liftIO $ UF.fresh $ Descriptor {
143 structure = Nothing,
144 rank = maxRank pool,
145 mark = noMark,
146 flex = case flex desc of
147 Is s -> Is s
148 _ -> Flexible,
149 copy = Nothing,
150 name = case flex desc of
151 Rigid -> Nothing
152 _ -> name desc
153 }
154 register newVar
156 -- Link the original variable to the new variable. This lets us
157 -- avoid making multiple copies of the variable we are instantiating.
158 --
159 -- Need to do this before recursively copying the structure of
160 -- the variable to avoid looping on cyclic terms.
161 liftIO $ UF.modifyDescriptor variable $ \desc ->
162 desc { mark = alreadyCopied, copy = Just newVar }
164 -- Now we recursively copy the structure of the variable.
165 -- We have already marked the variable as copied, so we
166 -- will not repeat this work or crawl this variable again.
167 case structure desc of
168 Nothing -> return newVar
169 Just term -> do
170 newTerm <- traverseTerm (makeCopy alreadyCopied) term
171 liftIO $ UF.modifyDescriptor newVar $ \desc ->
172 desc { structure = Just newTerm }
173 return newVar
175restore :: Int -> Variable -> StateT SolverState IO Variable
176restore alreadyCopied variable = do
177 desc <- liftIO $ UF.descriptor variable
178 if mark desc /= alreadyCopied
179 then return variable
180 else do
181 restoredStructure <-
182 Traversable.traverse (traverseTerm (restore alreadyCopied)) (structure desc)
183 liftIO $ UF.modifyDescriptor variable $ \desc ->
184 desc { mark = noMark, rank = noRank, structure = restoredStructure }
185 return variable
187traverseTerm :: (Monad f, Applicative f) => (a -> f b) -> Term1 a -> f (Term1 b)
188traverseTerm f term =
189 case term of
190 App1 a b -> App1 <$> f a <*> f b
191 Fun1 a b -> Fun1 <$> f a <*> f b
192 Var1 x -> Var1 <$> f x
193 EmptyRecord1 -> return EmptyRecord1
194 Record1 fields ext ->
195 Record1 <$> Traversable.traverse (mapM f) fields <*> f ext