Stabel

Check-in [efd95fdaff]
Login
Overview
Comment:TypeChecker is ported over. Exhaustiveness checking tests are failing.
Timelines: family | ancestors | descendants | both | int-literals-in-pattern-match
Files: files | file ages | folders
SHA3-256: efd95fdaff2520a4d81915adaad37808800f730a6d636bb192e643fd71405f5f
User & Date: robin.hansen on 2021-09-22 10:11:14
Other Links: branch diff | manifest | tags
Context
2021-09-22
10:47
Fix inexhaustiveness bugs. check-in: beb3f5edc2 user: robin.hansen tags: int-literals-in-pattern-match
10:11
TypeChecker is ported over. Exhaustiveness checking tests are failing. check-in: efd95fdaff user: robin.hansen tags: int-literals-in-pattern-match
09:12
Parser and Qualifier updated with new type match structure. check-in: f6408f42e9 user: robin.hansen tags: int-literals-in-pattern-match
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Modified src/Stabel/Qualifier.elm from [186078bf1d] to [8ec9cb1f71].

70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
....
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042

1043
1044
1045
1046
1047
1048
1049
type FunctionImplementation
    = SoloImpl (List Node)
    | MultiImpl (List ( TypeMatch, List Node )) (List Node)


type TypeMatch
    = TypeMatchInt SourceLocationRange Int
    | TypeMatchType SourceLocationRange Type (List ( String, TypeMatch ))


type Node
    = Integer SourceLocationRange Int
    | Function SourceLocationRange FunctionDefinition
    | FunctionRef SourceLocationRange FunctionDefinition
    | Recurse SourceLocationRange
................................................................................
    RunConfig
    -> Dict String TypeDefinition
    -> ModuleReferences
    -> SourceLocationRange
    -> String
    -> List ( String, Type )
    -> ( String, Parser.TypeMatch )
    -> Result Problem ( String, TypeMatch )
qualifyMatchValue config qualifiedTypes modRefs range typeName members ( fieldName, matchValue ) =
    case List.find ((==) fieldName << Tuple.first) members of
        Just _ ->
            matchValue
                |> qualifyMatch config qualifiedTypes modRefs
                |> Result.map
                    (\match ->
                        ( fieldName

                        , match
                        )
                    )

        _ ->
            Err <| NoSuchMemberOnType range typeName fieldName








|







 







|


|





>







70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
....
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
type FunctionImplementation
    = SoloImpl (List Node)
    | MultiImpl (List ( TypeMatch, List Node )) (List Node)


type TypeMatch
    = TypeMatchInt SourceLocationRange Int
    | TypeMatchType SourceLocationRange Type (List ( String, Type, TypeMatch ))


type Node
    = Integer SourceLocationRange Int
    | Function SourceLocationRange FunctionDefinition
    | FunctionRef SourceLocationRange FunctionDefinition
    | Recurse SourceLocationRange
................................................................................
    RunConfig
    -> Dict String TypeDefinition
    -> ModuleReferences
    -> SourceLocationRange
    -> String
    -> List ( String, Type )
    -> ( String, Parser.TypeMatch )
    -> Result Problem ( String, Type, TypeMatch )
qualifyMatchValue config qualifiedTypes modRefs range typeName members ( fieldName, matchValue ) =
    case List.find ((==) fieldName << Tuple.first) members of
        Just ( _, fieldType ) ->
            matchValue
                |> qualifyMatch config qualifiedTypes modRefs
                |> Result.map
                    (\match ->
                        ( fieldName
                        , fieldType
                        , match
                        )
                    )

        _ ->
            Err <| NoSuchMemberOnType range typeName fieldName

Modified src/Stabel/TypeChecker.elm from [cb83d58fcb] to [4361766d21].

2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
..
43
44
45
46
47
48
49

50
51
52
53
54
55
56
57
58
59
60
61
62
63
...
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
...
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
...
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587

588
589
590
591
592
593
594
...
607
608
609
610
611
612
613
614
615



616
617
618
619
620
621
622
...
623
624
625
626
627
628
629
















630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646

