From b300a30d433340c0d9abfd78f46ed8bd99fdd2e4 Mon Sep 17 00:00:00 2001
From: Alexis King <lexi.lambda@gmail.com>
Date: Wed, 30 Aug 2017 17:19:42 -0700
Subject: [PATCH] When elaborating dictionaries with subgoals, curry the
 application

fixes #36
---
 hackett-lib/hackett/private/base.rkt          | 27 +++++-----
 hackett-lib/hackett/private/prim/op.rkt       |  2 +-
 hackett-test/hackett/private/test.rkt         | 53 +++++++++++++++++++
 hackett-test/info.rkt                         |  4 +-
 .../hackett/regression/github-issue-36.rkt    |  5 ++
 5 files changed, 75 insertions(+), 16 deletions(-)
 create mode 100644 hackett-test/hackett/private/test.rkt
 create mode 100644 hackett-test/tests/hackett/regression/github-issue-36.rkt

diff --git a/hackett-lib/hackett/private/base.rkt b/hackett-lib/hackett/private/base.rkt
index f5fe60f..4659e7d 100644
--- a/hackett-lib/hackett/private/base.rkt
+++ b/hackett-lib/hackett/private/base.rkt
@@ -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)
diff --git a/hackett-lib/hackett/private/prim/op.rkt b/hackett-lib/hackett/private/prim/op.rkt
index 5dab2ad..8f43fea 100644
--- a/hackett-lib/hackett/private/prim/op.rkt
+++ b/hackett-lib/hackett/private/prim/op.rkt
@@ -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)))
diff --git a/hackett-test/hackett/private/test.rkt b/hackett-test/hackett/private/test.rkt
new file mode 100644
index 0000000..5b1f9fb
--- /dev/null
+++ b/hackett-test/hackett/private/test.rkt
@@ -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)))])
diff --git a/hackett-test/info.rkt b/hackett-test/info.rkt
index ae0d09d..14219e5 100644
--- a/hackett-test/info.rkt
+++ b/hackett-test/info.rkt
@@ -3,8 +3,8 @@
 (define collection 'multi)
 
 (define deps
-  '())
-(define build-deps
   '("base"
     "hackett-lib"
     "testing-util-lib"))
+(define build-deps
+  '())
diff --git a/hackett-test/tests/hackett/regression/github-issue-36.rkt b/hackett-test/tests/hackett/regression/github-issue-36.rkt
new file mode 100644
index 0000000..827b00e
--- /dev/null
+++ b/hackett-test/tests/hackett/regression/github-issue-36.rkt
@@ -0,0 +1,5 @@
+#lang hackett
+
+(require hackett/private/test)
+
+(test {(show (tuple 1 2)) ==! "(tuple 1 2)"})