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