git.iko.soy/elk
on 727d708 help sign in
elk/compiler/Type/State.hs
191 lines 6.3 kB history raw
1{-# LANGUAGE MultiWayIf #-}
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
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 message t1 t2 =
48 modify $ \state -> state { sErrors = err : sErrors state }
49 where
50 wordify = P.fsep . map P.text . words
51 msg = wordify message
52 width = maximum . map length . lines $ render msg
53 spaces = List.replicate (width - 15 - 3) ' '
54 err = makeError <$> extraPretty t1 <*> extraPretty t2
55 makeError pt1 pt2 =
56 P.vcat [ P.text $ "Type error" ++ spaces ++ "line ???"
57 , P.text (List.replicate width '-')
58 , msg <> P.text "\n"
59 , P.text " Expected Type:" <+> pt1
60 , P.text " Actual Type:" <+> pt2 <> P.text "\n"
61 ]
63switchToPool pool = modifyPool (\_ -> pool)
65getPool :: StateT SolverState IO Pool
66getPool = sPool <$> get
68getEnv :: StateT SolverState IO (Map.Map String Variable)
69getEnv = sEnv <$> get
71saveLocalEnv :: StateT SolverState IO ()
72saveLocalEnv = do
73 env <- sEnv <$> get
74 modify $ \state -> state { sSavedEnv = env }
76uniqueMark :: StateT SolverState IO Int
77uniqueMark = do
78 state <- get
79 let mark = sMark state
80 put $ state { sMark = mark + 1 }
81 return mark
83nextRankPool :: StateT SolverState IO Pool
84nextRankPool = do
85 pool <- getPool
86 return $ Pool { maxRank = maxRank pool + 1, inhabitants = [] }
88register :: Variable -> StateT SolverState IO Variable
89register variable = do
90 modifyPool $ \pool -> pool { inhabitants = variable : inhabitants pool }
91 return variable
93introduce :: Variable -> StateT SolverState IO Variable
94introduce variable = do
95 pool <- getPool
96 liftIO $ UF.modifyDescriptor variable (\desc -> desc { rank = maxRank pool })
97 register variable
99flatten :: Type -> StateT SolverState IO Variable
100flatten term =
101 case term of
102 VarN v -> return v
103 TermN t -> do
104 flatStructure <- traverseTerm flatten t
105 pool <- getPool
106 var <- liftIO . UF.fresh $ Descriptor {
107 structure = Just flatStructure,
108 rank = maxRank pool,
109 flex = Flexible,
110 name = Nothing,
111 copy = Nothing,
112 mark = noMark
113 }
114 register var
116makeInstance :: Variable -> StateT SolverState IO Variable
117makeInstance var = do
118 alreadyCopied <- uniqueMark
119 freshVar <- makeCopy alreadyCopied var
120 restore alreadyCopied var
121 return freshVar
123makeCopy :: Int -> Variable -> StateT SolverState IO Variable
124makeCopy alreadyCopied variable = do
125 desc <- liftIO $ UF.descriptor variable
126 if | mark desc == alreadyCopied ->
127 case copy desc of
128 Just v -> return v
129 Nothing -> error "This should be impossible."
131 | rank desc /= noRank || flex desc == Constant ->
132 return variable
134 | otherwise -> do
135 pool <- getPool
136 newVar <- liftIO $ UF.fresh $ Descriptor {
137 structure = Nothing,
138 rank = maxRank pool,
139 mark = noMark,
140 flex = case flex desc of
141 Is s -> Is s
142 _ -> Flexible,
143 copy = Nothing,
144 name = case flex desc of
145 Rigid -> Nothing
146 _ -> name desc
147 }
149 register newVar
151 -- Link the original variable to the new variable. This lets us
152 -- avoid making multiple copies of the variable we are instantiating.
153 --
154 -- Need to do this before recursively copying the structure of
155 -- the variable to avoid looping on cyclic terms.
156 liftIO $ UF.modifyDescriptor variable $ \desc ->
157 desc { mark = alreadyCopied, copy = Just newVar }
159 -- Now we recursively copy the structure of the variable.
160 -- We have already marked the variable as copied, so we
161 -- will not repeat this work or crawl this variable again.
162 case structure desc of
163 Nothing -> return newVar
164 Just term -> do
165 newTerm <- traverseTerm (makeCopy alreadyCopied) term
166 liftIO $ UF.modifyDescriptor newVar $ \desc ->
167 desc { structure = Just newTerm }
168 return newVar
170restore :: Int -> Variable -> StateT SolverState IO Variable
171restore alreadyCopied variable = do
172 desc <- liftIO $ UF.descriptor variable
173 if mark desc /= alreadyCopied
174 then return variable
175 else do
176 restoredStructure <-
177 Traversable.traverse (traverseTerm (restore alreadyCopied)) (structure desc)
178 liftIO $ UF.modifyDescriptor variable $ \desc ->
179 desc { mark = noMark, rank = noRank, structure = restoredStructure }
180 return variable
182traverseTerm :: (Monad f, Applicative f) => (a -> f b) -> Term1 a -> f (Term1 b)
183traverseTerm f term =
184 case term of
185 App1 a b -> App1 <$> f a <*> f b
186 Fun1 a b -> Fun1 <$> f a <*> f b
187 Var1 x -> Var1 <$> f x
188 EmptyRecord1 -> return EmptyRecord1
189 Record1 fields ext ->
190 Record1 <$> Traversable.traverse (mapM f) fields <*> f ext