git.iko.soy/elk
on master help sign in
Update Type.State for new AST
f903a1bEvan Czaplicki
src/Type/State.hs+26−11
compare with master
unifiedsplit
@@ -17,7 +17,7 @@ module Type.State
17 where
17 where
18
18
19
19
20−import Control.Monad (forM_, liftM, liftM2)
20+import Control.Monad (forM_, liftM, liftM2, liftM3)
21import Control.Monad.Trans (MonadIO, liftIO)
21import Control.Monad.Trans (MonadIO, liftIO)
22import qualified Data.Map.Strict as Map
22import qualified Data.Map.Strict as Map
23import Data.Map.Strict ((!))
23import Data.Map.Strict ((!))
@@ -143,17 +143,17 @@ flattenHelp maxRank pools aliasDict tipe =
143 PlaceHolder name ->
143 PlaceHolder name ->
144 return (aliasDict ! name)
144 return (aliasDict ! name)
145
145
146− AliasN name args realType ->
146+ AliasN home name args realType ->
147 do flatArgs <- mapM (traverse (flattenHelp maxRank pools aliasDict)) args
147 do flatArgs <- mapM (traverse (flattenHelp maxRank pools aliasDict)) args
148 flatVar <- flattenHelp maxRank pools (Map.fromList flatArgs) realType
148 flatVar <- flattenHelp maxRank pools (Map.fromList flatArgs) realType
149− registerFlatType maxRank pools (Alias name flatArgs flatVar)
149+ registerFlatType maxRank pools (Alias home name flatArgs flatVar)
150
150
151 VarN v ->
151 VarN v ->
152 return v
152 return v
153
153
154− AppN name args ->
154+ AppN home name args ->
155 do flatArgs <- traverse (flattenHelp maxRank pools aliasDict) args
155 do flatArgs <- traverse (flattenHelp maxRank pools aliasDict) args
156− registerFlatType maxRank pools (Structure (App1 name flatArgs))
156+ registerFlatType maxRank pools (Structure (App1 home name flatArgs))
157
157
158 FunN a b ->
158 FunN a b ->
159 do flatA <- flattenHelp maxRank pools aliasDict a
159 do flatA <- flattenHelp maxRank pools aliasDict a
@@ -168,6 +168,15 @@ flattenHelp maxRank pools aliasDict tipe =
168 flatExt <- flattenHelp maxRank pools aliasDict ext
168 flatExt <- flattenHelp maxRank pools aliasDict ext
169 registerFlatType maxRank pools (Structure (Record1 flatFields flatExt))
169 registerFlatType maxRank pools (Structure (Record1 flatFields flatExt))
170
170
171+ UnitN ->
172+ registerFlatType maxRank pools (Structure Unit1)
173+
174+ TupleN a b cs ->
175+ do flatA <- flattenHelp maxRank pools aliasDict a
176+ flatB <- flattenHelp maxRank pools aliasDict b
177+ flatCs <- traverse (flattenHelp maxRank pools aliasDict) cs
178+ registerFlatType maxRank pools (Structure (Tuple1 flatA flatB flatCs))
179+
171
180
172registerFlatType :: Int -> Pools -> Content -> IO Variable
181registerFlatType :: Int -> Pools -> Content -> IO Variable
173registerFlatType maxRank pools content =
182registerFlatType maxRank pools content =
@@ -233,10 +242,10 @@ copyHelp maxRank pools variable =
233 RigidSuper super name ->
242 RigidSuper super name ->
234 UF.setDescriptor newVar $ mkCopyDesc $ FlexSuper super (Just name)
243 UF.setDescriptor newVar $ mkCopyDesc $ FlexSuper super (Just name)
235
244
236− Alias name args realType ->
245+ Alias home name args realType ->
237 do newArgs <- mapM (traverse (copyHelp maxRank pools)) args
246 do newArgs <- mapM (traverse (copyHelp maxRank pools)) args
238 newRealType <- copyHelp maxRank pools realType
247 newRealType <- copyHelp maxRank pools realType
239− UF.setDescriptor newVar $ mkCopyDesc (Alias name newArgs newRealType)
248+ UF.setDescriptor newVar $ mkCopyDesc (Alias home name newArgs newRealType)
240
249
241 Error _ ->
250 Error _ ->
242 return ()
251 return ()
@@ -280,8 +289,8 @@ restoreContent content =
280 Structure term ->
289 Structure term ->
281 Structure <$> traverseFlatType restore term
290 Structure <$> traverseFlatType restore term
282
291
283− Alias name args var ->
292+ Alias home name args var ->
284− Alias name
293+ Alias home name
285 <$> mapM (traverse restore) args
294 <$> mapM (traverse restore) args
286 <*> restore var
295 <*> restore var
287
296
@@ -296,8 +305,8 @@ restoreContent content =
296traverseFlatType :: (Variable -> IO Variable) -> FlatType -> IO FlatType
305traverseFlatType :: (Variable -> IO Variable) -> FlatType -> IO FlatType
297traverseFlatType f flatType =
306traverseFlatType f flatType =
298 case flatType of
307 case flatType of
299− App1 name args ->
308+ App1 home name args ->
300− liftM (App1 name) (traverse f args)
309+ liftM (App1 home name) (traverse f args)
301
310
302 Fun1 a b ->
311 Fun1 a b ->
303 liftM2 Fun1 (f a) (f b)
312 liftM2 Fun1 (f a) (f b)
@@ -308,6 +317,12 @@ traverseFlatType f flatType =
308 Record1 fields ext ->
317 Record1 fields ext ->
309 liftM2 Record1 (traverse f fields) (f ext)
318 liftM2 Record1 (traverse f fields) (f ext)
310
319
320+ Unit1 ->
321+ pure Unit1
322+
323+ Tuple1 a b cs ->
324+ liftM3 Tuple1 (f a) (f b) (traverse f cs)
325+
311
326
312
327
313-- INSTANCES
328-- INSTANCES