Skip to content

Commit

Permalink
When elaborating dictionaries with subgoals, curry the application
Browse files Browse the repository at this point in the history
fixes #36
  • Loading branch information
lexi-lambda committed Aug 31, 2017
1 parent 52ec4c9 commit b300a30
Show file tree
Hide file tree
Showing 5 changed files with 75 additions and 16 deletions.
27 changes: 14 additions & 13 deletions hackett-lib/hackett/private/base.rkt
Original file line number Diff line number Diff line change
Expand Up @@ -289,19 +289,20 @@
[(dict-expr) (class:instance-dict-expr instance)])
; It’s possible that the dictionary itself requires dictionaries for classes with
; subgoals, like (instance ∀ [a] [(Show a)] => (Show (List a)) ...). If there are not
; any constraints, we should just produce a bare identifier. Otherwise, we should
; produce an application to sub-dictionaries, which need to be recursively elaborated.
(if (empty? constrs)
(make-variable-like-transformer dict-expr)
(make-variable-like-transformer
(elaborate-dictionaries
(local-expand #`(#,dict-expr
#,@(for/list ([constr (in-list constrs)])
(quasisyntax/loc this
(@%dictionary-placeholder
#,(preservable-property->expression constr)
(quote-syntax src-expr)))))
'expression '())))))])
; any constraints, we need to produce a (curried) application to sub-dictionaries, which
; should be recursively elaborated.
(make-variable-like-transformer
(foldr (λ (constr acc)
#`(#,acc
#,(elaborate-dictionaries
(local-expand
(quasisyntax/loc this
(@%dictionary-placeholder
#,(preservable-property->expression constr)
(quote-syntax src-expr)))
'expression '()))))
dict-expr
constrs)))])
dict-expr)]
[(#%plain-app @%with-dictionary constr-expr e)
#:with this #`(quote-syntax #,this-syntax)
Expand Down
2 changes: 1 addition & 1 deletion hackett-lib/hackett/private/prim/op.rkt
Original file line number Diff line number Diff line change
Expand Up @@ -88,7 +88,7 @@
;; ---------------------------------------------------------------------------------------------------
;; String

(define ((equal?/String x) y) (string=?- (force- x) (force- y)))
(define ((equal?/String x) y) (boolean->Bool (string=?- (force- x) (force- y))))
(define ((append/String x) y) (string-append- (force- x) (force- y)))
(define (string-length x) (string-length- (force- x)))
(define ((string-split x) y) (list->List (string-split- (force- y) (force- x) #:trim? #f)))
Expand Down
53 changes: 53 additions & 0 deletions hackett-test/hackett/private/test.rkt
Original file line number Diff line number Diff line change
@@ -0,0 +1,53 @@
#lang hackett

(require (only-in racket/base for-syntax module submod))

(module shared hackett
(provide (data Test-Result))
(data Test-Result test-success test-failure))

(module untyped racket/base
(require (for-syntax racket/base)
racket/promise
(prefix-in r: rackunit/log)
syntax/parse/define

(only-in hackett [#%app @%app] : -> IO String Unit unit tuple)
(only-in hackett/private/base with-dictionary-elaboration)
(only-in hackett/private/prim io unsafe-run-io!)
hackett/private/prim/type-provide

(submod ".." shared))

(provide (typed-out [test-log! : {Test-Result -> (IO Unit)}]
[println/error : {String -> (IO Unit)}])
test)

(define (test-log! result)
(io (λ (rw)
(r:test-log! (equal? test-success (force result)))
((tuple rw) unit))))

(define (println/error str)
(io (λ (rw)
(displayln (force str) (current-error-port))
((tuple rw) unit))))

(define-syntax-parser test
[(_ e:expr)
#'(module+ test
(void (with-dictionary-elaboration (force (@%app unsafe-run-io! e)))))]))

(require (submod "." shared)
(submod "." untyped))

(provide test ==!)

(defn ==! : (forall [a] (Eq a) (Show a) => {a -> a -> (IO Unit)})
[[x y] (if {x == y}
(test-log! test-success)
(do (println/error
{"expectation failed:\n"
++ " expected: " ++ (show y) ++ "\n"
++ " given: " ++ (show x)})
(test-log! test-failure)))])
4 changes: 2 additions & 2 deletions hackett-test/info.rkt
Original file line number Diff line number Diff line change
Expand Up @@ -3,8 +3,8 @@
(define collection 'multi)

(define deps
'())
(define build-deps
'("base"
"hackett-lib"
"testing-util-lib"))
(define build-deps
'())
5 changes: 5 additions & 0 deletions hackett-test/tests/hackett/regression/github-issue-36.rkt
Original file line number Diff line number Diff line change
@@ -0,0 +1,5 @@
#lang hackett

(require hackett/private/test)

(test {(show (tuple 1 2)) ==! "(tuple 1 2)"})

0 comments on commit b300a30

Please sign in to comment.