647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
...
707
708
709
710
711
712
713
714




715
716
717
718
719
720
721
...
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
...
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
....
1077
1078
1079
1080
1081
1082
1083
1084
1085


1086
1087

1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
....
1123
1124
1125
1126
1127
1128
1129
1130
1131








1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
    ( AST
    , AstNode(..)
    , CycleData
    , FunctionDefinition
    , FunctionImplementation(..)
    , TypeDefinition
    , TypeMatch(..)
    , TypeMatchValue(..)
    , run
    )

import Dict exposing (Dict)
import List.Extra as List
import Result.Extra as Result
import Set exposing (Set)
................................................................................

type FunctionImplementation
    = SoloImpl (List AstNode)
    | MultiImpl (List ( TypeMatch, List AstNode )) (List AstNode)


type TypeMatch

    = TypeMatch SourceLocationRange Type (List ( String, TypeMatchValue ))


type TypeMatchValue
    = LiteralInt Int
    | LiteralType Type
    | RecursiveMatch TypeMatch


type AstNode
    = IntLiteral SourceLocationRange Int
    | ArrayLiteral SourceLocationRange (List AstNode) Type
    | Function SourceLocationRange FunctionDefinition FunctionType
    | FunctionRef SourceLocationRange FunctionDefinition
................................................................................
                                untypedDef
                                untypedDef.typeSignature
                                defaultImpl
                                (cleanContext context)
                    in
                    case inferredDefaultType.input of
                        [] ->
                            ( Qualifier.TypeMatch SourceLocation.emptyRange (Type.Generic "*") [], defaultImpl ) :: initialWhens

                        firstType :: _ ->
                            ( Qualifier.TypeMatch SourceLocation.emptyRange firstType [], defaultImpl ) :: initialWhens

        whens =
            List.map (Tuple.mapFirst (resolveWhenConditions untypedDef)) allBranches

        ( inferredWhenTypes, newContext ) =
            whens
                |> List.foldr (inferWhenTypes untypedDef) ( [], context )
................................................................................
    in
    ( typedDef
    , finalContext
    )


resolveWhenConditions : Qualifier.FunctionDefinition -> Qualifier.TypeMatch -> Qualifier.TypeMatch
resolveWhenConditions untypedDef ((Qualifier.TypeMatch loc typeMatch conds) as match) =
    case typeMatch of
        Type.CustomGeneric _ structGenerics ->
            let
                bindings =
                    List.foldl
                        whenConditionsGenericBindings
                        (initialBindingsFromFunctionDef untypedDef structGenerics)
                        conds
            in
            Qualifier.TypeMatch
                loc
                (bindGenericsInType bindings typeMatch)
                (List.map (whenConditionsBindGenerics bindings) conds)

        _ ->
            match


initialBindingsFromFunctionDef : Qualifier.FunctionDefinition -> List Type -> Dict String Type
................................................................................
                _ ->
                    Dict.empty

        Nothing ->
            Dict.empty


whenConditionsGenericBindings : Qualifier.TypeMatchCond -> Dict String Type -> Dict String Type
whenConditionsGenericBindings (Qualifier.TypeMatchCond _ fieldType value) bindings =
    case ( fieldType, value ) of
        ( Type.Generic genericName, Qualifier.LiteralInt _ ) ->
            Dict.insert genericName Type.Int bindings

        ( Type.Generic genericName, Qualifier.LiteralType t ) ->
            Dict.insert genericName t bindings

        ( _, Qualifier.RecursiveMatch (Qualifier.TypeMatch _ _ subConds) ) ->
            List.foldl whenConditionsGenericBindings bindings subConds

        _ ->
            bindings


