diff --git a/src/Internal/Compiler.elm b/src/Internal/Compiler.elm index 796e46a..0521afa 100644 --- a/src/Internal/Compiler.elm +++ b/src/Internal/Compiler.elm @@ -1020,7 +1020,7 @@ resolve index cache annotation = getRestrictions annotation cache in newAnnotation - |> rewriteTypeVariables + |> rewriteTypeVariables cache |> checkRestrictions restrictions Err err -> @@ -1286,19 +1286,115 @@ getRestrictionsHelper existingRestrictions notation cache = existingRestrictions -rewriteTypeVariables : Annotation.TypeAnnotation -> Annotation.TypeAnnotation -rewriteTypeVariables type_ = +{-| Rewrite type variable names to clean forms, preserving typeclass +constraint names. + +When a constrained type variable (like `number_0`) gets resolved to +another generic variable (like `arg_0`), the constraint name is lost. +This function builds a mapping from resolved variable names back to +their constraint names, so `arg_0` gets renamed to `number` instead +of `a`. +-} +rewriteTypeVariables : + VariableCache + -> Annotation.TypeAnnotation + -> Annotation.TypeAnnotation +rewriteTypeVariables cache resolvedAnnotation = let + -- Build a map from resolved generic names to constraint names. + -- Check BOTH directions: + -- 1. Forward: a constrained name (number_0) maps to a generic (arg_0) + -- 2. Reverse: a generic (arg_0) maps to a constrained name (comparable) + -- Case 2 happens with applyInfix operators that use fixed names + -- like "comparable" which then get unified with arg variables. + constraintOverrides : Dict String String + constraintOverrides = + Dict.foldl + (\key value acc -> + case value of + Annotation.GenericType resolvedName -> + let + keyRestriction = + nameToRestrictions key + in + case keyRestriction of + NoRestrictions -> + -- Key has no constraint, but maybe the + -- resolved name does (reverse direction) + let + resolvedRestriction = + nameToRestrictions resolvedName + in + case resolvedRestriction of + NoRestrictions -> + acc + + _ -> + -- The target has a constraint — propagate + -- it to the key name + Dict.insert key + (restrictionToName resolvedRestriction) + acc + + _ -> + -- Key has a constraint — propagate to resolved name + Dict.insert resolvedName + (restrictionToName keyRestriction) + acc + + _ -> + acc + ) + Dict.empty + cache + existing : Set String existing = - getGenericsHelper type_ + getGenericsHelper resolvedAnnotation |> Set.fromList in - Tuple.second (rewriteTypeVariablesHelper existing Dict.empty type_) + Tuple.second + (rewriteTypeVariablesHelper + constraintOverrides + existing + Dict.empty + resolvedAnnotation + ) + +restrictionToName : Restrictions -> String +restrictionToName restriction = + case restriction of + IsNumber -> + "number" + + IsComparable -> + "comparable" + + IsAppendable -> + "appendable" + + IsAppendableComparable -> + "compappend" -rewriteTypeVariablesHelper : Set String -> Dict String String -> Annotation.TypeAnnotation -> ( Dict String String, Annotation.TypeAnnotation ) -rewriteTypeVariablesHelper existing renames type_ = + _ -> + "a" + + +{-| Rewrite type variable names to clean, simplified forms. + +The `overrides` dict maps variable names to constraint names +(e.g., "arg\_0" → "number") so that typeclass constraints are +preserved through the renaming process. Pass `Dict.empty` when +no constraint preservation is needed. +-} +rewriteTypeVariablesHelper : + Dict String String + -> Set String + -> Dict String String + -> Annotation.TypeAnnotation + -> ( Dict String String, Annotation.TypeAnnotation ) +rewriteTypeVariablesHelper overrides existing renames type_ = case type_ of Annotation.GenericType varName -> case Dict.get varName renames of @@ -1306,10 +1402,14 @@ rewriteTypeVariablesHelper existing renames type_ = let simplified : String simplified = - simplify varName + case Dict.get varName overrides of + Just constraintName -> + constraintName + + Nothing -> + simplify varName in if Set.member simplified existing && varName /= simplified then - -- We would have collided with an existing generic name ( renames, Annotation.GenericType simplified ) else @@ -1326,7 +1426,7 @@ rewriteTypeVariablesHelper existing renames type_ = (\(Node _ typevar) ( varUsed, varList ) -> let ( oneUsed, oneType ) = - rewriteTypeVariablesHelper existing varUsed typevar + rewriteTypeVariablesHelper overrides existing varUsed typevar in ( oneUsed, nodify oneType :: varList ) ) @@ -1351,10 +1451,10 @@ rewriteTypeVariablesHelper existing renames type_ = Annotation.FunctionTypeAnnotation (Node _ one) (Node _ two) -> let ( oneUsed, oneType ) = - rewriteTypeVariablesHelper existing renames one + rewriteTypeVariablesHelper overrides existing renames one ( twoUsed, twoType ) = - rewriteTypeVariablesHelper existing oneUsed two + rewriteTypeVariablesHelper overrides existing oneUsed two in ( twoUsed , Annotation.FunctionTypeAnnotation diff --git a/tests/TypeChecking.elm b/tests/TypeChecking.elm index 25a9ab3..d3c5154 100644 --- a/tests/TypeChecking.elm +++ b/tests/TypeChecking.elm @@ -271,6 +271,74 @@ generatedCode = ( 1 + 2, x ) """ ] + , describe "Typeclass constraints preserved in polymorphic annotations" + [ test "number constraint: polymorphic plus produces number annotation" <| + \_ -> + Elm.Declare.fn2 "addBoth" + (Arg.var "a") + (Arg.var "b") + (\a b -> Elm.Op.plus a b) + |> .declaration + |> Elm.Expect.declarationAs + """ + addBoth : number -> number -> number + addBoth a b = + a + b + """ + , test "comparable constraint: polymorphic compare produces comparable annotation" <| + \_ -> + Elm.Declare.fn2 "compareBoth" + (Arg.var "a") + (Arg.var "b") + (\a b -> Elm.Op.lt a b) + |> .declaration + |> Elm.Expect.declarationAs + """ + compareBoth : comparable -> comparable -> Bool + compareBoth a b = + a < b + """ + , test "appendable constraint: polymorphic append produces appendable annotation" <| + \_ -> + Elm.Declare.fn2 "appendBoth" + (Arg.var "a") + (Arg.var "b") + (\a b -> Elm.Op.append a b) + |> .declaration + |> Elm.Expect.declarationAs + """ + appendBoth : appendable -> appendable -> appendable + appendBoth a b = + a ++ b + """ + , test "number constraint narrows to Float via nested arithmetic" <| + -- Both polymorphic args flow through arithmetic with a + -- Float literal, so both narrow to Float. + \_ -> + Elm.Declare.fn2 "addToFloat" + (Arg.var "a") + (Arg.var "b") + (\a b -> Elm.Op.plus a (Elm.Op.plus b (Elm.float 1.0))) + |> .declaration + |> Elm.Expect.declarationAs + """ + addToFloat : Float -> Float -> Float + addToFloat a b = + a + (b + 1) + """ + , test "comparable used with concrete Char" <| + \_ -> + Elm.Declare.fn "isLessThanZ" + (Arg.var "c") + (\c -> Elm.Op.lt c (Elm.char 'z')) + |> .declaration + |> Elm.Expect.declarationAs + """ + isLessThanZ : Char.Char -> Bool + isLessThanZ c = + c < 'z' + """ + ] , test "Triple with mixed Float and Int infers correct types" <| \_ -> Elm.declaration "myTriple"