git.iko.soy/elk
on master help sign in
Switch to max tuple size of 3 in Type.Type / rewrite getVarNames
5bc3a70Evan Czaplicki
src/Type/Type.hs+45−47
compare with master
unifiedsplit
@@ -27,6 +27,7 @@ module Type.Type
27import Control.Monad.State.Strict (StateT, liftIO)
27import Control.Monad.State.Strict (StateT, liftIO)
28import qualified Control.Monad.State.Strict as State
28import qualified Control.Monad.State.Strict as State
29import qualified Data.Char as Char
29import qualified Data.Char as Char
30+import Data.Foldable (foldrM)
30import qualified Data.Map.Strict as Map
31import qualified Data.Map.Strict as Map
31import Data.Map.Strict ((!))
32import Data.Map.Strict ((!))
32import Data.Monoid ((<>))
33import Data.Monoid ((<>))
@@ -54,7 +55,7 @@ data FlatType
54 | EmptyRecord1
55 | EmptyRecord1
55 | Record1 (Map.Map Text Variable) Variable
56 | Record1 (Map.Map Text Variable) Variable
56 | Unit1
57 | Unit1
57− | Tuple1 Variable Variable [Variable]
58+ | Tuple1 Variable Variable (Maybe Variable)
58
59
59
60
60data Type
61data Type
@@ -66,7 +67,7 @@ data Type
66 | EmptyRecordN
67 | EmptyRecordN
67 | RecordN (Map.Map Text Type) Type
68 | RecordN (Map.Map Text Type) Type
68 | UnitN
69 | UnitN
69− | TupleN Type Type [Type]
70+ | TupleN Type Type (Maybe Type)
70
71
71
72
72
73
@@ -289,9 +290,14 @@ gatherFreeVars tipe dict =
289 T.Aliased _ _ args _ ->
290 T.Aliased _ _ args _ ->
290 foldr gatherFreeVars dict (map snd args)
291 foldr gatherFreeVars dict (map snd args)
291
292
292− T.Tuple a b cs ->
293+ T.Tuple a b maybeC ->
293 gatherFreeVars a $ gatherFreeVars b $
294 gatherFreeVars a $ gatherFreeVars b $
295+ case maybeC of
296+ Nothing ->
297+ dict
298+
299+ Just c ->
294− foldr gatherFreeVars dict cs
300+ gatherFreeVars c dict
295
301
296 T.Unit ->
302 T.Unit ->
297 dict
303 dict
@@ -329,11 +335,11 @@ fromSrcType freeVars sourceType =
329 T.Holey realType ->
335 T.Holey realType ->
330 fromSrcType (Map.fromList targs) realType
336 fromSrcType (Map.fromList targs) realType
331
337
332− T.Tuple a b cs ->
338+ T.Tuple a b maybeC ->
333 TupleN
339 TupleN
334 <$> fromSrcType freeVars a
340 <$> fromSrcType freeVars a
335 <*> fromSrcType freeVars b
341 <*> fromSrcType freeVars b
336− <*> traverse (fromSrcType freeVars) cs
342+ <*> traverse (fromSrcType freeVars) maybeC
337
343
338 T.Unit ->
344 T.Unit ->
339 return UnitN
345 return UnitN
@@ -358,7 +364,7 @@ fromSrcType freeVars sourceType =
358-- never have to do extra work, particularly nice for aliased types
364-- never have to do extra work, particularly nice for aliased types
359toSrcType :: Variable -> IO T.Canonical
365toSrcType :: Variable -> IO T.Canonical
360toSrcType variable =
366toSrcType variable =
361− do takenNames <- State.execStateT (getVarNames variable) Map.empty
367+ do takenNames <- getVarNames variable Map.empty
362 State.evalStateT (variableToSrcType variable) (makeNameState takenNames)
368 State.evalStateT (variableToSrcType variable) (makeNameState takenNames)
363
369
364
370
@@ -449,11 +455,11 @@ termToSrcType term =
449 Unit1 ->
455 Unit1 ->
450 return T.Unit
456 return T.Unit
451
457
452− Tuple1 a b cs ->
458+ Tuple1 a b maybeC ->
453 T.Tuple
459 T.Tuple
454 <$> variableToSrcType a
460 <$> variableToSrcType a
455 <*> variableToSrcType b
461 <*> variableToSrcType b
456− <*> traverse variableToSrcType cs
462+ <*> traverse variableToSrcType maybeC
457
463
458
464
459
465
@@ -554,81 +560,73 @@ getFreshSuperHelp name index taken =
554-- GET ALL VARIABLE NAMES
560-- GET ALL VARIABLE NAMES
555
561
556
562
557−getVarNames :: Variable -> StateT TakenNames IO ()
563+getVarNames :: Variable -> TakenNames -> IO TakenNames
558−getVarNames var =
564+getVarNames var takenNames =
559− do (Descriptor content rank mark copy) <- liftIO $ UF.descriptor var
565+ do (Descriptor content rank mark copy) <- UF.descriptor var
560− if mark == getVarNamesMark then return () else
566+ if mark == getVarNamesMark
567+ then return takenNames
568+ else
561− do liftIO $ UF.setDescriptor var (Descriptor content rank getVarNamesMark copy)
569+ do UF.setDescriptor var (Descriptor content rank getVarNamesMark copy)
562 case content of
570 case content of
563 Error _ ->
571 Error _ ->
564− return ()
572+ return takenNames
565
573
566 FlexVar maybeName ->
574 FlexVar maybeName ->
567 case maybeName of
575 case maybeName of
568 Nothing ->
576 Nothing ->
569− return ()
577+ return takenNames
570
578
571 Just name ->
579 Just name ->
572− registerName name var (FlexVar . Just)
580+ addName 0 name var (FlexVar . Just) takenNames
573
581
574 FlexSuper super maybeName ->
582 FlexSuper super maybeName ->
575 case maybeName of
583 case maybeName of
576 Nothing ->
584 Nothing ->
577− return ()
585+ return takenNames
578
586
579 Just name ->
587 Just name ->
580− registerName name var (FlexSuper super . Just)
588+ addName 0 name var (FlexSuper super . Just) takenNames
581
589
582 RigidVar name ->
590 RigidVar name ->
583− registerName name var RigidVar
591+ addName 0 name var RigidVar takenNames
584
592
585 RigidSuper super name ->
593 RigidSuper super name ->
586− registerName name var (RigidSuper super)
594+ addName 0 name var (RigidSuper super) takenNames
587
595
588− Alias _ _ args realVar ->
596+ Alias _ _ args _ ->
589− do mapM_ (getVarNames . snd) args
597+ foldrM getVarNames takenNames (map snd args)
590− getVarNames realVar
591
598
592 Structure flatType ->
599 Structure flatType ->
593 case flatType of
600 case flatType of
594 App1 _ _ args ->
601 App1 _ _ args ->
595− mapM_ getVarNames args
602+ foldrM getVarNames takenNames args
596
603
597 Fun1 arg body ->
604 Fun1 arg body ->
598− do getVarNames arg
599− getVarNames body
605+ getVarNames arg =<< getVarNames body takenNames
600
606
601 EmptyRecord1 ->
607 EmptyRecord1 ->
602− return ()
608+ return takenNames
603
609
604 Record1 fields extension ->
610 Record1 fields extension ->
605− do mapM_ getVarNames fields
606− getVarNames extension
611+ getVarNames extension =<<
612+ foldrM getVarNames takenNames (Map.elems fields)
607
613
608 Unit1 ->
614 Unit1 ->
609− return ()
615+ return takenNames
610−
611− Tuple1 a b cs ->
612− do getVarNames a
613− getVarNames b
614− mapM_ getVarNames cs
615
616
617+ Tuple1 a b Nothing ->
618+ getVarNames a =<< getVarNames b takenNames
616
619
620+ Tuple1 a b (Just c) ->
621+ getVarNames a =<< getVarNames b =<< getVarNames c takenNames
617
622
618−-- REGISTER NAME / RENAME DUPLICATES
619
623
620
624
621−registerName :: Text -> Variable -> (Text -> Content) -> StateT TakenNames IO ()
625+-- REGISTER NAME / RENAME DUPLICATES
622−registerName givenName var makeContent =
623− if Text.null givenName then
624− return ()
625− else
626− do takenNames <- State.get
627− State.put =<< liftIO (checkName 0 givenName var makeContent takenNames)
628
626
629
627
630−checkName :: Int -> Text -> Variable -> (Text -> Content) -> TakenNames -> IO TakenNames
628+addName :: Int -> N.Name -> Variable -> (N.Name -> Content) -> TakenNames -> IO TakenNames
631−checkName index givenName var makeContent takenNames =
629+addName index givenName var makeContent takenNames =
632 let
630 let
633 indexedName =
631 indexedName =
634 if index <= 0 then
632 if index <= 0 then
@@ -649,4 +647,4 @@ checkName index givenName var makeContent takenNames =
649 do same <- UF.equivalent var otherVar
647 do same <- UF.equivalent var otherVar
650 if same
648 if same
651 then return takenNames
649 then return takenNames
652− else checkName (index + 1) givenName var makeContent takenNames
650+ else addName (index + 1) givenName var makeContent takenNames