whenConditionsBindGenerics : Dict String Type -> Qualifier.TypeMatchCond -> Qualifier.TypeMatchCond
whenConditionsBindGenerics bindings (Qualifier.TypeMatchCond fieldName fieldType value) =
    let
        boundValue =
            case value of
                Qualifier.LiteralType t ->
                    Qualifier.LiteralType <| bindGenericsInType bindings t

                Qualifier.RecursiveMatch (Qualifier.TypeMatch subLoc subType subConds) ->
                    Qualifier.RecursiveMatch <|
                        Qualifier.TypeMatch
                            subLoc
                            (bindGenericsInType bindings subType)
                            (List.map (whenConditionsBindGenerics bindings) subConds)

                _ ->
                    value
    in
    Qualifier.TypeMatchCond
        fieldName
        (bindGenericsInType bindings fieldType)
        boundValue



bindGenericsInType : Dict String Type -> Type -> Type
bindGenericsInType bindings t =
    case t of
        Type.Generic genericName ->
            Dict.get genericName bindings
................................................................................


inferWhenTypes :
    Qualifier.FunctionDefinition
    -> ( Qualifier.TypeMatch, List Qualifier.Node )
    -> ( List FunctionType, Context )
    -> ( List FunctionType, Context )
inferWhenTypes untypedDef ( Qualifier.TypeMatch _ t _, im ) ( infs, ctx ) =
    let



        alteredTypeSignature =
            case untypedDef.typeSignature of
                TypeSignature.UserProvided wt ->
                    TypeSignature.UserProvided <|
                        case wt.input of
                            firstAnnotatedType :: rest ->
                                { wt | input = resolveFirstType firstAnnotatedType t :: rest }
................................................................................

                            _ ->
                                wt

                x ->
                    x

















        resolveFirstType : Type -> Type -> Type
        resolveFirstType annotatedType typeMatchType =
            case ( annotatedType, typeMatchType ) of
                ( Type.Union _ unionMembers, Type.CustomGeneric name _ ) ->
                    List.find (matchingCustomGenericType name) unionMembers
                        |> Maybe.withDefault typeMatchType

                ( Type.CustomGeneric annName _, Type.CustomGeneric matchName _ ) ->
                    if annName == matchName then
                        annotatedType

                    else
                        typeMatchType

                _ ->
                    typeMatchType


        matchingCustomGenericType : String -> Type -> Bool
        matchingCustomGenericType nameToMatch tipe =
            case tipe of
                Type.CustomGeneric name _ ->
                    name == nameToMatch

                _ ->
                    False

        ( inf, newCtx ) =
            typeCheckImplementation untypedDef alteredTypeSignature im (cleanContext ctx)
    in
    ( inf :: infs, newCtx )


normalizeWhenTypes : List FunctionType -> List FunctionType
normalizeWhenTypes whenTypes =
    let
        maybeLongestInputWhenType =
            List.sortBy (.input >> List.length) whenTypes
                |> List.reverse
................................................................................
        (\wt -> Tuple.first (simplifyFunctionType ( wt, context )))
        functionTypes
    , context
    )


replaceFirstTypeWithPatternMatch : ( Qualifier.TypeMatch, FunctionType ) -> FunctionType
replaceFirstTypeWithPatternMatch ( Qualifier.TypeMatch _ matchType _, typeSignature ) =




    case typeSignature.input of
        ((Type.Generic _) as toReplace) :: _ ->
            { input = List.map (replaceType toReplace matchType) typeSignature.input
            , output = List.map (replaceType toReplace matchType) typeSignature.output
            }

        ((Type.StackRange _) as toReplace) :: _ ->
................................................................................


unionOfTypeMatches : List ( Qualifier.TypeMatch, a ) -> Type
unionOfTypeMatches whenBranches =
    let
        uniqueTypes =
            whenBranches
                |> List.map (Tuple.first >> extractTypeFromTypeMatch)
                |> List.concatMap flattenUnions
                |> List.gatherEquals
                |> List.map Tuple.first

        flattenUnions t =
            case t of
                Type.Union _ members ->
................................................................................
                (constrainedFunction :: acc)

        ( _ :: annotatedRest, inferredEl :: inferredRest ) ->
            constrainGenericsHelper remappedGenerics annotatedRest inferredRest (inferredEl :: acc)


