Merge pull request #69 from iitalics/pretty-arrow-string

Pretty-print infix types (such as "->") with infix notation

Author: lexi-lambda

hackett-lib/hackett/private/adt.rkt

@@ -30,11 +30,11 @@
   (provide (contract-out [struct type-constructor ([type type?]
                                                    [arity exact-nonnegative-integer?]
                                                    [data-constructors (listof identifier?)]
-                                                   [fixity operator-fixity?])]
+                                                   [fixity (or/c operator-fixity? #f)])]
                          [struct data-constructor ([macro procedure?]
                                                    [type type?]
                                                    [make-match-pat procedure?]
-                                                   [fixity operator-fixity?])])))
+                                                   [fixity (or/c operator-fixity? #f)])])))
 
 (begin-for-syntax
   (define-splicing-syntax-class type-constructor-spec
@@ -472,7 +472,7 @@
    ; quantify the type using the type variables in τ, then evaluate the type
    #:with τ_con:type #'(forall [τ.arg ...] τ_con_unquantified)
    #:with [field ...] (generate-temporaries (attribute constructor.arg))
-   #:with fixity-expr (preservable-property->expression (or (attribute constructor.fixity) 'left))
+   #:with fixity (attribute constructor.fixity)
    #`(begin-
        (define-values- [] τ_con.residual)
        ; check if the constructor is nullary or not
@@ -488,7 +488,7 @@
                     (make-typed-var-transformer #'tag- (quote-syntax τ_con.expansion))
                     (quote-syntax τ_con.expansion)
                     (match-lambda [(list) #'(app force- (==- tag-))])
-                    fixity-expr)))
+                    'fixity)))
              ; if it isn’t, define a constructor function
              #`(splicing-local- [(struct- tag- (field ...) #:transparent
                                           #:reflection-name 'constructor.tag)
@@ -502,21 +502,21 @@
                                      (quote-syntax τ_con.expansion)
                                      (match-lambda [(list field ...)
                                                     #`(app force- (tag- #,field ...))])
-                                     fixity-expr)))))])
+                                     'fixity)))))])
 
 (define-syntax-parser data
   [(_ τ:type-constructor-spec constructor:data-constructor-spec ...
       {~optional
        {~seq #:deriving [{~type {~var class-id (class-id #:require-deriving-transformer? #t)}} ...]}
        #:defaults ([[class-id 1] '()])})
    #:with [τ*:type-constructor-spec] (type-namespace-introduce #'τ)
-   #:with fixity-expr (preservable-property->expression (or (attribute τ.fixity) 'left))
+   #:with fixity (attribute τ.fixity)
    #`(begin-
        (define-syntax- τ*.tag (type-constructor
                                #'(#%type:con τ*.tag)
                                '#,(attribute τ*.len)
                                (list #'constructor.tag ...)
-                               fixity-expr))
+                               'fixity))
        (define-data-constructor τ* constructor) ...
        (derive-instance class-id τ*.tag) ...)])
 

hackett-lib/hackett/private/base.rkt

@@ -15,7 +15,7 @@
          syntax/parse/define
 
          (for-syntax hackett/private/infix
-                     (rename-in hackett/private/typecheck [-> ->/prefix])
+                     hackett/private/typecheck
                      hackett/private/util/list
                      hackett/private/util/stx))
 
@@ -39,8 +39,6 @@
        (syntax-property 'disappeared-use (list (syntax-local-introduce #'op-)
                                                (syntax-local-introduce #'colon))))])
 
-(define-syntax -> (infix-operator-impl #'->/prefix 'right))
-
 (begin-for-syntax
   ;; -------------------------------------------------------------------------------------------------
   ;; inference/checking + erasure/expansion

hackett-lib/hackett/private/infix.rkt

@@ -14,37 +14,46 @@
          syntax/parse/class/local-value)
 
 (provide (contract-out
-          [prop:infix-operator (struct-type-property/c (-> any/c operator-fixity?))]
-          [struct infix-operator-impl ([id identifier?] [fixity operator-fixity?])])
-         operator-fixity? infix-operator? infix-operator-fixity
-         infix-operator fixity-annotation indirect-infix-definition)
+          [prop:infix-operator (struct-type-property/c (-> any/c (or/c operator-fixity? #f)))]
+          [infix-operator-fixity (-> infix-operator? operator-fixity?)]
+          [make-infix-variable-like-transformer
+           (-> (or/c syntax? (-> syntax? syntax?)) (or/c operator-fixity? #f) (-> syntax? syntax?))]
+          [indirect-infix-definition (-> syntax? (or/c operator-fixity? #f) syntax?)])
+         operator-fixity? infix-operator? infix-operator fixity-annotation)
 
 (define operator-fixity?
   (flat-named-contract
    'operator-fixity?
    (or/c 'left 'right)))
 
-(define-values [prop:infix-operator infix-operator? infix-operator-fixity-procedure]
+(define-values [prop:infix-operator has-prop:infix-operator? infix-operator-fixity-procedure]
   (make-struct-type-property 'infix-operator))
 
 (define (infix-operator-fixity operator)
   ((infix-operator-fixity-procedure operator) operator))
+
+(define (infix-operator? x)
+  (and (has-prop:infix-operator? x)
+       (operator-fixity? (infix-operator-fixity x))))
 
-(struct infix-operator-impl (id fixity)
-  #:transparent
-  #:property prop:procedure
-  (λ (operator stx) ((make-variable-like-transformer (infix-operator-impl-id operator)) stx))
+(struct infix-variable-like-transformer (procedure fixity)
+  #:property prop:procedure (struct-field-index procedure)
   #:property prop:infix-operator
-  (λ (operator) (infix-operator-impl-fixity operator)))
+  (λ (operator) (infix-variable-like-transformer-fixity operator)))
+
+(define (make-infix-variable-like-transformer expr fixity)
+  (let ([proc (make-variable-like-transformer expr)])
+    (if fixity (infix-variable-like-transformer proc fixity) proc)))
 
-(define-syntax-class infix-operator
+(define-syntax-class (infix-operator #:default-fixity [default-fixity 'left])
   #:description #f
   #:commit
   #:attributes [fixity]
   [pattern {~var op (local-value infix-operator?)}
            #:attr fixity (infix-operator-fixity (attribute op.local-value))]
   [pattern _:expr
-           #:attr fixity 'left])
+           #:when default-fixity
+           #:attr fixity default-fixity])
 
 (define-splicing-syntax-class fixity-annotation
   #:description "fixity annotation"
@@ -61,10 +70,9 @@
 ;   > (indirect-infix-definition #'(define :: cons) 'right)
 ;   #'(begin
 ;       (define ::1 cons)
-;       (define-syntax :: (infix-operator-impl #'::1 'right)))
+;       (define-syntax :: (infix-variable-like-transformer #'::1 'right)))
 ;
-(define/contract (indirect-infix-definition stx fixity)
-  (-> syntax? (or/c operator-fixity? #f) syntax?)
+(define (indirect-infix-definition stx fixity)
   (if fixity
       (syntax-parse stx
         #:context 'indirect-infix-definition
@@ -73,5 +81,5 @@
          #:with fixity-expr (preservable-property->expression fixity)
          #'(begin
              (d id- expr)
-             (define-syntax id (infix-operator-impl #'id- fixity-expr)))])
+             (define-syntax id (make-infix-variable-like-transformer #'id- fixity-expr)))])
       stx))

hackett-lib/hackett/private/type-language.rkt

@@ -15,6 +15,7 @@
                      syntax/parse/experimental/template
                      threading
 
+                     hackett/private/infix
                      hackett/private/util/stx)
          syntax/parse/define)
 
@@ -307,17 +308,19 @@
                               ({~literal #%type:con} {~literal #,con-id}))
                           pat ...))])))))
 
-(define-simple-macro (define-base-type name:id)
+(define-simple-macro (define-base-type name:id {~optional fixity-ann:fixity-annotation})
   #:with {~var ~name} (format-id #'name "~~~a" #'name #:source #'name #:props #'name)
   ; Ensure that the binding does not have either the type or the value scope on it. Otherwise, if the
   ; type appears in a fully-expanded type or value, and the namespace on the resulting piece of syntax
   ; is flipped, the identifier can become unbound.
   #:with name- (datum->syntax #'here (syntax-e #'name) #'name)
+  #:with fixity (attribute fixity-ann.fixity)
   (begin
-    (define-syntax name- (make-variable-like-transformer
+    (define-syntax name- (make-infix-variable-like-transformer
                           (λ (name-id)
-                            #`(#%type:con #,(replace-stx-loc (quote-syntax name-) name-id)))))
-    (define-syntax name (make-rename-transformer #'name-))
+                            #`(#%type:con #,(replace-stx-loc (quote-syntax name-) name-id)))
+                          'fixity))
+    (define-syntax name (make-rename-transformer (quote-syntax name-)))
     (begin-for-syntax
       (define-syntax ~name (make-type-con-pattern-expander (quote-syntax name))))))
 
@@ -328,7 +331,7 @@
 ; handled specially by the typechecker in order to implement higher-rank polymorphism, so they are
 ; defined here.
 
-(define-base-type ->)
+(define-base-type -> #:fixity right)
 
 (begin-for-syntax
   (define-syntax-class nested-->s

hackett-lib/hackett/private/typecheck.rkt

@@ -21,6 +21,7 @@
          racket/function
          racket/list
          racket/match
+         racket/string
          racket/syntax
          racket/stxparam-exptime
          syntax/id-table
@@ -30,6 +31,7 @@
          syntax/parse/experimental/template
          threading
 
+         hackett/private/infix
          hackett/private/util/list
          hackett/private/util/stx)
 
@@ -111,26 +113,44 @@
 
 (define/contract (type->string t)
   (-> type? string?)
-  (format "~a" (τ->datum t)))
+  (~a (type->datum t)))
 
-(define/contract τ->datum
+(define/contract type->datum
   (-> type? any/c)
   (syntax-parser
-    #:context 'τ->datum
+    #:context 'type->string
     #:literal-sets [type-literals]
     [x:id (syntax-e #'x)]
     [(#%type:wobbly-var x^) (string->symbol (format "~a^" (syntax-e #'x^)))]
     [(#%type:rigid-var x^) (syntax-e #'x^)]
     [(#%type:con name) (syntax-e #'name)]
-    [{~#%type:app+ t ...} (map τ->datum (attribute t))]
+    [{~#%type:app+ (#%type:con {~var op (infix-operator #:default-fixity #f)}) _ _}
+     (infix-type->string #'op (attribute op.fixity) this-syntax)]
+    [{~#%type:app+ t ...} (map type->datum (attribute t))]
     [{~#%type:forall* [x ...+] {~#%type:qual* [constr ...+] t}}
      `(forall ,(map syntax-e (attribute x))
-              ,@(map τ->datum (attribute constr))
-              => ,(τ->datum #'t))]
+              ,@(map type->datum (attribute constr))
+              => ,(type->datum #'t))]
     [{~#%type:forall* [x ...+] t}
-     `(forall ,(map syntax-e (attribute x)) ,(τ->datum #'t))]
+     `(forall ,(map syntax-e (attribute x)) ,(type->datum #'t))]
     [{~#%type:qual* [constr ...+] t}
-     `(=> ,(map τ->datum (attribute constr)) ,(τ->datum #'t))]))
+     `(=> ,(map type->datum (attribute constr)) ,(type->datum #'t))]))
+
+(define/contract (infix-type->string op-id fixity t0)
+  (-> identifier? operator-fixity? type? string?)
+  (define traverse
+    (syntax-parser
+      #:literal-sets [type-literals]
+      [{~#%type:app* (#%type:con op) t s}
+       #:when (free-identifier=? #'op op-id)
+       (case fixity
+         [(left)  (snoc (traverse #'t) #'s)]
+         [(right) (cons #'t (traverse #'s))])]
+      [t (list #'t)]))
+  (string-join (map type->string (traverse t0))
+               (format " ~a " (syntax-e op-id))
+               #:before-first "{"
+               #:after-last "}"))
 
 ;; ---------------------------------------------------------------------------------------------------
 ;; type contexts