1(* 2 Copyright (c) 2013 David C.J. Matthews 3 4 This library is free software; you can redistribute it and/or 5 modify it under the terms of the GNU Lesser General Public 6 License as published by the Free Software Foundation; either 7 version 2.1 of the License, or (at your option) any later version. 8 9 This library is distributed in the hope that it will be useful, 10 but WITHOUT ANY WARRANTY; without even the implied warranty of 11 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 12 Lesser General Public License for more details. 13 14 You should have received a copy of the GNU Lesser General Public 15 License along with this library; if not, write to the Free Software 16 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 17*) 18 19(* 20 Derived from the original parse-tree 21 22 Copyright (c) 2000 23 Cambridge University Technical Services Limited 24 25 Further development: 26 Copyright (c) 2000-13 David C.J. Matthews 27 28 Title: Parse Tree Structure and Operations. 29 Author: Dave Matthews, Cambridge University Computer Laboratory 30 Copyright Cambridge University 1985 31 32*) 33 34functor PRINT_PARSETREE ( 35 36 structure BASEPARSETREE : BaseParseTreeSig 37 structure LEX : LEXSIG 38 structure STRUCTVALS : STRUCTVALSIG; 39 structure TYPETREE : TYPETREESIG 40 structure VALUEOPS : VALUEOPSSIG; 41 structure PRETTY : PRETTYSIG 42 43 sharing LEX.Sharing = TYPETREE.Sharing = STRUCTVALS.Sharing 44 = VALUEOPS.Sharing = PRETTY.Sharing 45 = BASEPARSETREE.Sharing 46 47): PrintParsetreeSig 48= 49struct 50 open LEX 51 open STRUCTVALS 52 open VALUEOPS 53 open TYPETREE 54 open PRETTY 55 open BASEPARSETREE 56 57 fun isEmptyTree EmptyTree = true | isEmptyTree _ = false; 58 59 (* This pretty printer is used to format the parsetree 60 for error messages (Error near ...) and also for 61 debugging. There is a quite different pretty printer 62 in VALUEOPS that is used to format values produced as 63 a result of compiling and executing an expression or 64 declaration. *) 65 66 fun printList (doPrint: 'a*FixedInt.int->pretty) (c: 'a list, separator, depth: FixedInt.int): pretty list = 67 if depth <= 0 then [PrettyString "..."] 68 else 69 case c of 70 [] => [] 71 | [v] => [doPrint (v, depth)] 72 | (v::vs) => 73 PrettyBlock (0, false, [], 74 [ 75 doPrint (v, depth), 76 PrettyBreak 77 (if separator = "," orelse separator = ";" orelse separator = "" then 0 else 1, 0), 78 PrettyString separator 79 ] 80 ) :: 81 PrettyBreak (1, 0) :: 82 printList doPrint (vs, separator, depth - 1) 83 84 (* Generates a pretty-printed representation of a piece of tree. *) 85 fun displayParsetree (c : parsetree, (* The value to print. *) 86 depth : FixedInt.int) : pretty = (* The number of levels to display. *) 87 let 88 val displayList = printList displayParsetree 89 and displayListWithBpts = printList (fn ((c,_), depth) => displayParsetree(c, depth)) 90 91 (* type bindings and datatype bindings are used in several cases *) 92 fun printTypeBind (TypeBind{name, typeVars, decType, ...}, depth) = 93 PrettyBlock (3, true, [], 94 displayTypeVariables (typeVars, depth) @ 95 ( 96 PrettyString name :: 97 (* The type may be missing if this is a signature. *) 98 (case decType of 99 NONE => [] 100 | SOME t => 101 [ 102 PrettyBreak (1, 0), 103 PrettyString "=", 104 PrettyBreak (1, 0), 105 displayTypeParse (t, depth, emptyTypeEnv) 106 ] 107 ) 108 ) 109 ) 110 111 and printDatatypeBind (DatatypeBind{name, typeVars, constrs, ...}, depth) = 112 PrettyBlock (3, true, [], 113 displayTypeVariables (typeVars, depth) @ 114 ( 115 PrettyString name :: 116 PrettyBreak (1, 0) :: 117 PrettyString "=" :: 118 PrettyBreak (1, 0) :: 119 printList printConstructor (constrs, "|", depth - 1) 120 ) 121 ) 122 123 and printConstructor ({constrName, constrArg, ...}, depth) = 124 PrettyBlock (2, false, [], 125 PrettyString constrName :: 126 ( 127 case constrArg of 128 NONE => [] 129 | SOME argType => 130 [ 131 PrettyBreak (1, 0), 132 PrettyString "of", 133 PrettyBreak (1, 0), 134 displayTypeParse (argType, depth, emptyTypeEnv) 135 ] 136 ) 137 ) 138 139 in 140 if depth <= 0 (* elide further text. *) 141 then PrettyString "..." 142 143 else case c of 144 145 Ident {name, ...} => 146 PrettyString name 147 148 | Literal{literal, converter, ...} => 149 let 150 val convName = valName converter 151 val lit = 152 if convName = "convString" 153 then concat["\"" , literal, "\""] 154 else if convName = "convChar" 155 then concat["#\"" , literal, "\""] 156 else literal 157 in 158 PrettyString lit 159 end 160 161 | Applic { f, arg = TupleTree{fields=[left, right], ...}, isInfix = true, ...} => 162 (* Infixed application. *) 163 PrettyBlock (0, false, [], 164 [ 165 displayParsetree (left, depth - 1), 166 PrettyBreak (1, 0), 167 displayParsetree (f, depth), (* Just an identifier. *) 168 PrettyBreak (1, 0), 169 displayParsetree (right, depth - 1) 170 ] 171 ) 172 173 | Applic {f, arg, ...} => (* Function application. *) 174 PrettyBlock (0, false, [], 175 [ 176 displayParsetree (f, depth - 1), 177 PrettyBreak (1, 0), 178 displayParsetree (arg, depth - 1) 179 ] 180 ) 181 182 | Cond {test, thenpt, elsept, ...} => (* if..then..else.. *) 183 PrettyBlock (0, false, [], 184 [ 185 PrettyString "if", 186 PrettyBreak (1, 0), 187 displayParsetree (test, depth - 1), 188 PrettyBreak (1, 0), 189 PrettyString "then", 190 PrettyBreak (1, 0), 191 displayParsetree (thenpt, depth - 1), 192 PrettyBreak (1, 0), 193 PrettyString "else", 194 PrettyBreak (1, 0), 195 displayParsetree (elsept, depth - 1) 196 ] 197 ) 198 199 | TupleTree{fields, ...} => 200 PrettyBlock (3, true, [], 201 ( 202 PrettyString "(" :: 203 PrettyBreak (0, 0) :: 204 displayList (fields, ",", depth - 1) 205 ) @ [PrettyBreak (0, 0), PrettyString ")"] 206 ) 207 208 | ValDeclaration {dec, ...} => 209 let 210 (* We can't use printList here because we don't want an 211 "and" after a "rec". *) 212 fun printValBind ([], _) = [] 213 214 | printValBind (ValBind{dec, exp, isRecursive, ...} :: rest, depth) = 215 if depth <= 0 216 then [PrettyString "..."] 217 else 218 let 219 val isRec = 220 if isRecursive then [PrettyString "rec" , PrettyBreak (1, 0)] else [] 221 val pValBind = 222 PrettyBlock (3, false, [], 223 [ 224 displayParsetree (dec, depth - 1), 225 PrettyBreak (1, 0), 226 PrettyString "=", 227 PrettyBreak (1, 0), 228 displayParsetree (exp, depth - 1) 229 ] 230 ) 231 in 232 case rest of 233 [] => isRec @ [pValBind] 234 | _ => PrettyBlock (0, false, [], isRec @ [pValBind, PrettyBreak(1, 0), PrettyString "and"]) :: 235 PrettyBreak(1, 0) :: printValBind(rest, depth-1) 236 end 237 in 238 PrettyBlock (3, true, [], 239 PrettyString "val" :: 240 PrettyBreak (1, 0) :: 241 (* TODO: Display the explicit type variables. *) 242 (* displayTypeVariables (explicit, depth); *) 243 printValBind (dec, depth - 1) 244 ) 245 end 246 247 | FunDeclaration {dec, ...} => 248 let 249 fun printfvalbind (FValBind{clauses, ...}, depth) = 250 PrettyBlock(3, true, [], printList printClause (clauses, "|", depth - 1)) 251 and printClause (FValClause{dec, exp, ...}, depth) = 252 PrettyBlock (3, true, [], 253 [ 254 printDec (dec, depth - 1), 255 PrettyBreak (1, 0), 256 PrettyString "=", 257 PrettyBreak (1, 0), 258 displayParsetree (exp, depth - 1) 259 ] 260 ) 261 and printDec( 262 { ident = { name, ... }, isInfix=true, args=[TupleTree{fields=[left, right], ...}], constraint }, depth) = 263 (* Single infixed application. *) 264 PrettyBlock (0, false, [], 265 [ 266 displayParsetree (left, depth - 1), 267 PrettyBreak (1, 0), 268 PrettyString name, 269 PrettyBreak (1, 0), 270 displayParsetree (right, depth - 1) 271 ] @ printConstraint (constraint, depth-1) 272 ) 273 | printDec( 274 { ident = { name, ... }, isInfix=true, 275 args=TupleTree{fields=[left, right], ...} :: args, constraint }, depth) = 276 (* Infixed application followed by other arguments. *) 277 PrettyBlock (0, false, [], 278 [ 279 PrettyString "(", 280 PrettyBreak (0, 0), 281 displayParsetree (left, depth - 1), 282 PrettyBreak (1, 0), 283 PrettyString name, 284 PrettyBreak (1, 0), 285 displayParsetree (right, depth - 1), 286 PrettyBreak (0, 0), 287 PrettyString ")" 288 ] @ displayList (args, "", depth - 1) @ printConstraint(constraint, depth-2) 289 ) 290 | printDec({ ident = { name, ...}, args, constraint, ... }, depth) = 291 (* Prefixed application. *) 292 PrettyBlock (0, false, [], 293 [ PrettyString name, PrettyBreak (1, 0) ] @ 294 displayList (args, "", depth - 1) @ printConstraint(constraint, depth-2) 295 ) 296 and printConstraint(NONE, _) = [] 297 | printConstraint(SOME given, depth) = 298 [ 299 PrettyBreak (1, 0), 300 PrettyString ":", 301 PrettyBreak (1, 0), 302 displayTypeParse (given, depth, emptyTypeEnv) 303 ] 304 in 305 PrettyBlock (3, true, [], 306 PrettyString "fun" :: 307 PrettyBreak (1, 0) :: 308 (* TODO: Display the explicit type variables. *) 309 (* displayTypeVariables (explicit, depth); *) 310 printList printfvalbind (dec, "and", depth - 1) 311 ) 312 end 313 314 | OpenDec {decs, ...} => 315 let 316 fun printStrName ({name, ...}: structureIdentForm, _) = PrettyString name 317 in 318 PrettyBlock (3, true, [], 319 PrettyString "open" :: 320 PrettyBreak (1, 0) :: 321 printList printStrName (decs, "", depth - 1) 322 ) 323 end 324 325 | List {elements, ...} => 326 PrettyBlock (3, true, [], 327 PrettyString "[" :: 328 PrettyBreak (0, 0) :: 329 displayList (elements, ",", depth - 1) @ 330 [PrettyBreak (0, 0), PrettyString "]" ] 331 ) 332 333 | Constraint {value, given, ...} => 334 PrettyBlock (3, false, [], 335 [ 336 displayParsetree (value, depth - 1), 337 PrettyBreak (1, 0), 338 PrettyString ":", 339 PrettyBreak (1, 0), 340 displayTypeParse (given, depth, emptyTypeEnv) 341 ] 342 ) 343 344 | Layered {var, pattern, ...} => 345 PrettyBlock (3, true, [], 346 [ 347 displayParsetree (var, depth - 1), 348 PrettyBreak (1, 0), 349 PrettyString "as", 350 PrettyBreak (1, 0), 351 displayParsetree (pattern, depth - 1) 352 ] 353 ) 354 355 | Fn {matches, ...} => 356 PrettyBlock (3, true, [], 357 PrettyString "fn" :: 358 PrettyBreak (1, 0) :: 359 printList displayMatch (matches, "|", depth - 1) 360 ) 361 362 | Unit _ => 363 PrettyString "()" 364 365 | WildCard _ => 366 PrettyString "_" 367 368 | Localdec {isLocal, decs, body, ...} => 369 PrettyBlock (3, false, [], 370 PrettyString (if isLocal then "local" else "let") :: 371 PrettyBreak (1, 0) :: 372 displayListWithBpts (decs, ";", depth - 1) @ 373 [PrettyBreak (1, 0), PrettyString "in", PrettyBreak (1, 0)] @ 374 displayListWithBpts (body, ";", depth - 1) @ 375 [PrettyBreak (1, 0), PrettyString "end"] 376 ) 377 378 | TypeDeclaration(ptl, _) => 379 let 380 (* This is used both for type bindings and also in signatures. 381 In a signature we may have "eqtype". *) 382 val typeString = 383 case ptl of 384 TypeBind {isEqtype=true, ...} :: _ => "eqtype" 385 | _ => "type" 386 in 387 PrettyBlock (3, true, [], 388 PrettyString typeString :: 389 PrettyBreak (1, 0) :: 390 printList printTypeBind (ptl, "and", depth - 1) 391 ) 392 end 393 394 | AbsDatatypeDeclaration {typelist, withtypes, isAbsType=false, ...} => 395 PrettyBlock (3, true, [], 396 PrettyString "datatype" :: 397 PrettyBreak (1, 0) :: 398 printList printDatatypeBind (typelist, "and", depth - 1) @ 399 ( 400 if null withtypes then [] 401 else 402 PrettyBreak (1, 0) :: 403 PrettyString "withtype" :: 404 PrettyBreak (1, 0) :: 405 printList printTypeBind (withtypes, "and", depth - 1) 406 ) 407 ) 408 409 | DatatypeReplication {newType, oldType, ...} => 410 PrettyBlock (3, true, [], 411 [ 412 PrettyString "datatype", 413 PrettyBreak (1, 0), 414 PrettyString newType, 415 PrettyBreak (1, 0), 416 PrettyString "=", 417 PrettyBreak (1, 0), 418 PrettyString "datatype", 419 PrettyBreak (1, 0), 420 PrettyString oldType 421 ] 422 ) 423 424 | AbsDatatypeDeclaration {typelist, withtypes, declist, isAbsType=true, ...} => 425 PrettyBlock (3, true, [], 426 PrettyString "abstype" :: 427 PrettyBreak (1, 0) :: 428 printList printDatatypeBind (typelist, "and", depth - 1) @ 429 [ PrettyBreak (1, 0) ] @ 430 ( 431 if null withtypes then [] 432 else 433 PrettyString "withtype" :: 434 PrettyBreak (1, 0) :: 435 printList printTypeBind (withtypes, "and", depth - 1) @ 436 [PrettyBreak (1, 0)] 437 ) @ 438 [ 439 PrettyString "with", 440 PrettyBreak (1, 0), 441 PrettyBlock (3, true, [], 442 displayListWithBpts(declist, ";", depth - 1)) 443 ] 444 ) 445 446 447 | ExpSeq(ptl, _) => 448 PrettyBlock (3, true, [], 449 PrettyString "(" :: 450 PrettyBreak (0, 0) :: 451 displayListWithBpts (ptl, ";", depth - 1) @ 452 [ PrettyBreak (0, 0), PrettyString ")"] 453 ) 454 455 | Directive {fix, tlist, ...} => 456 let 457 val status = 458 case fix of 459 Nonfix => PrettyString "nonfix" 460 | Infix prec => 461 PrettyBlock(0, false, [], 462 [ PrettyString "infix", PrettyBreak (1, 0), PrettyString (Int.toString prec) ]) 463 | InfixR prec => 464 PrettyBlock(0, false, [], 465 [ PrettyString "infixr", PrettyBreak (1, 0), PrettyString (Int.toString prec) ]) 466 in 467 PrettyBlock (3, true, [], 468 status :: 469 PrettyBreak (1, 0) :: 470 printList (fn (name, _) => PrettyString name) (tlist, "", depth - 1) 471 ) 472 end 473 474 | ExDeclaration(pt, _) => 475 let 476 fun printExBind (ExBind {name, ofType, previous, ...}, depth) = 477 PrettyBlock (0, false, [], 478 PrettyString name :: 479 (case ofType of NONE => [] 480 | SOME typeof => 481 [ 482 PrettyBreak (1, 0), 483 PrettyString "of", 484 PrettyBreak (1, 0), 485 displayTypeParse (typeof, depth, emptyTypeEnv) 486 ] 487 ) @ 488 (if isEmptyTree previous then [] 489 else 490 [ 491 PrettyBreak (1, 0), 492 PrettyString "=", 493 PrettyBreak (1, 0), 494 displayParsetree (previous, depth - 1) 495 ]) 496 ) 497 in 498 PrettyBlock (3, true, [], 499 PrettyString "exception" :: 500 PrettyBreak (1, 0) :: 501 printList printExBind (pt, "and", depth - 1) 502 ) 503 end 504 505 | Raise (pt, _) => 506 PrettyBlock (0, false, [], 507 [ 508 PrettyString "raise", 509 PrettyBreak (1, 0), 510 displayParsetree (pt, depth - 1) 511 ] 512 ) 513 514 | HandleTree {exp, hrules, ...} => 515 PrettyBlock (0, false, [], 516 [ 517 displayParsetree (exp, depth - 1), 518 PrettyBreak (1, 0), 519 PrettyBlock (3, true, [], 520 PrettyString "handle" :: 521 PrettyBreak (1, 0) :: 522 printList displayMatch (hrules, "|", depth - 1) 523 ) 524 ] 525 ) 526 527 | While {test, body, ...} => 528 PrettyBlock (0, false, [], 529 [ 530 PrettyString "while", 531 PrettyBreak (1, 0), 532 displayParsetree (test, depth - 1), 533 PrettyBreak (1, 0), 534 PrettyString "do", 535 PrettyBreak (1, 0), 536 displayParsetree (body, depth - 1) 537 ] 538 ) 539 540 | Case {test, match, ...} => 541 PrettyBlock (3, true, [], 542 PrettyBlock (0, false, [], 543 [ 544 PrettyString "case", 545 PrettyBreak (1, 0), 546 displayParsetree (test, depth - 1), 547 PrettyBreak (1, 0), 548 PrettyString "of" 549 ] 550 ) :: 551 PrettyBreak (1, 0) :: 552 printList displayMatch (match, "|", depth - 1) 553 ) 554 555 | Andalso {first, second, ...} => 556 PrettyBlock (3, true, [], 557 [ 558 displayParsetree (first, depth - 1), 559 PrettyBreak (1, 0), 560 PrettyString "andalso", 561 PrettyBreak (1, 0), 562 displayParsetree (second, depth - 1) 563 ] 564 ) 565 566 | Orelse {first, second, ...} => 567 PrettyBlock (3, true, [], 568 [ 569 displayParsetree (first, depth - 1), 570 PrettyBreak (1, 0), 571 PrettyString "orelse", 572 PrettyBreak (1, 0), 573 displayParsetree (second, depth - 1) 574 ] 575 ) 576 577 | Labelled {recList, frozen, ...} => 578 let 579 fun displayRecList (c, depth): pretty list = 580 if depth <= 0 then [PrettyString "..."] 581 else 582 case c of 583 [] => [] 584 | [{name, valOrPat, ...}] => 585 [ 586 PrettyBlock (0, false, [], 587 [ 588 PrettyString (name ^ " ="), 589 PrettyBreak (1, 0), 590 displayParsetree (valOrPat, depth - 1) 591 ] 592 ) 593 ] 594 | ({name, valOrPat, ...}::vs) => 595 PrettyBlock (0, false, [], 596 [ 597 PrettyBlock (0, false, [], 598 [ 599 PrettyString (name ^ " ="), 600 PrettyBreak (1, 0), 601 displayParsetree (valOrPat, depth - 1) 602 ] 603 ), 604 PrettyBreak (0, 0), 605 PrettyString "," 606 ] 607 ) :: 608 PrettyBreak (1, 0) :: 609 displayRecList (vs, depth - 1) 610 (* end displayRecList *) 611 in 612 PrettyBlock (2, false, [], 613 PrettyString "{" :: 614 displayRecList (recList, depth - 1) @ 615 (if frozen then [PrettyString "}"] 616 else [PrettyString (if null recList then "...}" else ", ...}")]) 617 ) 618 end 619 620 | Selector {name, ...} => 621 PrettyString ("#" ^ name) 622 623 | EmptyTree => 624 PrettyString "<Empty>" 625 626 | Parenthesised(p, _) => 627 PrettyBlock(0, false, [], 628 [ 629 PrettyString "(", 630 PrettyBreak (0, 0), 631 displayParsetree (p, depth), 632 PrettyBreak (0, 0), 633 PrettyString ")" 634 ] 635 ) 636 637 end (* displayParsetree *) 638 639 and displayMatch(MatchTree {vars, exp, ...}, depth) = 640 PrettyBlock (0, false, [], 641 [ 642 displayParsetree (vars, depth - 1), 643 PrettyBreak (1, 0), 644 PrettyString "=>", 645 PrettyBreak (1, 0), 646 displayParsetree (exp, depth - 1) 647 ] 648 ) 649 650 (* Error message routine. Used in both pass 2 and pass 3. *) 651 fun errorNear (lex, hard, near, line, message) = 652 let 653 val errorDepth = errorDepth lex 654 in 655 (* Puts out an error message and then prints the piece of tree. *) 656 reportError lex 657 { 658 hard = hard, 659 location = line, 660 message = PrettyBlock (0, false, [], [PrettyString message]), 661 context = SOME(displayParsetree (near, errorDepth)) 662 } 663 end 664 665 (* Types that can be shared. *) 666 structure Sharing = 667 struct 668 type lexan = lexan 669 and parsetree = parsetree 670 and matchtree = matchtree 671 and pretty = pretty 672 end 673 674end; 675 676