patternMatchIsCompatibleWithInferredType : ( Qualifier.TypeMatch, FunctionType ) -> Bool
patternMatchIsCompatibleWithInferredType ( Qualifier.TypeMatch _ typeMatchType _, inf ) =
    case inf.input of
        inferredType :: _ ->
            Type.genericlyCompatible typeMatchType inferredType

        [] ->
            False


dropFirstInputType : FunctionType -> FunctionType
dropFirstInputType inf =
................................................................................
                |> Maybe.map .input
                |> Maybe.withDefault []
    in
    functionTypeFromStackEffects untypedDef contextWithStackEffects
        |> (\( ctx, wt ) -> ( { wt | input = wt.input ++ annotatedInput }, ctx ))
        |> simplifyFunctionType


extractTypeFromTypeMatch : Qualifier.TypeMatch -> Type


extractTypeFromTypeMatch (Qualifier.TypeMatch _ t_ _) =
    t_



mapTypeMatch : Qualifier.TypeMatch -> TypeMatch
mapTypeMatch (Qualifier.TypeMatch range type_ cond) =
    TypeMatch range type_ (List.map mapTypeMatchCond cond)


mapTypeMatchCond : Qualifier.TypeMatchCond -> ( String, TypeMatchValue )
mapTypeMatchCond (Qualifier.TypeMatchCond fieldName _ value) =
    case value of
        Qualifier.LiteralInt val ->
            ( fieldName, LiteralInt val )

        Qualifier.LiteralType val ->
            ( fieldName, LiteralType val )

        Qualifier.RecursiveMatch val ->
            ( fieldName, RecursiveMatch (mapTypeMatch val) )


type InexhaustiveState
    = Total
    | SeenInt


................................................................................
            Nothing

        _ ->
            Just (InexhaustiveMultiFunction range inexhaustiveStates)


inexhaustivenessCheckHelper : List Type -> Qualifier.TypeMatch -> List ( List Type, InexhaustiveState ) -> List ( List Type, InexhaustiveState )
inexhaustivenessCheckHelper typePrefix (Qualifier.TypeMatch _ t conds) acc =
    let








        typeList =
            typePrefix ++ [ t ]
    in
    if List.any (\( toMatch, state ) -> typeList == toMatch && state == Total) acc then
        acc

    else
        let
            subcases =
                conds
                    |> List.filterMap isRecursiveMatch
                    |> List.foldl (inexhaustivenessCheckHelper typeList) acc

            isRecursiveMatch cond =
                case cond of
                    Qualifier.TypeMatchCond _ _ (Qualifier.RecursiveMatch val) ->
                        Just val

                    _ ->
                        Nothing

            toAdd =
                case ( t, conds, subcases ) of
                    ( _, [], _ ) ->







<







 







>
|
<
<
<
<
<
<







 







|


|







 







|
|
|







|

|







 







|
|

|


|


|






|
|



<
<
<
|
<
|
|
|
|




<
|
|
|
>







 







|

>
>
>







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
|
|
|
|

|
|
|

|
|

|
|

>
|
|
|
|
|

|
|

<
<
<
<
<







 







|
>
>
>
>







 







|







 







|


|







 








|
>
>
|
<
>

<
|
<
|


|
|
<
<
|
<
<
<
<
<
<







 







|

>
>
>
>
>
>
>
>













|
|
|
|







2
3
4
5
6
7
8

9
10
11
12
13
14
15
..
42
43
44
45
46
47
48
49
50






51
52
53
54
55
56
57
...
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
...
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
...
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564



565

566
567
568
569
570
571
572
573

574
575
576
577
578
579
580
581
582
583
584
...
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
...
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665





666
667
668
669
670
671
672
...
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
...
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
....
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
....
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097

1098
1099

1100

1101
1102
1103
1104
1105


1106






1107
1108
1109
1110
1111
1112
1113
....
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
    ( AST
    , AstNode(..)
    , CycleData
    , FunctionDefinition
    , FunctionImplementation(..)
    , TypeDefinition
    , TypeMatch(..)

    , run
    )

import Dict exposing (Dict)
import List.Extra as List
import Result.Extra as Result
import Set exposing (Set)
................................................................................

