git.iko.soy/elk
on master help sign in
Improve the error messages for bad rigid type variables

Use richer representation of type variables, so FlexVar, FlexSuper, RigidVar, and RigidSuper are actually different constructors. This has the downside of adding extra work to pattern matches that treat all type variables the same. It may be worth considering adding some indirection for those cases. It has the benefit of making things very explicit, and the performance cost appears to be quite small. The net effect is that error messages with bad rigid variables are much nicer!

commitfbff9ce1fc9ad148908e4559065cd056de80c5eb authorEvan Czaplicki <evancz@users.noreply.github.com> dateMon 17 Jul 2017, 18:41 (9 years ago) parent40aafc6
9 files changed+452−327
compare with master
unifiedsplit
src/Reporting/Error/Type.hs+87−59 src/Type/Constrain/Expression.hs+3−3 src/Type/Environment.hs+23−16 src/Type/Inference.hs+1−1 src/Type/Occurs.hs+14−5 src/Type/Solve.hs+15−5 src/Type/State.hs+21−6 src/Type/Type.hs+135−92 src/Type/Unify.hs+153−140
src/Reporting/Error/Type.hs+87−59
@@ -3,7 +3,7 @@
33module Reporting.Error.Type
44 ( Error(..)
55 , Mismatch(..), Hint(..)
6− , Reason(..), VarType(..)
6+ , Reason(..), SpecificThing(..)
77 , Pattern(..)
88 , toReport
99 , flipReason
@@ -54,15 +54,17 @@ data Reason
5454 | IntFloat
5555 | TooLongComparableTuple Int
5656 | MissingArgs Int
57− | BadVar (Maybe VarType) (Maybe VarType)
57+ | RigidClash Text Text
58+ | NotPartOfSuper Type.Super
59+ | RigidVarTooGeneric Text SpecificThing
60+ | RigidSuperTooGeneric Type.Super Text SpecificThing
5861
5962
60−data VarType
61− = Number
62− | Comparable
63− | Appendable
64− | CompAppend
65− | Rigid (Maybe Text)
63+data SpecificThing
64+ = SpecificSuper Type.Super
65+ | SpecificType Var.Canonical
66+ | SpecificFunction
67+ | SpecificRecord
6668
6769
6870data Hint
@@ -694,8 +696,17 @@ flipReason reason =
694696 MissingArgs num ->
695697 MissingArgs num
696698
697− BadVar left right ->
698− BadVar right left
699+ RigidClash a b ->
700+ RigidClash b a
701+
702+ NotPartOfSuper super ->
703+ NotPartOfSuper super
704+
705+ RigidVarTooGeneric name specific ->
706+ RigidVarTooGeneric name specific
707+
708+ RigidSuperTooGeneric super name specific ->
709+ RigidSuperTooGeneric super name specific
699710
700711
701712reasonToString :: Reason -> Maybe Doc
@@ -776,73 +787,90 @@ reasonToStringHelp reason =
776787 go $
777788 "It looks like a function needs " <> Help.moreArgs num <> "."
778789
779− BadVar (Just Comparable) _ ->
790+ RigidClash name1 name2 ->
791+ go $
792+ "Your type annotation uses `" <> name1 <> "` and `" <> name2 <>
793+ "` as DIFFERENT type variables. By using separate names, you are\
794+ \ claiming the values can be different, but the code suggests that\
795+ \ they must be the SAME based on how they are used. Maybe these two\
796+ \ type variables in your type annotation should just be one? Maybe\
797+ \ your code uses them in a weird way? More help at: "
798+ <> Help.hintLink "type-annotations"
799+
800+ NotPartOfSuper Type.Number ->
801+ go "Only ints and floats are numbers."
802+
803+ NotPartOfSuper Type.Comparable ->
780804 go "Only ints, floats, chars, strings, lists, and tuples are comparable."
781805
782− BadVar (Just Appendable) _ ->
783− go "Only strings, text, and lists are appendable."
806+ NotPartOfSuper Type.Appendable ->
807+ go "Only strings and lists are appendable."
784808
785− BadVar (Just CompAppend) _ ->
809+ NotPartOfSuper Type.CompAppend ->
786810 go "Only strings and lists are both comparable and appendable."
787811
788− BadVar (Just (Rigid maybeLeftName)) (Just (Rigid maybeRightName)) ->
789− go $ doubleRigidError maybeLeftName maybeRightName
812+ RigidVarTooGeneric name specific ->
813+ go $ rigidTooGenericHelp "ANY type of value" name specific
790814
791− BadVar (Just (Rigid maybeName)) _ ->
792− go $ singleRigidError maybeName
815+ RigidSuperTooGeneric Type.Number name specific ->
816+ go $ rigidTooGenericHelp "BOTH Ints and Floats" name specific
793817
794− BadVar _ (Just (Rigid maybeName)) ->
795− go $ singleRigidError maybeName
818+ RigidSuperTooGeneric Type.Comparable name specific ->
819+ go $ rigidTooGenericHelp "ANY comparable value" name specific
796820
797− BadVar _ _ ->
798− Nothing
821+ RigidSuperTooGeneric Type.Appendable name specific ->
822+ go $ rigidTooGenericHelp "BOTH Strings and Lists" name specific
799823
824+ RigidSuperTooGeneric Type.CompAppend name specific ->
825+ go $ rigidTooGenericHelp "Strings and ANY comparable List" name specific
800826
801−badFieldElaboration :: Text
802−badFieldElaboration =
803− "I always figure out field types in alphabetical order. If a field\
804− \ seems fine, I assume it is \"correct\" in subsequent checks.\
805− \ So the problem may actually be a weird interaction with previous fields."
806827
828+rigidTooGenericHelp :: Text -> Text -> SpecificThing -> Text
829+rigidTooGenericHelp manyTypesOfValues name specific =
830+ "The type variable `" <> name <> "` in your type annotation suggests that"
831+ <> manyTypesOfValues <> " can flow through, but the code suggests that it must be "
832+ <> specificThingToText specific <> " based on how it is used. Maybe make your\
833+ \ type annotation more specific? Maybe the code has a problem? More help at: "
834+ <> Help.hintLink "type-annotations"
807835
808−weirdRigidError :: Text
809−weirdRigidError =
810− "You are having a problem with \"rigid\" type variables. That usually\
811− \ means you have a type annotation that says it accepts anything, but\
812− \ in fact, it accepts a much more specific type. More info at: "
813− <> Help.hintLink "type-annotations" <>
814− ". This case is weird though, so please turn it into an <http://sscce.org>\
815− \ and report it to <https://github.com/elm-lang/error-message-catalog>."
816836
837+specificThingToText :: SpecificThing -> Text
838+specificThingToText specific =
839+ case specific of
840+ SpecificSuper Type.Number ->
841+ "a number"
817842
818−singleRigidError :: Maybe Text -> Text
819−singleRigidError maybeName =
820− case maybeName of
821− Just name ->
822− "Your type annotation uses type variable `" <> name <>
823− "` which means any type of value can flow through. Your code is saying\
824− \ it CANNOT be anything though! Maybe change your type annotation to\
825− \ be more specific? Maybe the code has a problem? More at: "
826− <> Help.hintLink "type-annotations"
843+ SpecificSuper Type.Comparable ->
844+ "comparable"
827845
828− Nothing ->
829− weirdRigidError
846+ SpecificSuper Type.Appendable ->
847+ "appendable"
830848
849+ SpecificSuper Type.CompAppend ->
850+ "comparable AND appendable"
831851
832−doubleRigidError :: Maybe Text -> Maybe Text -> Text
833−doubleRigidError maybeLeftName maybeRightName =
834− case (maybeLeftName, maybeRightName) of
835− (Just leftName, Just rightName) ->
836− "Your type annotation uses `" <> leftName <> "` and `" <> rightName <>
837− "` as separate type variables. Each one can be any type of value,\
838− \ but because they have separate names, there is no guarantee that they\
839− \ are equal to each other. Your code seems to be saying they ARE the\
840− \ same though! Maybe they should be the same in your type annotation?\
841− \ Maybe your code uses them in a weird way? More at: "
842− <> Help.hintLink "type-annotations"
852+ SpecificType var@(Var.Canonical _ name) ->
853+ if Var.isTuple var then
854+ "a tuple"
843855
844− _ ->
845− weirdRigidError
856+ else if Text.isInfixOf (Text.take 1 name) "AEIOU" then
857+ "an " <> name
858+
859+ else
860+ "a " <> name
861+
862+ SpecificRecord ->
863+ "a record"
864+
865+ SpecificFunction ->
866+ "a function"
867+
868+
869+badFieldElaboration :: Text
870+badFieldElaboration =
871+ "I always figure out field types in alphabetical order. If a field\
872+ \ seems fine, I assume it is \"correct\" in subsequent checks.\
873+ \ So the problem may actually be a weird interaction with previous fields."
846874
847875
848876messyFieldsHelp :: [Text] -> [Text] -> [Text] -> Maybe (Text, [Doc])
src/Type/Constrain/Expression.hs+3−3
@@ -536,7 +536,7 @@ constrainAnnotatedDef
536536 -> Info
537537 -> IO Info
538538constrainAnnotatedDef env defRegion region name expr tipe info =
539− do (flexType, flexVars) <- Env.instantiateType Flex env tipe
539+ do (flexType, flexVars) <- Env.instantiateFlex env tipe
540540
541541 let scheme =
542542 Scheme
@@ -568,7 +568,7 @@ constrainAnnDefHelp :: C.Expr -> ST.Canonical -> ArgInfo -> IO Constraint
568568constrainAnnDefHelp expr tipe (ArgInfo name defRegion env args vars) =
569569 case (expr, tipe) of
570570 (A.A _ (C.Lambda arg result), ST.Lambda argType resultType) ->
571− do (rigidArgType, newVars) <- Env.instantiateType Rigid env argType
571+ do (rigidArgType, newVars) <- Env.instantiateRigid env argType
572572
573573 constrainAnnDefHelp result resultType $
574574 ArgInfo
@@ -580,7 +580,7 @@ constrainAnnDefHelp expr tipe (ArgInfo name defRegion env args vars) =
580580 }
581581
582582 (A.A region _, _) ->
583− do (rigidType, newVars) <- Env.instantiateType Rigid env tipe
583+ do (rigidType, newVars) <- Env.instantiateRigid env tipe
584584
585585 let finalEnv = Env.addValues newVars env
586586 let finalArgs = reverse args
src/Type/Environment.hs+23−16
@@ -6,7 +6,8 @@ module Type.Environment
66 , initialize
77 , get, freshDataScheme, ctorNames
88 , addValues
9− , instantiateType
9+ , instantiateFlex
10+ , instantiateRigid
1011 )
1112 where
1213
@@ -102,8 +103,8 @@ makeCtorsHelp constructorDict ( var, (rawTypeVars, ctors) ) =
102103
103104 go :: [T.Canonical] -> State.StateT VarDict IO ([Type], Type)
104105 go args =
105− do types <- mapM (instantiator Flex Map.empty) args
106− returnType <- instantiator Flex Map.empty (T.Type var tvars)
106+ do types <- mapM (instantiator nameToFlex Map.empty) args
107+ returnType <- instantiator nameToFlex Map.empty (T.Type var tvars)
107108 return (types, returnType)
108109 in
109110 List.foldl' inst constructorDict ctors
@@ -142,25 +143,31 @@ addValues newValues env =
142143-- INSTANTIATE TYPES
143144
144145
145−instantiateType :: Flex -> Env -> T.Canonical -> IO (Type, VarDict)
146−instantiateType flex env sourceType =
147− State.runStateT (instantiator flex (_value env) sourceType) Map.empty
146+instantiateFlex :: Env -> T.Canonical -> IO (Type, VarDict)
147+instantiateFlex env sourceType =
148+ State.runStateT (instantiator nameToFlex (_value env) sourceType) Map.empty
148149
149150
150−instantiator :: Flex -> Dict Type -> T.Canonical -> State.StateT VarDict IO Type
151−instantiator flex values sourceType =
152− instantiatorHelp flex values Set.empty sourceType
151+instantiateRigid :: Env -> T.Canonical -> IO (Type, VarDict)
152+instantiateRigid env sourceType =
153+ State.runStateT (instantiator nameToRigid (_value env) sourceType) Map.empty
153154
154155
155−instantiatorHelp :: Flex -> Dict Type -> Set.Set Text -> T.Canonical -> State.StateT VarDict IO Type
156−instantiatorHelp flex values aliasVars sourceType =
156+instantiator :: (Text -> IO Variable) -> Dict Type -> T.Canonical -> State.StateT VarDict IO Type
157+instantiator nameToVar values sourceType =
158+ instantiatorHelp nameToVar values Set.empty sourceType
159+
160+
161+instantiatorHelp :: (Text -> IO Variable) -> Dict Type -> Set.Set Text -> T.Canonical -> State.StateT VarDict IO Type
162+instantiatorHelp nameToVar values aliasVars sourceType =
163+ {-# SCC elm_compiler_type_instantiate #-}
157164 let
158165 go =
159− instantiatorHelp flex values aliasVars
166+ instantiatorHelp nameToVar values aliasVars
160167 in
161168 case sourceType of
162169 T.Lambda t1 t2 ->
163− (==>) <$> go t1 <*> go t2
170+ FunN <$> go t1 <*> go t2
164171
165172 T.Var name ->
166173 if Set.member name aliasVars then
@@ -178,7 +185,7 @@ instantiatorHelp flex values aliasVars sourceType =
178185 return (VarN variable)
179186
180187 Nothing ->
181− do variable <- State.liftIO (mkNamedVar flex name)
188+ do variable <- State.liftIO (nameToVar name)
182189 State.put (Map.insert name variable dict)
183190 return (VarN variable)
184191
@@ -187,10 +194,10 @@ instantiatorHelp flex values aliasVars sourceType =
187194 realType <-
188195 case aliasType of
189196 T.Filled tipe ->
190− instantiatorHelp flex values Set.empty tipe
197+ instantiatorHelp nameToVar values Set.empty tipe
191198
192199 T.Holey tipe ->
193− instantiatorHelp flex values (Set.fromList (map fst args)) tipe
200+ instantiatorHelp nameToVar values (Set.fromList (map fst args)) tipe
194201
195202 return (AliasN name targs realType)
196203
src/Type/Inference.hs+1−1
@@ -79,7 +79,7 @@ canonicalizeValues
7979 -> IO [(Text, ([T.Variable], T.Type))]
8080canonicalizeValues env (moduleName, iface) =
8181 forM (Map.toList (Module.iTypes iface)) $ \(name, tipe) ->
82− do (flexType, flexVars) <- Env.instantiateType T.Flex env tipe
82+ do (flexType, flexVars) <- Env.instantiateFlex env tipe
8383 return
8484 ( ModuleName.canonicalToText moduleName <> "." <> name
8585 , ( Map.elems flexVars
src/Type/Occurs.hs+14−5
@@ -25,15 +25,17 @@ occursHelp seen var =
2525 else
2626 do (Descriptor content _ _ _) <- UF.descriptor var
2727 case content of
28− Var _ _ _ ->
28+ FlexVar _ ->
2929 return False
3030
31− Error _ ->
31+ FlexSuper _ _ ->
3232 return False
3333
34− Alias _ args _ ->
35− -- TODO is it okay to only check args?
36− or <$> traverse (occursHelp (var:seen) . snd) args
34+ RigidVar _ ->
35+ return False
36+
37+ RigidSuper _ _ ->
38+ return False
3739
3840 Structure term ->
3941 let
@@ -51,3 +53,10 @@ occursHelp seen var =
5153
5254 Record1 fields ext ->
5355 or <$> traverse go (ext : Map.elems fields)
56+
57+ Alias _ args _ ->
58+ -- TODO is it okay to only check args?
59+ or <$> traverse (occursHelp (var:seen) . snd) args
60+
61+ Error _ ->
62+ return False
src/Type/Solve.hs+15−5
@@ -276,15 +276,17 @@ adjustRankContent youngMark visitMark groupRank content =
276276 go = adjustRank youngMark visitMark groupRank
277277 in
278278 case content of
279− Error _ ->
279+ FlexVar _ ->
280280 return groupRank
281281
282− Var _ _ _ ->
282+ FlexSuper _ _ ->
283283 return groupRank
284284
285− Alias _ args _ ->
286− -- THEORY: anything in the realVar would be outermostRank
287− foldM (\rank (_, argVar) -> max rank <$> go argVar) outermostRank args
285+ RigidVar _ ->
286+ return groupRank
287+
288+ RigidSuper _ _ ->
289+ return groupRank
288290
289291 Structure flatType ->
290292 case flatType of
@@ -301,3 +303,11 @@ adjustRankContent youngMark visitMark groupRank content =
301303 Record1 fields extension ->
302304 do extRank <- go extension
303305 foldM (\rank field -> max rank <$> go field) extRank fields
306+
307+ Alias _ args _ ->
308+ -- THEORY: anything in the realVar would be outermostRank
309+ foldM (\rank (_, argVar) -> max rank <$> go argVar) outermostRank args
310+
311+ Error _ ->
312+ return groupRank
313+
src/Type/State.hs+21−6
@@ -221,12 +221,18 @@ copyHelp maxRank pools variable =
221221 do newTerm <- traverseFlatType (copyHelp maxRank pools) term
222222 UF.setDescriptor newVar $ mkCopyDesc (Structure newTerm)
223223
224− Var Rigid maybeSuper maybeName ->
225− UF.setDescriptor newVar $ mkCopyDesc $ Var Flex maybeSuper maybeName
224+ FlexVar _ ->
225+ return ()
226226
227− Var Flex _ _ ->
227+ FlexSuper _ _ ->
228228 return ()
229229
230+ RigidVar name ->
231+ UF.setDescriptor newVar $ mkCopyDesc $ FlexVar (Just name)
232+
233+ RigidSuper super name ->
234+ UF.setDescriptor newVar $ mkCopyDesc $ FlexSuper super (Just name)
235+
230236 Alias name args realType ->
231237 do newArgs <- mapM (traverse (copyHelp maxRank pools)) args
232238 newRealType <- copyHelp maxRank pools realType
@@ -259,12 +265,21 @@ restore variable =
259265restoreContent :: Content -> IO Content
260266restoreContent content =
261267 case content of
262− Structure term ->
263− Structure <$> traverseFlatType restore term
268+ FlexVar _ ->
269+ return content
264270
265− Var _ _ _ ->
271+ FlexSuper _ _ ->
266272 return content
267273
274+ RigidVar _ ->
275+ return content
276+
277+ RigidSuper _ _ ->
278+ return content
279+
280+ Structure term ->
281+ Structure <$> traverseFlatType restore term
282+
268283 Alias name args var ->
269284 Alias name
270285 <$> mapM (traverse restore) args
src/Type/Type.hs+135−92
@@ -6,7 +6,6 @@ module Type.Type
66 , Type(..)
77 , Descriptor(Descriptor)
88 , Content(..)
9− , Flex(..)
109 , noRank
1110 , outermostRank
1211 , Mark
@@ -15,12 +14,14 @@ module Type.Type
1514 , (==>), float, char, string, bool
1615 , mkFlexVar
1716 , mkFlexNumber
18− , mkNamedVar
17+ , unnamedFlexVar
18+ , unnamedFlexSuper
19+ , nameToFlex
20+ , nameToRigid
1921 , toSrcType
2022 )
2123 where
2224
23−import Control.Monad (when)
2425import Control.Monad.State.Strict (StateT, liftIO)
2526import qualified Control.Monad.State.Strict as State
2627import qualified Data.Char as Char
@@ -74,8 +75,11 @@ data Descriptor =
7475
7576
7677data Content
77− = Structure FlatType
78− | Var Flex (Maybe T.Super) (Maybe Text)
78+ = FlexVar (Maybe Text)
79+ | FlexSuper T.Super (Maybe Text)
80+ | RigidVar Text
81+ | RigidSuper T.Super Text
82+ | Structure FlatType
7983 | Alias Var.Canonical [(Text,Variable)] Variable
8084 | Error Text
8185
@@ -85,21 +89,18 @@ makeDescriptor content =
8589 Descriptor content noRank noMark Nothing
8690
8791
88−data Flex
89− = Rigid
90− | Flex
91−
92−
9392
9493-- RANKS
9594
9695
9796noRank :: Int
98−noRank = 0
97+noRank =
98+ 0
9999
100100
101101outermostRank :: Int
102−outermostRank = 1
102+outermostRank =
103+ 1
103104
104105
105106
@@ -183,11 +184,10 @@ flexVarDescriptor =
183184 makeDescriptor unnamedFlexVar
184185
185186
186−
187187{-# NOINLINE unnamedFlexVar #-}
188188unnamedFlexVar :: Content
189189unnamedFlexVar =
190− Var Flex Nothing Nothing
190+ FlexVar Nothing
191191
192192
193193
@@ -207,16 +207,23 @@ flexNumberDescriptor =
207207
208208unnamedFlexSuper :: T.Super -> Content
209209unnamedFlexSuper super =
210− Var Flex (Just super) Nothing
210+ FlexSuper super Nothing
211+
211212
212213
214+-- MAKE NAMED VARIABLES
213215
214−-- MAKE NAMED FLEX VARIABLES
215216
217+nameToFlex :: Text -> IO Variable
218+nameToFlex name =
219+ UF.fresh $ makeDescriptor $
220+ maybe FlexVar FlexSuper (toSuper name) (Just name)
216221
217−mkNamedVar :: Flex -> Text -> IO Variable
218−mkNamedVar flex name =
219− UF.fresh $ makeDescriptor $ Var flex (toSuper name) (Just name)
222+
223+nameToRigid :: Text -> IO Variable
224+nameToRigid name =
225+ UF.fresh $ makeDescriptor $
226+ maybe RigidVar RigidSuper (toSuper name) name
220227
221228
222229toSuper :: Text -> Maybe T.Super
@@ -270,14 +277,31 @@ contentToSrcType variable content =
270277 Structure term ->
271278 termToSrcType term
272279
273− Var _ _ (Just name) ->
280+ FlexVar maybeName ->
281+ case maybeName of
282+ Just name ->
283+ return (T.Var name)
284+
285+ Nothing ->
286+ do name <- getFreshVarName
287+ liftIO $ UF.modifyDescriptor variable (\desc -> desc { _content = FlexVar (Just name) })
288+ return (T.Var name)
289+
290+ FlexSuper super maybeName ->
291+ case maybeName of
292+ Just name ->
293+ return (T.Var name)
294+
295+ Nothing ->
296+ do name <- getFreshSuperName super
297+ liftIO $ UF.modifyDescriptor variable (\desc -> desc { _content = FlexSuper super (Just name) })
298+ return (T.Var name)
299+
300+ RigidVar name ->
274301 return (T.Var name)
275302
276− Var flex maybeSuper Nothing ->
277− do freshName <- getFreshName maybeSuper
278− liftIO $ UF.modifyDescriptor variable $ \desc ->
279− desc { _content = Var flex maybeSuper (Just freshName) }
280− return (T.Var freshName)
303+ RigidSuper _ name ->
304+ return (T.Var name)
281305
282306 Alias name args realVariable ->
283307 do srcArgs <- traverse (traverse variableToSrcType) args
@@ -340,27 +364,29 @@ makeNameState taken =
340364 NameState taken 0 0 0 0 0
341365
342366
343−getFreshName :: (Monad m) => Maybe T.Super -> StateT NameState m Text
344−getFreshName maybeSuper =
345− case maybeSuper of
346− Nothing ->
347− do index <- State.gets _normals
348− taken <- State.gets _taken
349− let (uniqueName, newIndex) = getFreshNormal index taken
350− State.modify (\state -> state { _normals = newIndex })
351− return uniqueName
367+getFreshVarName :: (Monad m) => StateT NameState m Text
368+getFreshVarName =
369+ do index <- State.gets _normals
370+ taken <- State.gets _taken
371+ let (uniqueName, newIndex) = getFreshNormal index taken
372+ State.modify (\state -> state { _normals = newIndex })
373+ return uniqueName
374+
352375
353− Just T.Number ->
354− getFreshSuper "number" _numbers (\index state -> state { _numbers = index })
376+getFreshSuperName :: (Monad m) => T.Super -> StateT NameState m Text
377+getFreshSuperName super =
378+ case super of
379+ T.Number ->
380+ getFreshSuper "number" _numbers (\index state -> state { _numbers = index })
355381
356− Just T.Comparable ->
357− getFreshSuper "comparable" _comparables (\index state -> state { _comparables = index })
382+ T.Comparable ->
383+ getFreshSuper "comparable" _comparables (\index state -> state { _comparables = index })
358384
359− Just T.Appendable ->
360− getFreshSuper "appendable" _appendables (\index state -> state { _appendables = index })
385+ T.Appendable ->
386+ getFreshSuper "appendable" _appendables (\index state -> state { _appendables = index })
361387
362− Just T.CompAppend ->
363− getFreshSuper "compappend" _compAppends (\index state -> state { _compAppends = index })
388+ T.CompAppend ->
389+ getFreshSuper "compappend" _compAppends (\index state -> state { _compAppends = index })
364390
365391
366392getFreshNormal :: Int -> TakenNames -> (Text, Int)
@@ -415,70 +441,87 @@ getFreshSuperHelp name index taken =
415441
416442getVarNames :: Variable -> StateT TakenNames IO ()
417443getVarNames var =
418− do desc <- liftIO $ UF.descriptor var
419− case _mark desc == getVarNamesMark of
420− True ->
421− return ()
444+ do (Descriptor content rank mark copy) <- liftIO $ UF.descriptor var
445+ if mark == getVarNamesMark then return () else
446+ do liftIO $ UF.setDescriptor var (Descriptor content rank getVarNamesMark copy)
447+ case content of
448+ Error _ ->
449+ return ()
450+
451+ FlexVar maybeName ->
452+ case maybeName of
453+ Nothing ->
454+ return ()
422455
423− False ->
424− do liftIO $ UF.setDescriptor var (desc { _mark = getVarNamesMark })
425− case _content desc of
426− Error _ ->
427− return ()
456+ Just name ->
457+ registerName name var (FlexVar . Just)
428458
429− Var _ _ Nothing ->
430− return ()
459+ FlexSuper super maybeName ->
460+ case maybeName of
461+ Nothing ->
462+ return ()
431463
432− Var flex maybeSuper (Just name) ->
433− do oldTaken <- State.get
434− newTaken <- liftIO $ addVarName 0 name var flex maybeSuper oldTaken
435− State.put newTaken
464+ Just name ->
465+ registerName name var (FlexSuper super . Just)
436466
437− Alias _ args realVar ->
438− do mapM_ (getVarNames . snd) args
439− getVarNames realVar
467+ RigidVar name ->
468+ registerName name var RigidVar
440469
441− Structure (App1 _ args) ->
442− mapM_ getVarNames args
470+ RigidSuper super name ->
471+ registerName name var (RigidSuper super)
443472
444− Structure (Fun1 arg body) ->
445− do getVarNames arg
446− getVarNames body
473+ Alias _ args realVar ->
474+ do mapM_ (getVarNames . snd) args
475+ getVarNames realVar
447476
448− Structure EmptyRecord1 ->
449− return ()
477+ Structure (App1 _ args) ->
478+ mapM_ getVarNames args
450479
451− Structure (Record1 fields extension) ->
452− do mapM_ getVarNames fields
453− getVarNames extension
480+ Structure (Fun1 arg body) ->
481+ do getVarNames arg
482+ getVarNames body
454483
484+ Structure EmptyRecord1 ->
485+ return ()
455486
456−addVarName :: Int -> Text -> Variable -> Flex -> Maybe T.Super -> TakenNames -> IO TakenNames
457−addVarName index givenName var flex maybeSuper taken =
487+ Structure (Record1 fields extension) ->
488+ do mapM_ getVarNames fields
489+ getVarNames extension
490+
491+
492+
493+-- REGISTER NAME / RENAME DUPLICATES
494+
495+
496+registerName :: Text -> Variable -> (Text -> Content) -> StateT TakenNames IO ()
497+registerName givenName var makeContent =
498+ if Text.null givenName then
499+ return ()
500+ else
501+ do takenNames <- State.get
502+ State.put =<< liftIO (checkName 0 givenName var makeContent takenNames)
503+
504+
505+checkName :: Int -> Text -> Variable -> (Text -> Content) -> TakenNames -> IO TakenNames
506+checkName index givenName var makeContent takenNames =
458507 let
459− name =
460− makeIndexedName givenName index
508+ indexedName =
509+ if index <= 0 then
510+ givenName
511+ else if Char.isDigit (Text.last givenName) then
512+ givenName <> Text.pack ('_' : show index)
513+ else
514+ givenName <> Text.pack (show index)
461515 in
462− case Map.lookup name taken of
516+ case Map.lookup indexedName takenNames of
463517 Nothing ->
464− do when (name /= givenName) $ UF.modifyDescriptor var $ \desc ->
465− desc { _content = Var flex maybeSuper (Just name) }
466− return $ Map.insert name var taken
518+ do if indexedName == givenName then return () else
519+ UF.modifyDescriptor var $ \(Descriptor _ rank mark copy) ->
520+ Descriptor (makeContent indexedName) rank mark copy
521+ return $ Map.insert indexedName var takenNames
467522
468523 Just otherVar ->
469524 do same <- UF.equivalent var otherVar
470525 if same
471− then return taken
472− else addVarName (index + 1) givenName var flex maybeSuper taken
473−
474−
475−makeIndexedName :: Text -> Int -> Text
476−makeIndexedName name index =
477− if index <= 0 then
478− name
479−
480− else if Char.isDigit (Text.last name) then
481− name <> Text.pack ('_' : show index)
482−
483− else
484− name <> Text.pack (show index)
526+ then return takenNames
527+ else checkName (index + 1) givenName var makeContent takenNames
src/Type/Unify.hs+153−140
@@ -125,42 +125,6 @@ reasonToProblem orientation maybeReason =
125125 Special (Error.flipReason reason)
126126
127127
128−badRigid :: Maybe Text -> Error.Reason
129−badRigid maybeName =
130− Error.BadVar (Just (Error.Rigid maybeName)) Nothing
131−
132−
133−badSuper :: Super -> Error.Reason
134−badSuper super =
135− Error.BadVar (Just (errorSuper super)) Nothing
136−
137−
138−badSupers :: Super -> Super -> Error.Reason
139−badSupers super1 super2 =
140− Error.BadVar (Just (errorSuper super1)) (Just (errorSuper super2))
141−
142−
143−doubleBad :: Error.VarType -> Error.VarType -> Error.Reason
144−doubleBad vt1 vt2 =
145− Error.BadVar (Just vt1) (Just vt2)
146−
147−
148−errorSuper :: Super -> Error.VarType
149−errorSuper super =
150− case super of
151− Number ->
152− Error.Number
153−
154− Comparable ->
155− Error.Comparable
156−
157− Appendable ->
158− Error.Appendable
159−
160− CompAppend ->
161− Error.CompAppend
162−
163−
164128
165129-- MERGE
166130
@@ -210,25 +174,28 @@ subUnify context var1 var2 =
210174actuallyUnify :: Context -> Unify ()
211175actuallyUnify context@(Context _ _ (Descriptor firstContent _ _ _) _ (Descriptor secondContent _ _ _)) =
212176 case firstContent of
213− Error _ ->
214− -- If there was an error, just pretend it is okay. This lets us avoid
215− -- "cascading" errors where one problem manifests as multiple message.
216− return ()
217−
218− Var Flex Nothing _ ->
177+ FlexVar _ ->
219178 unifyFlex context secondContent
220179
221− Var Flex (Just super) _ ->
180+ FlexSuper super _ ->
222181 unifyFlexSuper context super firstContent secondContent
223182
224− Var Rigid maybeSuper maybeName ->
225− unifyRigid context maybeSuper maybeName firstContent secondContent
183+ RigidVar name ->
184+ unifyRigid context Nothing name firstContent secondContent
185+
186+ RigidSuper super name ->
187+ unifyRigid context (Just super) name firstContent secondContent
226188
227189 Alias name args realVar ->
228190 unifyAlias context name args realVar secondContent
229191
230− Structure term ->
231− unifyStructure context term firstContent secondContent
192+ Structure flatType ->
193+ unifyStructure context flatType firstContent secondContent
194+
195+ Error _ ->
196+ -- If there was an error, just pretend it is okay. This lets us avoid
197+ -- "cascading" errors where one problem manifests as multiple message.
198+ return ()
232199
233200
234201
@@ -241,10 +208,18 @@ unifyFlex context otherContent =
241208 Error _ ->
242209 return ()
243210
244− Var Flex _ _ ->
211+ -- TODO see if wildcarding makes a noticable perf difference
212+
213+ FlexVar _ ->
214+ merge context otherContent
215+
216+ FlexSuper _ _ ->
217+ merge context otherContent
218+
219+ RigidVar _ ->
245220 merge context otherContent
246221
247− Var Rigid _ _ ->
222+ RigidSuper _ _ ->
248223 merge context otherContent
249224
250225 Alias _ _ _ ->
@@ -258,35 +233,61 @@ unifyFlex context otherContent =
258233-- UNIFY RIGID VARIABLES
259234
260235
261−unifyRigid :: Context -> Maybe Super -> Maybe Text -> Content -> Content -> Unify ()
262−unifyRigid context maybeSuper maybeName content otherContent =
236+unifyRigid :: Context -> Maybe Super -> Text -> Content -> Content -> Unify ()
237+unifyRigid context maybeSuper name content otherContent =
263238 case otherContent of
264− Error _ ->
265− return ()
239+ FlexVar _ ->
240+ merge context content
266241
267− Var Flex otherMaybeSuper _ ->
268− case (maybeSuper, otherMaybeSuper) of
269− (_, Nothing) ->
242+ FlexSuper otherSuper _ ->
243+ case maybeSuper of
244+ Just super ->
245+ if combineRigidSupers super otherSuper then
270246 merge context content
247+ else
248+ mismatch context $ Just $
249+ Error.RigidSuperTooGeneric super name $ Error.SpecificSuper otherSuper
271250
272− (Nothing, Just _) ->
273− mismatch context (Just (badRigid maybeName))
251+ Nothing ->
252+ mismatch context $ Just $
253+ Error.RigidVarTooGeneric name $ Error.SpecificSuper otherSuper
274254
275− (Just super, Just otherSuper) ->
276− if combineRigidSupers super otherSuper then
277− merge context content
278− else
279− mismatch context (Just (badRigid maybeName))
255+ RigidVar otherName ->
256+ mismatch context $ Just $
257+ Error.RigidClash name otherName
280258
281− Var Rigid _ otherMaybeName ->
259+ RigidSuper _ otherName ->
282260 mismatch context $ Just $
283− doubleBad (Error.Rigid maybeName) (Error.Rigid otherMaybeName)
261+ Error.RigidClash name otherName
284262
285− Alias _ _ _ ->
286− mismatch context (Just (badRigid maybeName))
263+ Alias otherName _ _ ->
264+ mismatch context $ Just $
265+ maybe Error.RigidVarTooGeneric Error.RigidSuperTooGeneric maybeSuper name $
266+ Error.SpecificType otherName
287267
288− Structure _ ->
289− mismatch context (Just (badRigid maybeName))
268+ Structure flatType ->
269+ mismatch context $ Just $
270+ maybe Error.RigidVarTooGeneric Error.RigidSuperTooGeneric maybeSuper name $
271+ flatTypeToSpecificThing flatType
272+
273+ Error _ ->
274+ return ()
275+
276+
277+flatTypeToSpecificThing :: FlatType -> Error.SpecificThing
278+flatTypeToSpecificThing flatType =
279+ case flatType of
280+ App1 name _ ->
281+ Error.SpecificType name
282+
283+ Fun1 _ _ ->
284+ Error.SpecificFunction
285+
286+ EmptyRecord1 ->
287+ Error.SpecificRecord
288+
289+ Record1 _ _ ->
290+ Error.SpecificRecord
290291
291292
292293
@@ -296,49 +297,51 @@ unifyRigid context maybeSuper maybeName content otherContent =
296297unifyFlexSuper :: Context -> Super -> Content -> Content -> Unify ()
297298unifyFlexSuper context super content otherContent =
298299 case otherContent of
299− Structure term ->
300− unifyFlexSuperStructure context super term
300+ Structure flatType ->
301+ unifyFlexSuperStructure context super flatType
301302
302− Var Rigid Nothing maybeName ->
303− mismatch context (Just (doubleBad (errorSuper super) (Error.Rigid maybeName)))
303+ RigidVar name ->
304+ mismatch context $ Just $
305+ Error.RigidVarTooGeneric name (Error.SpecificSuper super)
304306
305− Var Rigid (Just otherSuper) maybeName ->
307+ RigidSuper otherSuper name ->
306308 if combineRigidSupers otherSuper super then
307309 merge context otherContent
308310 else
309− mismatch context $ Just $ badRigid maybeName
311+ mismatch context $ Just $
312+ Error.RigidSuperTooGeneric otherSuper name (Error.SpecificSuper super)
310313
311− Var Flex Nothing _ ->
314+ FlexVar _ ->
312315 merge context content
313316
314− Var Flex (Just otherSuper) _ ->
317+ FlexSuper otherSuper _ ->
315318 case super of
316319 Number ->
317320 case otherSuper of
318321 Number -> merge context content
319322 Comparable -> merge context content
320− _ -> mismatch context $ Just $ badSupers super otherSuper
323+ _ -> mismatch context Nothing -- Error.NumberAppendableClash
321324
322325 Comparable ->
323326 case otherSuper of
324327 Comparable -> merge context otherContent
325328 Number -> merge context otherContent
326− Appendable -> merge context (Var Flex (Just CompAppend) Nothing)
329+ Appendable -> merge context (Type.unnamedFlexSuper CompAppend)
327330 CompAppend -> merge context otherContent
328331
329332 Appendable ->
330333 case otherSuper of
331334 Appendable -> merge context otherContent
332− Comparable -> merge context (Var Flex (Just CompAppend) Nothing)
335+ Comparable -> merge context (Type.unnamedFlexSuper CompAppend)
333336 CompAppend -> merge context otherContent
334− Number -> mismatch context $ Just $ badSupers super otherSuper
337+ Number -> mismatch context Nothing -- Error.NumberAppendableClash
335338
336339 CompAppend ->
337340 case otherSuper of
338341 Comparable -> merge context content
339342 Appendable -> merge context content
340343 CompAppend -> merge context content
341− Number -> mismatch context $ Just $ badSupers super otherSuper
344+ Number -> mismatch context Nothing -- Error.NumberAppendableClash
342345
343346 Alias _ _ realVar ->
344347 subUnify context (_first context) realVar
@@ -371,54 +374,54 @@ atomMatchesSuper super name =
371374
372375
373376unifyFlexSuperStructure :: Context -> Super -> FlatType -> Unify ()
374−unifyFlexSuperStructure context super term =
375− do case term of
376− App1 name [] ->
377− if atomMatchesSuper super name then
378− merge context (Structure term)
379− else
380− mismatch context (Just (badSuper super))
381−
382− App1 name [variable] | name == Var.list ->
383− case super of
384− Number ->
385− mismatch context (Just (badSuper super))
386−
387− Appendable ->
388− merge context (Structure term)
389−
390− Comparable ->
391− do comparableOccursCheck context
392− merge context (Structure term)
393− unifyComparableRecursive (_orientation context) variable
377+unifyFlexSuperStructure context super flatType =
378+ case flatType of
379+ App1 name [] ->
380+ if atomMatchesSuper super name then
381+ merge context (Structure flatType)
382+ else
383+ mismatch context $ Just $ Error.NotPartOfSuper super
384+
385+ App1 name [variable] | name == Var.list ->
386+ case super of
387+ Number ->
388+ mismatch context $ Just $ Error.NotPartOfSuper super
394389
395− CompAppend ->
396− do comparableOccursCheck context
397− merge context (Structure term)
398− unifyComparableRecursive (_orientation context) variable
390+ Appendable ->
391+ merge context (Structure flatType)
399392
400− App1 name args | Var.isTuple name ->
401− case super of
402− Number ->
403− mismatch context (Just (badSuper super))
393+ Comparable ->
394+ do comparableOccursCheck context
395+ merge context (Structure flatType)
396+ unifyComparableRecursive (_orientation context) variable
404397
405− Appendable ->
406− mismatch context (Just (badSuper super))
398+ CompAppend ->
399+ do comparableOccursCheck context
400+ merge context (Structure flatType)
401+ unifyComparableRecursive (_orientation context) variable
407402
408− Comparable ->
409− if length args > 6 then
410− mismatch context (Just (Error.TooLongComparableTuple (length args)))
403+ App1 name args | Var.isTuple name ->
404+ case super of
405+ Number ->
406+ mismatch context $ Just $ Error.NotPartOfSuper super
411407
412− else
413− do comparableOccursCheck context
414− merge context (Structure term)
415− mapM_ (unifyComparableRecursive (_orientation context)) args
408+ Appendable ->
409+ mismatch context $ Just $ Error.NotPartOfSuper super
416410
417− CompAppend ->
418− mismatch context (Just (badSuper super))
411+ Comparable ->
412+ if length args > 6 then
413+ mismatch context (Just (Error.TooLongComparableTuple (length args)))
419414
420− _ ->
421− mismatch context (Just (badSuper super))
415+ else
416+ do comparableOccursCheck context
417+ merge context (Structure flatType)
418+ mapM_ (unifyComparableRecursive (_orientation context)) args
419+
420+ CompAppend ->
421+ mismatch context $ Just $ Error.NotPartOfSuper super
422+
423+ _ ->
424+ mismatch context $ Just $ Error.NotPartOfSuper super
422425
423426
424427-- TODO: is there some way to avoid doing this?
@@ -435,7 +438,7 @@ unifyComparableRecursive :: Orientation -> Variable -> Unify ()
435438unifyComparableRecursive orientation var =
436439 do compVar <- liftIO $
437440 do (Descriptor _ rank _ _) <- UF.descriptor var
438− UF.fresh $ Descriptor (Var Flex (Just Comparable) Nothing) rank noMark Nothing
441+ UF.fresh $ Descriptor (Type.unnamedFlexSuper Comparable) rank noMark Nothing
439442
440443 lift $ TS.register compVar
441444
@@ -465,13 +468,16 @@ collectArgsHelp revArgs variable =
465468unifyAlias :: Context -> Var.Canonical -> [(Text, Variable)] -> Variable -> Content -> Unify ()
466469unifyAlias context name args realVar otherContent =
467470 case otherContent of
468− Error _ ->
469− return ()
470−
471− Var Flex Nothing _ ->
471+ FlexVar _ ->
472472 merge context (Alias name args realVar)
473473
474− Var _ _ _ ->
474+ FlexSuper _ _ ->
475+ subUnify context realVar (_second context)
476+
477+ RigidVar _ ->
478+ subUnify context realVar (_second context)
479+
480+ RigidSuper _ _ ->
475481 subUnify context realVar (_second context)
476482
477483 Alias otherName otherArgs otherRealVar ->
@@ -485,31 +491,34 @@ unifyAlias context name args realVar otherContent =
485491 Structure _ ->
486492 subUnify context realVar (_second context)
487493
494+ Error _ ->
495+ return ()
496+
488497
489498
490499-- UNIFY STRUCTURES
491500
492501
493502unifyStructure :: Context -> FlatType -> Content -> Content -> Unify ()
494−unifyStructure context term content otherContent =
503+unifyStructure context flatType content otherContent =
495504 case otherContent of
496− Error _ ->
497− return ()
498−
499− Var Flex Nothing _ ->
505+ FlexVar _ ->
500506 merge context content
501507
502− Var Flex (Just super) _ ->
503− unifyFlexSuperStructure (reorient context) super term
508+ FlexSuper super _ ->
509+ unifyFlexSuperStructure (reorient context) super flatType
504510
505− Var Rigid _ maybeName ->
506− mismatch context (Just (Error.flipReason (badRigid maybeName)))
511+ RigidVar name ->
512+ mismatch context $ Just $ Error.RigidVarTooGeneric name (flatTypeToSpecificThing flatType)
513+
514+ RigidSuper super name ->
515+ mismatch context $ Just $ Error.RigidSuperTooGeneric super name (flatTypeToSpecificThing flatType)
507516
508517 Alias _ _ realVar ->
509518 subUnify context (_first context) realVar
510519
511520 Structure otherTerm ->
512− case (term, otherTerm) of
521+ case (flatType, otherTerm) of
513522 (App1 name args, App1 otherName otherArgs) ->
514523 if name == otherName then
515524 do zipWithM_ (subUnify context) args otherArgs
@@ -543,6 +552,10 @@ unifyStructure context term content otherContent =
543552 _ ->
544553 mismatch context Nothing
545554
555+ Error _ ->
556+ return ()
557+
558+
546559
547560isIntFloat :: Var.Canonical -> Var.Canonical -> Bool
548561isIntFloat name otherName =
@@ -595,7 +608,7 @@ unifyRecord context firstStructure secondStructure =
595608
596609 (Extension, False, Extension, False) ->
597610 do let subFields = Map.union uniqueExpFields uniqueActFields
598− subExt <- fresh context (Var Flex Nothing Nothing)
611+ subExt <- fresh context Type.unnamedFlexVar
599612 expRecord <- fresh context (Structure (Record1 uniqueActFields subExt))
600613 actRecord <- fresh context (Structure (Record1 uniqueExpFields subExt))
601614 subUnify context expVar expRecord