@@ -1,12 +1,12 @@
11{-# OPTIONS_GHC -Wall #-}
22module Type.Type where
33
4+import Control.Monad (when)
45import Control.Monad.State (StateT, liftIO)
56import qualified Control.Monad.State as State
7+import qualified Data.Char as Char
68import qualified Data.List as List
79import qualified Data.Map as Map
8−import qualified Data.Set as Set
9−import qualified Data.Traversable as Traverse (traverse)
1010import qualified Data.UnionFind.IO as UF
1111
1212import qualified AST.Type as T
@@ -185,13 +185,7 @@ mkVar maybeSuper =
185185
186186mkNamedVar :: Flex -> String -> IO Variable
187187mkNamedVar flex name =
188− UF.fresh $ mkDescriptor $ Var flex (toSuper name) $
189− case flex of
190− Flex ->
191− Nothing
192−
193− Rigid ->
194− Just name
188+ UF.fresh $ mkDescriptor $ Var flex (toSuper name) (Just name)
195189
196190
197191toSuper :: String -> Maybe Super
@@ -259,8 +253,8 @@ existsNumber f =
259253-- never have to do extra work, particularly nice for aliased types
260254toSrcType :: Variable -> IO T.Canonical
261255toSrcType variable =
262− do usedNames <- getVarNames variable
263− State.evalStateT (variableToSrcType variable) (makeNameState usedNames)
256+ do takenNames <- State.execStateT (getVarNames variable) Map.empty
257+ State.evalStateT (variableToSrcType variable) (makeNameState takenNames)
264258
265259
266260variableToSrcType :: Variable -> StateT NameState IO T.Canonical
@@ -297,7 +291,7 @@ contentToSrcType variable content =
297291 return (T.Var freshName)
298292
299293 Alias name args realVariable ->
300− do srcArgs <- mapM (\(arg,tvar) -> (,) arg <$> variableToSrcType tvar) args
294+ do srcArgs <- traverse (traverse variableToSrcType) args
301295 srcType <- variableToSrcType realVariable
302296 return (T.Aliased name srcArgs (T.Filled srcType))
303297
@@ -327,7 +321,7 @@ termToSrcType term =
327321 return $ T.Record [] Nothing
328322
329323 Record1 fields extension ->
330− do srcFields <- Map.toList <$> Traverse.traverse variableToSrcType fields
324+ do srcFields <- Map.toList <$> traverse variableToSrcType fields
331325 srcExt <- T.iteratedDealias <$> variableToSrcType extension
332326 return $
333327 case srcExt of
@@ -346,112 +340,163 @@ termToSrcType term =
346340
347341
348342data NameState = NameState
349− { _freeNames :: [String]
350− , _numberPrimes :: Int
351− , _comparablePrimes :: Int
352− , _appendablePrimes :: Int
353− , _compAppendPrimes :: Int
343+ { _taken :: TakenNames
344+ , _normals :: Int
345+ , _numbers :: Int
346+ , _comparables :: Int
347+ , _appendables :: Int
348+ , _compAppends :: Int
354349 }
355350
356351
357−makeNameState :: Set.Set String -> NameState
358−makeNameState usedNames =
359− let
360− makeName suffix =
361− map (:suffix) ['a'..'z']
352+type TakenNames = Map.Map String Variable
362353
363− allNames =
364− concatMap makeName ("" : map show [ (1 :: Int) .. ])
365354
366− freeNames =
367− filter (\name -> Set.notMember name usedNames) allNames
368− in
369− NameState freeNames 0 0 0 0
355+makeNameState :: TakenNames -> NameState
356+makeNameState taken =
357+ NameState taken 0 0 0 0 0
370358
371359
372360getFreshName :: (Monad m) => Maybe Super -> StateT NameState m String
373361getFreshName maybeSuper =
374362 case maybeSuper of
375363 Nothing ->
376− do names <- State.gets _freeNames
377− State.modify (\state -> state { _freeNames = tail names })
378− return (head names)
364+ do index <- State.gets _normals
365+ taken <- State.gets _taken
366+ let (uniqueName, newIndex) = getFreshNormal index taken
367+ State.modify (\state -> state { _normals = newIndex })
368+ return uniqueName
379369
380370 Just Number ->
381− do primes <- State.gets _numberPrimes
382− State.modify (\state -> state { _numberPrimes = primes + 1 })
383− return ("number" ++ replicate primes '\'')
371+ getFreshSuper "number" _numbers (\index state -> state { _numbers = index })
384372
385373 Just Comparable ->
386− do primes <- State.gets _comparablePrimes
387− State.modify (\state -> state { _comparablePrimes = primes + 1 })
388− return ("comparable" ++ replicate primes '\'')
374+ getFreshSuper "comparable" _comparables (\index state -> state { _comparables = index })
389375
390376 Just Appendable ->
391− do primes <- State.gets _appendablePrimes
392− State.modify (\state -> state { _appendablePrimes = primes + 1 })
393− return ("appendable" ++ replicate primes '\'')
377+ getFreshSuper "appendable" _appendables (\index state -> state { _appendables = index })
394378
395379 Just CompAppend ->
396− do primes <- State.gets _compAppendPrimes
397− State.modify (\state -> state { _compAppendPrimes = primes + 1 })
398− return ("compappend" ++ replicate primes '\'')
380+ getFreshSuper "compappend" _compAppends (\index state -> state { _compAppends = index })
381+
382+
383+getFreshNormal :: Int -> TakenNames -> (String, Int)
384+getFreshNormal index taken =
385+ let
386+ (postfix, letter) =
387+ quotRem index 26
388+
389+ name =
390+ Char.chr (97 + letter) : if postfix <= 0 then "" else show postfix
391+ in
392+ if Map.member name taken then
393+ getFreshNormal (index + 1) taken
394+
395+ else
396+ (name, index + 1)
397+
398+
399+getFreshSuper
400+ :: (Monad m)
401+ => String
402+ -> (NameState -> Int)
403+ -> (Int -> NameState -> NameState)
404+ -> StateT NameState m String
405+getFreshSuper name getter setter =
406+ do index <- State.gets getter
407+ taken <- State.gets _taken
408+ let (uniqueName, newIndex) = getFreshSuperHelp name index taken
409+ State.modify (setter newIndex)
410+ return uniqueName
411+
412+
413+getFreshSuperHelp :: String -> Int -> TakenNames -> (String, Int)
414+getFreshSuperHelp name index taken =
415+ let
416+ newName =
417+ if index <= 0 then name else name ++ show index
418+ in
419+ if Map.member newName taken then
420+ getFreshSuperHelp name (index + 1) taken
421+
422+ else
423+ (newName, index + 1)
399424
400425
401426
402427-- GET ALL VARIABLE NAMES
403428
404429
405−getVarNames :: Variable -> IO (Set.Set String)
430+getVarNames :: Variable -> StateT TakenNames IO ()
406431getVarNames var =
407− do desc <- UF.descriptor var
408− if _mark desc == getVarNamesMark
409− then
410− return Set.empty
432+ do desc <- liftIO $ UF.descriptor var
433+ case _mark desc == getVarNamesMark of
434+ True ->
435+ return ()
411436
412− else
413− do UF.setDescriptor var (desc { _mark = getVarNamesMark })
414− getVarNamesHelp (_content desc)
437+ False ->
438+ do liftIO $ UF.setDescriptor var (desc { _mark = getVarNamesMark })
439+ case _content desc of
440+ Atom _ ->
441+ return ()
415442
443+ Error ->
444+ return ()
416445
417−getVarNamesHelp :: Content -> IO (Set.Set String)
418−getVarNamesHelp content =
419− case content of
420− Var _ _ (Just name) ->
421− return (Set.singleton name)
446+ Var _ _ Nothing ->
447+ return ()
422448
423− Var _ _ Nothing ->
424− return Set.empty
449+ Var flex maybeSuper (Just name) ->
450+ do oldTaken <- State.get
451+ newTaken <- liftIO $ addVarName 0 name var flex maybeSuper oldTaken
452+ State.put newTaken
425453
426− Structure term ->
427− getVarNamesTerm term
454+ Alias _ args realVar ->
455+ do mapM_ (getVarNames . snd) args
456+ getVarNames realVar
428457
429− Alias _name args realVar ->
430− do let argSet = Set.fromList (map fst args)
431− realSet <- getVarNames realVar
432− sets <- mapM (getVarNames . snd) args
433− return (Set.unions (realSet : argSet : sets))
458+ Structure (App1 func arg) ->
459+ do getVarNames func
460+ getVarNames arg
434461
435− Atom _ ->
436− return Set.empty
462+ Structure (Fun1 arg body) ->
463+ do getVarNames arg
464+ getVarNames body
437465
438− Error ->
439− return Set.empty
466+ Structure EmptyRecord1 ->
467+ return ()
440468
469+ Structure (Record1 fields extension) ->
470+ do mapM_ getVarNames fields
471+ getVarNames extension
441472
442−getVarNamesTerm :: Term1 Variable -> IO (Set.Set String)
443−getVarNamesTerm term =
444− let go = getVarNames in
445− case term of
446− App1 a b ->
447− Set.union <$> go a <*> go b
448473
449− Fun1 a b ->
450− Set.union <$> go a <*> go b
474+addVarName :: Int -> String -> Variable -> Flex -> Maybe Super -> TakenNames -> IO TakenNames
475+addVarName index givenName var flex maybeSuper taken =
476+ let
477+ name =
478+ makeIndexedName givenName index
479+ in
480+ case Map.lookup name taken of
481+ Nothing ->
482+ do when (name /= givenName) $ UF.modifyDescriptor var $ \desc ->
483+ desc { _content = Var flex maybeSuper (Just name) }
484+ return $ Map.insert name var taken
451485
452− EmptyRecord1 ->
453− return Set.empty
486+ Just otherVar ->
487+ do same <- UF.equivalent var otherVar
488+ if same
489+ then return taken
490+ else addVarName (index + 1) givenName var flex maybeSuper taken
454491
455− Record1 fields extension ->
456− do fieldVars <- Set.unions <$> mapM go (Map.elems fields)
457− Set.union fieldVars <$> go extension
492+
493+makeIndexedName :: String -> Int -> String
494+makeIndexedName name index =
495+ if index <= 0 then
496+ name
497+
498+ else if Char.isDigit (last name) then
499+ name ++ '_' : show index
500+
501+ else
502+ name ++ show index