type FunctionImplementation
    = SoloImpl (List AstNode)
    | MultiImpl (List ( TypeMatch, List AstNode )) (List AstNode)


type TypeMatch
    = TypeMatchInt SourceLocationRange Int
    | TypeMatchType SourceLocationRange Type (List ( String, TypeMatch ))








type AstNode
    = IntLiteral SourceLocationRange Int
    | ArrayLiteral SourceLocationRange (List AstNode) Type
    | Function SourceLocationRange FunctionDefinition FunctionType
    | FunctionRef SourceLocationRange FunctionDefinition
................................................................................
                                untypedDef
                                untypedDef.typeSignature
                                defaultImpl
                                (cleanContext context)
                    in
                    case inferredDefaultType.input of
                        [] ->
                            ( Qualifier.TypeMatchType SourceLocation.emptyRange (Type.Generic "*") [], defaultImpl ) :: initialWhens

                        firstType :: _ ->
                            ( Qualifier.TypeMatchType SourceLocation.emptyRange firstType [], defaultImpl ) :: initialWhens

        whens =
            List.map (Tuple.mapFirst (resolveWhenConditions untypedDef)) allBranches

        ( inferredWhenTypes, newContext ) =
            whens
                |> List.foldr (inferWhenTypes untypedDef) ( [], context )
................................................................................
    in
    ( typedDef
    , finalContext
    )


resolveWhenConditions : Qualifier.FunctionDefinition -> Qualifier.TypeMatch -> Qualifier.TypeMatch
resolveWhenConditions untypedDef match =
    case match of
        Qualifier.TypeMatchType loc ((Type.CustomGeneric _ structGenerics) as t) conds ->
            let
                bindings =
                    List.foldl
                        whenConditionsGenericBindings
                        (initialBindingsFromFunctionDef untypedDef structGenerics)
                        conds
            in
            Qualifier.TypeMatchType
                loc
                (bindGenericsInType bindings t)
                (List.map (whenConditionsBindGenerics bindings) conds)

        _ ->
            match


initialBindingsFromFunctionDef : Qualifier.FunctionDefinition -> List Type -> Dict String Type
................................................................................
                _ ->
                    Dict.empty

        Nothing ->
            Dict.empty


whenConditionsGenericBindings : ( String, Type, Qualifier.TypeMatch ) -> Dict String Type -> Dict String Type
whenConditionsGenericBindings ( _, fieldType, value ) bindings =
    case ( fieldType, value ) of
        ( Type.Generic genericName, Qualifier.TypeMatchInt _ _ ) ->
            Dict.insert genericName Type.Int bindings

        ( Type.Generic genericName, Qualifier.TypeMatchType _ t [] ) ->
            Dict.insert genericName t bindings

        ( _, Qualifier.TypeMatchType _ _ subConds ) ->
            List.foldl whenConditionsGenericBindings bindings subConds

        _ ->
            bindings


whenConditionsBindGenerics : Dict String Type -> ( String, Type, Qualifier.TypeMatch ) -> ( String, Type, Qualifier.TypeMatch )
whenConditionsBindGenerics bindings ( fieldName, fieldType, value ) =
    let
        boundValue =
            case value of



                Qualifier.TypeMatchType subLoc subType subConds ->

                    Qualifier.TypeMatchType
                        subLoc
                        (bindGenericsInType bindings subType)
                        (List.map (whenConditionsBindGenerics bindings) subConds)

                _ ->
                    value
    in

    ( fieldName
    , bindGenericsInType bindings fieldType
    , boundValue
    )


bindGenericsInType : Dict String Type -> Type -> Type
bindGenericsInType bindings t =
    case t of
        Type.Generic genericName ->
            Dict.get genericName bindings
................................................................................


inferWhenTypes :
    Qualifier.FunctionDefinition
    -> ( Qualifier.TypeMatch, List Qualifier.Node )
    -> ( List FunctionType, Context )
    -> ( List FunctionType, Context )
