1module TypeSignature exposing (Signature, parseSignature, showSignature, normalizeSignature, functionCompatibility, curry1, curry1Flip, sigIsArrow)
2
3{-| This module provides the possibility to parse Haskell and Elm type signatures.
4-}
5
6import Combine as C
7import Combine.Char as CC
8import Combine.Num as CN
9import Char
10import Debug
11import Dict
12import Tuple exposing (first)
13import List exposing ((::))
14import List.Extra exposing (permutations, subsequences)
15import Maybe
16import Result
17import String
18
19
20type Signature
21    = Arrow Signature Signature
22    | ListType Signature
23      -- A Tuple with an empty List is the unit type.
24    | Tuple (List Signature)
25    | TypeConstructor String
26    | TypeApplication Signature Signature
27    | VariableType String
28
29
30showSignature : Bool -> Signature -> String
31showSignature charListAsString =
32    showSignatureHelper charListAsString False False
33
34
35splitLast : List a -> ( List a, a )
36splitLast xs =
37    case List.reverse xs of
38        y :: ys ->
39            ( List.reverse ys, y )
40
41        _ ->
42            "Error splitLast"
43                |> Debug.todo
44
45
46curry1 : Signature -> Signature
47curry1 sig =
48    case sig of
49        Arrow (Tuple []) ret ->
50            "Error curry1 (empty tuple): "
51                ++ showSignature True sig
52                |> Debug.todo
53
54        Arrow (Tuple params) ret ->
55            let
56                ( ps, x ) =
57                    splitLast params
58            in
59                case ps of
60                    [p] -> Arrow p (Arrow x ret)
61                    _ -> Arrow (Tuple ps) (Arrow x ret)
62
63        Arrow sig2 ret ->
64            Arrow (Tuple []) (Arrow sig2 ret)
65
66        _ ->
67            "Error curry1: "
68                ++ showSignature True sig
69                |> Debug.todo
70
71curry1Flip : Signature -> Signature
72curry1Flip sig =
73    case (sig |> curry1) of
74        Arrow a (Arrow b ret) ->
75            Arrow b (Arrow a ret)
76        _ ->
77            "Error curry1Flip: "
78                ++ showSignature True sig
79                |> Debug.todo
80
81mapS : (s -> String -> ( s, String )) -> s -> List Signature -> ( List Signature, s )
82mapS f s =
83    let
84        go sig ( sigs, s2 ) =
85            let
86                ( sig_, s_ ) =
87                    mapLRS f s2 sig
88            in
89                ( sig_ :: sigs, s_ )
90    in
91        List.foldl go ( [], s ) >> \( xs, s2 ) -> ( List.reverse xs, s2 )
92
93
94
95{- http://stackoverflow.com/a/37455356/1866775 -}
96
97
98mapLRS : (s -> String -> ( s, String )) -> s -> Signature -> ( Signature, s )
99mapLRS f s sig =
100    case sig of
101        Arrow a b ->
102            let
103                ( a_, s_ ) =
104                    mapLRS f s a
105
106                ( b_, s__ ) =
107                    mapLRS f s_ b
108            in
109                ( Arrow a_ b_, s__ )
110
111        TypeConstructor x ->
112            ( TypeConstructor x, s )
113
114        VariableType x ->
115            let
116                ( s_, x_ ) =
117                    f s x
118            in
119                ( VariableType x_, s_ )
120
121        TypeApplication a b ->
122            let
123                ( a_, s_ ) =
124                    mapLRS f s a
125
126                ( b_, s__ ) =
127                    mapLRS f s_ b
128            in
129                ( TypeApplication a_ b_, s__ )
130
131        ListType x ->
132            let
133                ( x_, s_ ) =
134                    mapLRS f s x
135            in
136                ( ListType x_, s_ )
137
138        Tuple xs ->
139            let
140                ( xs_, s_ ) =
141                    mapS f s xs
142            in
143                ( Tuple xs_, s_ )
144
145
146nthVarName : Int -> String
147nthVarName i =
148    let
149        charPart =
150            97 + (remainderBy 26 i) |> Char.fromCode |> String.fromChar
151
152        addNumber =
153            i // 26
154
155        numStr =
156            if addNumber == 0 then
157                ""
158            else
159                String.fromInt addNumber
160    in
161        charPart ++ numStr
162
163
164
165{- Asserts varNames being generated by the same functions. -}
166
167
168nextFreeVarName : List String -> String
169nextFreeVarName varNames =
170    nthVarName (List.length varNames)
171
172
173normalizeSignatureGo :
174    Dict.Dict String String
175    -> String
176    -> ( Dict.Dict String String, String )
177normalizeSignatureGo dict str =
178    let
179        nextFree =
180            nextFreeVarName (Dict.keys dict)
181
182        str_ =
183            Dict.get str dict |> Maybe.withDefault nextFree
184    in
185        ( Dict.insert str str_ dict, str_ )
186
187
188normalizeSignature : Signature -> Signature
189normalizeSignature =
190    mapLRS normalizeSignatureGo Dict.empty >> first
191
192
193
194--mapLRS (\s -> ( s + 1, s |> Char.fromCode |> String.fromChar )) 97 >> first
195
196
197addParenthesis : String -> String
198addParenthesis x =
199    "(" ++ x ++ ")"
200
201
202showSignatureHelper : Bool -> Bool -> Bool -> Signature -> String
203showSignatureHelper charListAsString arrowsInParens typeAppInParens sig =
204    let
205        optArrowParens =
206            if arrowsInParens then
207                addParenthesis
208            else
209                identity
210
211        optTypeApplicationParens =
212            if typeAppInParens then
213                addParenthesis
214            else
215                identity
216    in
217        case sig of
218            Arrow a b ->
219                showSignatureHelper charListAsString True False a
220                    ++ " -> "
221                    ++ showSignatureHelper charListAsString False False b
222                    |> optArrowParens
223
224            TypeConstructor x ->
225                x
226
227            VariableType x ->
228                x
229
230            TypeApplication a b ->
231                showSignatureHelper charListAsString False False a
232                    ++ " "
233                    ++ showSignatureHelper charListAsString True True b
234                    |> optTypeApplicationParens
235
236            ListType (TypeConstructor "Char") ->
237                if charListAsString then
238                    "String"
239                else
240                    "[Char]"
241
242            ListType x ->
243                "[" ++ showSignatureHelper charListAsString False False x ++ "]"
244
245            Tuple xs ->
246                String.join ", "
247                    (List.map (showSignatureHelper charListAsString False False) xs)
248                    |> addParenthesis
249
250
251listParser : C.Parser s Signature
252listParser =
253    C.brackets (C.lazy <| \() -> signatureParser)
254        |> C.map ListType
255
256
257trimSpaces : C.Parser s a -> C.Parser s a
258trimSpaces =
259    let
260        skipSpaces =
261            C.skipMany <| C.choice [ CC.space, CC.tab ]
262    in
263        C.between skipSpaces skipSpaces
264
265
266tupleParser : C.Parser s Signature
267tupleParser =
268    let
269        innerParser =
270            C.sepBy (trimSpaces <| CC.char ',')
271                (C.lazy <| \() -> signatureParser)
272                |> C.map simplify
273
274        simplify xs =
275            case xs of
276                [ x ] ->
277                    x
278
279                _ ->
280                    Tuple xs
281    in
282        trimSpaces innerParser
283            |> C.parens
284
285
286arrowParser : C.Parser s Signature
287arrowParser =
288    let
289        arrowOp =
290            C.onsuccess Arrow (trimSpaces (C.string "->"))
291    in
292        C.chainr arrowOp (C.lazy <| \() -> nonAppSignatureParser)
293
294
295isValidTypeApplication : Signature -> Bool
296isValidTypeApplication sig =
297    case sig of
298        TypeConstructor _ ->
299            True
300
301        TypeApplication a b ->
302            isValidTypeApplication a
303
304        _ ->
305            False
306
307
308typeApplicationParser : C.Parser s Signature
309typeApplicationParser =
310    let
311        typeApplyOp =
312            C.onsuccess TypeApplication (C.many1 CC.space)
313
314        validate ta =
315            if isValidTypeApplication ta then
316                C.succeed ta
317            else
318                C.fail "invalid type application"
319    in
320        C.andThen validate
321            (C.chainl typeApplyOp (C.lazy <| \() -> nonOpSignatureParser))
322
323
324
325typeStartsWithParser : C.Parser s Char -> (String -> Signature) -> C.Parser s Signature
326typeStartsWithParser p tagger =
327    [ p |> C.map (\x -> [ x ])
328    , C.many <| C.choice [ CC.lower, CC.upper, CC.char '.', CC.char '_', CC.digit ]
329    ]
330        |> C.sequence
331        |> C.map List.concat
332        |> C.map (String.fromList >> tagger)
333
334
335variableTypeParser : C.Parser s Signature
336variableTypeParser =
337    typeStartsWithParser CC.lower VariableType
338
339
340stringToListChar : Signature -> Signature
341stringToListChar sig =
342    case sig of
343        TypeConstructor "String" ->
344            ListType (TypeConstructor "Char")
345
346        _ ->
347            sig
348
349
350fixedTypeParser : C.Parser s Signature
351fixedTypeParser =
352    typeStartsWithParser CC.upper TypeConstructor |> C.map stringToListChar
353
354
355nonOpSignatureParser : C.Parser s Signature
356nonOpSignatureParser =
357    C.choice
358        [ C.lazy <| \() -> listParser
359        , C.lazy <| \() -> tupleParser
360        , variableTypeParser
361        , fixedTypeParser
362        ]
363
364
365nonAppSignatureParser : C.Parser s Signature
366nonAppSignatureParser =
367    C.choice
368        [ C.lazy <| \() -> typeApplicationParser
369        , C.lazy <| \() -> nonOpSignatureParser
370        ]
371
372
373signatureParser : C.Parser s Signature
374signatureParser =
375    C.choice
376        [ C.lazy <| \() -> arrowParser
377        , nonAppSignatureParser
378        ]
379        |> trimSpaces
380
381
382parseSignature : String -> Maybe Signature
383parseSignature inputData =
384    case C.parse signatureParser inputData of
385        Ok (state, { input }, result) ->
386            if String.isEmpty input then
387                Maybe.Just result
388            else
389                Maybe.Nothing
390
391        Err (state, stream, errors) ->
392            Maybe.Nothing
393
394
395equalityToFloat : Float -> Float -> a -> a -> Float
396equalityToFloat valueTrue valueFalse x y =
397    if x == y then
398        valueTrue
399    else
400        valueFalse
401
402
403sigIsArrow : Signature -> Bool
404sigIsArrow sig =
405    case sig of
406        Arrow _ _ ->
407            True
408
409        _ ->
410            False
411
412
413functionCompatibility : Signature -> Signature -> Float
414functionCompatibility db query =
415    case ( db, query ) of
416        ( VariableType _, TypeConstructor _ ) ->
417            0.95
418
419        ( VariableType _, ListType _ ) ->
420            0.8
421
422        ( TypeApplication (TypeConstructor "Maybe") (VariableType x), VariableType y ) ->
423            0.8 * equalityToFloat 1.0 0.0 x y
424
425        ( TypeApplication (TypeConstructor "Maybe") (TypeConstructor x), TypeConstructor y ) ->
426            0.8 * equalityToFloat 1.0 0.0 x y
427
428        ( Arrow a b, Arrow x y ) ->
429            functionCompatibility a x * functionCompatibility b y
430
431        ( TypeConstructor x, TypeConstructor y ) ->
432            equalityToFloat 1.0 0.0 x y
433
434        ( VariableType x, VariableType y ) ->
435            equalityToFloat 1.0 0.85 x y
436
437        ( TypeApplication a b, TypeApplication x y ) ->
438            functionCompatibility a x * functionCompatibility b y
439
440        ( ListType a, ListType x ) ->
441            functionCompatibility a x
442
443        ( Tuple xs, Tuple ys ) ->
444            if List.length xs > List.length ys then
445                List.map
446                    (\xs_ ->
447                        List.map2 functionCompatibility xs_ ys
448                            |> List.product
449                            |> (\x ->
450                                    x
451                                        * toFloat (List.length ys)
452                                        / toFloat (List.length xs)
453                               )
454                    )
455                    (subsequences xs)
456                    |> List.maximum
457                    |> Maybe.withDefault 0
458            else if List.length xs == List.length ys then
459                List.map
460                    (\ys_ ->
461                        List.map2 functionCompatibility xs ys_
462                            |> List.product
463                    )
464                    (permutations ys)
465                    |> List.maximum
466                    |> Maybe.withDefault 0
467            else
468                0
469
470        ( Tuple xs, y ) ->
471            List.map
472                (\x ->
473                    functionCompatibility x y
474                        / toFloat (List.length xs)
475                )
476                xs
477                |> List.maximum
478                |> Maybe.withDefault 0
479
480        _ ->
481            0
482