@@ -27,6 +27,7 @@ module Type.Type
2727import Control.Monad.State.Strict (StateT, liftIO)
2828import qualified Control.Monad.State.Strict as State
2929import qualified Data.Char as Char
30+import Data.Foldable (foldrM)
3031import qualified Data.Map.Strict as Map
3132import Data.Map.Strict ((!))
3233import Data.Monoid ((<>))
@@ -54,7 +55,7 @@ data FlatType
5455 | EmptyRecord1
5556 | Record1 (Map.Map Text Variable) Variable
5657 | Unit1
57− | Tuple1 Variable Variable [Variable]
58+ | Tuple1 Variable Variable (Maybe Variable)
5859
5960
6061data Type
@@ -66,7 +67,7 @@ data Type
6667 | EmptyRecordN
6768 | RecordN (Map.Map Text Type) Type
6869 | UnitN
69− | TupleN Type Type [Type]
70+ | TupleN Type Type (Maybe Type)
7071
7172
7273
@@ -289,9 +290,14 @@ gatherFreeVars tipe dict =
289290 T.Aliased _ _ args _ ->
290291 foldr gatherFreeVars dict (map snd args)
291292
292− T.Tuple a b cs ->
293+ T.Tuple a b maybeC ->
293294 gatherFreeVars a $ gatherFreeVars b $
294− foldr gatherFreeVars dict cs
295+ case maybeC of
296+ Nothing ->
297+ dict
298+
299+ Just c ->
300+ gatherFreeVars c dict
295301
296302 T.Unit ->
297303 dict
@@ -329,11 +335,11 @@ fromSrcType freeVars sourceType =
329335 T.Holey realType ->
330336 fromSrcType (Map.fromList targs) realType
331337
332− T.Tuple a b cs ->
338+ T.Tuple a b maybeC ->
333339 TupleN
334340 <$> fromSrcType freeVars a
335341 <*> fromSrcType freeVars b
336− <*> traverse (fromSrcType freeVars) cs
342+ <*> traverse (fromSrcType freeVars) maybeC
337343
338344 T.Unit ->
339345 return UnitN
@@ -358,7 +364,7 @@ fromSrcType freeVars sourceType =
358364-- never have to do extra work, particularly nice for aliased types
359365toSrcType :: Variable -> IO T.Canonical
360366toSrcType variable =
361− do takenNames <- State.execStateT (getVarNames variable) Map.empty
367+ do takenNames <- getVarNames variable Map.empty
362368 State.evalStateT (variableToSrcType variable) (makeNameState takenNames)
363369
364370
@@ -449,11 +455,11 @@ termToSrcType term =
449455 Unit1 ->
450456 return T.Unit
451457
452− Tuple1 a b cs ->
458+ Tuple1 a b maybeC ->
453459 T.Tuple
454460 <$> variableToSrcType a
455461 <*> variableToSrcType b
456− <*> traverse variableToSrcType cs
462+ <*> traverse variableToSrcType maybeC
457463
458464
459465
@@ -554,81 +560,73 @@ getFreshSuperHelp name index taken =
554560-- GET ALL VARIABLE NAMES
555561
556562
557−getVarNames :: Variable -> StateT TakenNames IO ()
558−getVarNames var =
559− do (Descriptor content rank mark copy) <- liftIO $ UF.descriptor var
560− if mark == getVarNamesMark then return () else
561− do liftIO $ UF.setDescriptor var (Descriptor content rank getVarNamesMark copy)
563+getVarNames :: Variable -> TakenNames -> IO TakenNames
564+getVarNames var takenNames =
565+ do (Descriptor content rank mark copy) <- UF.descriptor var
566+ if mark == getVarNamesMark
567+ then return takenNames
568+ else
569+ do UF.setDescriptor var (Descriptor content rank getVarNamesMark copy)
562570 case content of
563571 Error _ ->
564− return ()
572+ return takenNames
565573
566574 FlexVar maybeName ->
567575 case maybeName of
568576 Nothing ->
569− return ()
577+ return takenNames
570578
571579 Just name ->
572− registerName name var (FlexVar . Just)
580+ addName 0 name var (FlexVar . Just) takenNames
573581
574582 FlexSuper super maybeName ->
575583 case maybeName of
576584 Nothing ->
577− return ()
585+ return takenNames
578586
579587 Just name ->
580− registerName name var (FlexSuper super . Just)
588+ addName 0 name var (FlexSuper super . Just) takenNames
581589
582590 RigidVar name ->
583− registerName name var RigidVar
591+ addName 0 name var RigidVar takenNames
584592
585593 RigidSuper super name ->
586− registerName name var (RigidSuper super)
594+ addName 0 name var (RigidSuper super) takenNames
587595
588− Alias _ _ args realVar ->
589− do mapM_ (getVarNames . snd) args
590− getVarNames realVar
596+ Alias _ _ args _ ->
597+ foldrM getVarNames takenNames (map snd args)
591598
592599 Structure flatType ->
593600 case flatType of
594601 App1 _ _ args ->
595− mapM_ getVarNames args
602+ foldrM getVarNames takenNames args
596603
597604 Fun1 arg body ->
598− do getVarNames arg
599− getVarNames body
605+ getVarNames arg =<< getVarNames body takenNames
600606
601607 EmptyRecord1 ->
602− return ()
608+ return takenNames
603609
604610 Record1 fields extension ->
605− do mapM_ getVarNames fields
606− getVarNames extension
611+ getVarNames extension =<<
612+ foldrM getVarNames takenNames (Map.elems fields)
607613
608614 Unit1 ->
609− return ()
610−
611− Tuple1 a b cs ->
612− do getVarNames a
613− getVarNames b
614− mapM_ getVarNames cs
615+ return takenNames
615616
617+ Tuple1 a b Nothing ->
618+ getVarNames a =<< getVarNames b takenNames
616619
620+ Tuple1 a b (Just c) ->
621+ getVarNames a =<< getVarNames b =<< getVarNames c takenNames
617622
618−-- REGISTER NAME / RENAME DUPLICATES
619623
620624
621−registerName :: Text -> Variable -> (Text -> Content) -> StateT TakenNames IO ()
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)
625+-- REGISTER NAME / RENAME DUPLICATES
628626
629627
630−checkName :: Int -> Text -> Variable -> (Text -> Content) -> TakenNames -> IO TakenNames
631−checkName index givenName var makeContent takenNames =
628+addName :: Int -> N.Name -> Variable -> (N.Name -> Content) -> TakenNames -> IO TakenNames
629+addName index givenName var makeContent takenNames =
632630 let
633631 indexedName =
634632 if index <= 0 then
@@ -649,4 +647,4 @@ checkName index givenName var makeContent takenNames =
649647 do same <- UF.equivalent var otherVar
650648 if same
651649 then return takenNames
652− else checkName (index + 1) givenName var makeContent takenNames
650+ else addName (index + 1) givenName var makeContent takenNames