inferWhenTypes untypedDef ( typeMatch, im ) ( infs, ctx ) =
    let
        t =
            typeOfTypeMatch typeMatch

        alteredTypeSignature =
            case untypedDef.typeSignature of
                TypeSignature.UserProvided wt ->
                    TypeSignature.UserProvided <|
                        case wt.input of
                            firstAnnotatedType :: rest ->
                                { wt | input = resolveFirstType firstAnnotatedType t :: rest }
................................................................................

                            _ ->
                                wt

                x ->
                    x

        ( inf, newCtx ) =
            typeCheckImplementation untypedDef alteredTypeSignature im (cleanContext ctx)
    in
    ( inf :: infs, newCtx )


typeOfTypeMatch : Qualifier.TypeMatch -> Type
typeOfTypeMatch typeMatch =
    case typeMatch of
        Qualifier.TypeMatchInt _ _ ->
            Type.Int

        Qualifier.TypeMatchType _ t _ ->
            t


resolveFirstType : Type -> Type -> Type
resolveFirstType annotatedType typeMatchType =
    case ( annotatedType, typeMatchType ) of
        ( Type.Union _ unionMembers, Type.CustomGeneric name _ ) ->
            List.find (matchingCustomGenericType name) unionMembers
                |> Maybe.withDefault typeMatchType

        ( Type.CustomGeneric annName _, Type.CustomGeneric matchName _ ) ->
            if annName == matchName then
                annotatedType

            else
                typeMatchType

        _ ->
            typeMatchType


matchingCustomGenericType : String -> Type -> Bool
matchingCustomGenericType nameToMatch tipe =
    case tipe of
        Type.CustomGeneric name _ ->
            name == nameToMatch

        _ ->
            False







normalizeWhenTypes : List FunctionType -> List FunctionType
normalizeWhenTypes whenTypes =
    let
        maybeLongestInputWhenType =
            List.sortBy (.input >> List.length) whenTypes
                |> List.reverse
................................................................................
        (\wt -> Tuple.first (simplifyFunctionType ( wt, context )))
        functionTypes
    , context
    )


replaceFirstTypeWithPatternMatch : ( Qualifier.TypeMatch, FunctionType ) -> FunctionType
replaceFirstTypeWithPatternMatch ( typeMatch, typeSignature ) =
    let
        matchType =
            typeOfTypeMatch typeMatch
    in
    case typeSignature.input of
        ((Type.Generic _) as toReplace) :: _ ->
            { input = List.map (replaceType toReplace matchType) typeSignature.input
            , output = List.map (replaceType toReplace matchType) typeSignature.output
            }

        ((Type.StackRange _) as toReplace) :: _ ->
................................................................................


unionOfTypeMatches : List ( Qualifier.TypeMatch, a ) -> Type
unionOfTypeMatches whenBranches =
    let
        uniqueTypes =
            whenBranches
                |> List.map (Tuple.first >> typeOfTypeMatch)
                |> List.concatMap flattenUnions
                |> List.gatherEquals
                |> List.map Tuple.first

        flattenUnions t =
            case t of
                Type.Union _ members ->
................................................................................
                (constrainedFunction :: acc)

        ( _ :: annotatedRest, inferredEl :: inferredRest ) ->
            constrainGenericsHelper remappedGenerics annotatedRest inferredRest (inferredEl :: acc)


patternMatchIsCompatibleWithInferredType : ( Qualifier.TypeMatch, FunctionType ) -> Bool
patternMatchIsCompatibleWithInferredType ( typeMatch, inf ) =
    case inf.input of
        inferredType :: _ ->
            Type.genericlyCompatible (typeOfTypeMatch typeMatch) inferredType

        [] ->
            False


dropFirstInputType : FunctionType -> FunctionType
dropFirstInputType inf =
................................................................................
                |> Maybe.map .input
                |> Maybe.withDefault []
    in
    functionTypeFromStackEffects untypedDef contextWithStackEffects
        |> (\( ctx, wt ) -> ( { wt | input = wt.input ++ annotatedInput }, ctx ))
        |> simplifyFunctionType


mapTypeMatch : Qualifier.TypeMatch -> TypeMatch
mapTypeMatch typeMatch =
    case typeMatch of
        Qualifier.TypeMatchInt range val ->

            TypeMatchInt range val


        Qualifier.TypeMatchType range type_ cond ->

            TypeMatchType range type_ (List.map (mapQualifiedMatch mapTypeMatch) cond)


mapQualifiedMatch : (Qualifier.TypeMatch -> TypeMatch) -> ( String, Type, Qualifier.TypeMatch ) -> ( String, TypeMatch )
mapQualifiedMatch fn ( fieldName, _, match ) =


    ( fieldName, fn match )








type InexhaustiveState
    = Total
    | SeenInt


................................................................................
            Nothing

        _ ->
            Just (InexhaustiveMultiFunction range inexhaustiveStates)


inexhaustivenessCheckHelper : List Type -> Qualifier.TypeMatch -> List ( List Type, InexhaustiveState ) -> List ( List Type, InexhaustiveState )
inexhaustivenessCheckHelper typePrefix typeMatch acc =
    let
        ( t, conds ) =
            case typeMatch of
                Qualifier.TypeMatchInt _ _ ->
                    ( Type.Int, [] )

                Qualifier.TypeMatchType _ t_ conds_ ->
                    ( t_, conds_ )

        typeList =
            typePrefix ++ [ t ]
    in
    if List.any (\( toMatch, state ) -> typeList == toMatch && state == Total) acc then
        acc

    else
        let
            subcases =
                conds
                    |> List.filterMap isRecursiveMatch
                    |> List.foldl (inexhaustivenessCheckHelper typeList) acc

            isRecursiveMatch ( _, _, match ) =
                case match of
                    Qualifier.TypeMatchType _ _ (_ :: _) ->
                        Just match

                    _ ->
                        Nothing

            toAdd =
                case ( t, conds, subcases ) of
                    ( _, [], _ ) ->

Modified tests/Test/Qualifier.elm from [a654cc777a] to [eb2f930745].

172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
                        , typeSignature =
                            TypeSignature.UserProvided
                                { input = [ usMoneyUnionType ]
                                , output = [ Type.Int ]
                                }
                        , implementation =
                            MultiImpl
                                [ ( TypeMatch emptyRange (Type.Custom "/stabel/test/some/module/Dollar") []
                                  , [ Function emptyRange dollarValueGetFn
                                    , Integer emptyRange 100
                                    , Builtin emptyRange Builtin.Multiply
                                    ]
                                  )
                                , ( TypeMatch emptyRange (Type.Custom "/stabel/test/some/module/Cent") []
                                  , [ Function emptyRange centValueGetFn
                                    ]
                                  )
                                ]
                                []
                        }








|





|







172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
                        , typeSignature =
                            TypeSignature.UserProvided
                                { input = [ usMoneyUnionType ]
                                , output = [ Type.Int ]
                                }
                        , implementation =
                            MultiImpl
                                [ ( TypeMatchType emptyRange (Type.Custom "/stabel/test/some/module/Dollar") []
                                  , [ Function emptyRange dollarValueGetFn
                                    , Integer emptyRange 100
                                    , Builtin emptyRange Builtin.Multiply
                                    ]
                                  )
                                , ( TypeMatchType emptyRange (Type.Custom "/stabel/test/some/module/Cent") []
                                  , [ Function emptyRange centValueGetFn
                                    ]
                                  )
                                ]
                                []
                        }

Modified tests/Test/Qualifier/Util.elm from [8fae3ca458] to [f6240479a5].

5
6
7
8
9
10
11

12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
...
158
159
160
161
162
163
164
165
166
167

168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
    , stripLocations
    )

import Dict
import Expect exposing (Expectation)
import Set
import Stabel.Data.SourceLocation exposing (emptyRange)

import Stabel.Parser as Parser
import Stabel.Qualifier as AST
    exposing
        ( AST
        , FunctionDefinition
        , FunctionImplementation(..)
        , Node
        , TypeDefinition
        , TypeMatch(..)
        , TypeMatchCond(..)
        , TypeMatchValue(..)
        )


emptyAst : AST
emptyAst =
    { types = Dict.empty
    , functions = Dict.empty
................................................................................
stripMultiWordBranchLocation ( typeMatch, nodes ) =
    ( stripTypeMatchLocation typeMatch
    , List.map stripNodeLocation nodes
    )


stripTypeMatchLocation : TypeMatch -> TypeMatch
stripTypeMatchLocation (TypeMatch _ type_ otherConds) =
    TypeMatch emptyRange type_ <|
        List.map (mapTypeMatchCondValue stripRecursiveTypeMatchLocation) otherConds



mapTypeMatchCondValue : (TypeMatchValue -> TypeMatchValue) -> TypeMatchCond -> TypeMatchCond
mapTypeMatchCondValue fn (TypeMatchCond name tipe val) =
    TypeMatchCond name tipe (fn val)


stripRecursiveTypeMatchLocation : TypeMatchValue -> TypeMatchValue
stripRecursiveTypeMatchLocation typeMatchValue =
    case typeMatchValue of
        RecursiveMatch typeMatch ->
            RecursiveMatch (stripTypeMatchLocation typeMatch)

        _ ->
            typeMatchValue







>









<
<







 







|
|
|
>

<
|
|
|


|
|
<
<
|
<
<
<
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21


22
23
24
25
26
27
28
...
157
158
159
160
161
162
163
164
165
166
167
168

169
170
171
172
173
174
175


176



    , stripLocations
    )

import Dict
import Expect exposing (Expectation)
import Set
import Stabel.Data.SourceLocation exposing (emptyRange)
import Stabel.Data.Type as Type exposing (Type)
import Stabel.Parser as Parser
import Stabel.Qualifier as AST
    exposing
        ( AST
        , FunctionDefinition
        , FunctionImplementation(..)
        , Node
        , TypeDefinition
        , TypeMatch(..)


        )


emptyAst : AST
emptyAst =
    { types = Dict.empty
    , functions = Dict.empty
................................................................................
stripMultiWordBranchLocation ( typeMatch, nodes ) =
    ( stripTypeMatchLocation typeMatch
    , List.map stripNodeLocation nodes
    )


stripTypeMatchLocation : TypeMatch -> TypeMatch
stripTypeMatchLocation typeMatch =
    case typeMatch of
        TypeMatchInt _ val ->
            TypeMatchInt emptyRange val


        TypeMatchType _ type_ otherConds ->
            TypeMatchType emptyRange type_ <|
                List.map stripTypeMatchCondLocation otherConds


stripTypeMatchCondLocation : ( String, Type, TypeMatch ) -> ( String, Type, TypeMatch )
stripTypeMatchCondLocation ( fieldName, fieldType, match ) =


    ( fieldName, fieldType, stripTypeMatchLocation match )



Modified tests/Test/TypeChecker/Unions.elm from [9955d381cb] to [9a884413e9].

218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
                                , Type.Generic "a"
                                ]
                            , output = [ Type.Generic "a" ]
                            }
                        , sourceLocation = Nothing
                        , implementation =
                            MultiImpl
                                [ ( TypeMatch emptyRange (Type.Generic "a") []
                                  , [ Builtin emptyRange Builtin.StackDrop
                                    ]
                                  )
                                , ( TypeMatch emptyRange (Type.Custom "Nil") []
                                  , [ Builtin emptyRange Builtin.StackSwap
                                    , Builtin emptyRange Builtin.StackDrop
                                    ]
                                  )
                                ]
                                []
                        }







|



|







218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
                                , Type.Generic "a"
                                ]
                            , output = [ Type.Generic "a" ]
                            }
                        , sourceLocation = Nothing
                        , implementation =
                            MultiImpl
                                [ ( TypeMatchType emptyRange (Type.Generic "a") []
                                  , [ Builtin emptyRange Builtin.StackDrop
                                    ]
                                  )
                                , ( TypeMatchType emptyRange (Type.Custom "Nil") []
                                  , [ Builtin emptyRange Builtin.StackSwap
                                    , Builtin emptyRange Builtin.StackDrop
                                    ]
                                  )
                                ]
                                []
                        }