Bug fixes, remove expr->tex, fix bugs, fmt

Author: pavpanchekha

src/api/server.rkt

@@ -478,7 +478,8 @@
   (match-define (alt-analysis alt test-errors) analysis)
   (define cost (alt-cost alt repr))
 
-  (define history (render-history alt pcontext (test-context test) errcache))
+  (define history-json (render-json alt pcontext (test-context test) errcache))
+  (define history (render-history history-json (test-context test)))
 
   (define vars (test-vars test))
   (define splitpoints

src/reports/common.rkt

@@ -37,7 +37,7 @@
          format-percent
          write-html
          program->fpcore
-         program->tex
+         fpcore->tex
          fpcore->string
          js-tex-include
          doc-url
@@ -159,10 +159,9 @@
                                                       ("Wolfram" "wl" ,core->wls)
                                                       ("TeX" "tex" ,(λ (c i) (core->tex c)))))
 
-(define (program->tex prog ctx #:loc [loc #f])
-  (define prog* (program->fpcore prog ctx))
-  (if (supported-by-lang? prog* "tex")
-      (core->tex prog* #:loc (and loc (cons 2 loc)) #:color "blue")
+(define (fpcore->tex fpcore #:loc [loc #f])
+  (if (supported-by-lang? fpcore "tex")
+      (core->tex fpcore #:loc (and loc (cons 2 loc)) #:color "blue")
       "ERROR"))
 
 (define (render-program expr ctx #:ident [identifier #f] #:pre [precondition '(TRUE)])

src/reports/history.rkt

@@ -58,18 +58,6 @@
   (define err (errors-score-masked (hash-ref errcache (alt-expr altn)) mask))
   (format-accuracy err repr #:unit "%"))
 
-(define (expr->fpcore expr ctx #:ident [ident #f])
-  (list 'FPCore
-        (context-vars ctx)
-        (let loop ([expr expr])
-          (match expr
-            [(? symbol?) expr]
-            [(? number?) expr]
-            [(? literal?) (literal-value expr)]
-            [(approx spec impl) (loop impl)]
-            [(hole precision spec) (loop spec)]
-            [(list op args ...) (cons op (map loop args))]))))
-
 (define (mixed->fpcore expr ctx)
   (define expr*
     (let loop ([expr expr])
@@ -122,65 +110,49 @@
   (make-list (pcontext-length pcontext) #f))
 
 ;; HTML renderer for derivations
-(define (render-history altn pcontext ctx errcache [mask (make-mask pcontext)])
-  (match altn
-    [(alt prog 'start (list) _)
-     (define err (altn-errors altn pcontext ctx errcache mask))
+(define (render-history json ctx)
+  (define err
+    (match (hash-ref json 'error)
+      [(? number? n) (format-accuracy n (context-repr ctx) #:unit "%")]
+      [other other]))
+  (define prog (read (open-input-string (hash-ref json 'program))))
+  (match (hash-ref json 'type)
+    ["start"
      (list `(li (p "Initial program " (span ((class "error")) ,err))
-                (div ((class "math")) "\\[" ,(program->tex prog ctx) "\\]")))]
+                (div ((class "math")) "\\[" ,(fpcore->tex prog) "\\]")))]
 
-    [(alt prog 'add-preprocessing `(,prev) _)
-     ;; TODO message to user is? proof later
-     `(,@(render-history prev pcontext ctx errcache mask) (li "Add Preprocessing"))]
-
-    [(alt _ `(regimes ,splitpoints) prevs _)
-     (define intervals
-       (for/list ([start-sp (cons (sp -1 -1 #f) splitpoints)]
-                  [end-sp splitpoints])
-         (interval (sp-cidx end-sp) (sp-point start-sp) (sp-point end-sp) (sp-bexpr end-sp))))
-     (define repr (context-repr ctx))
+    ["add-preprocessing" `(,@(render-history (hash-ref json 'prev) ctx) (li "Add Preprocessing"))]
 
+    ["regimes"
+     (define prevs (hash-ref json 'prevs))
      `((li ((class "event")) "Split input into " ,(~a (length prevs)) " regimes")
        (li ,@(apply append
-                    (for/list ([entry prevs]
-                               [idx (in-naturals)]
-                               [new-mask (regimes-pcontext-masks pcontext splitpoints prevs ctx)])
-                      (define mask* (map and-fn mask new-mask))
-                      (define entry-ivals
-                        (filter (λ (intrvl) (= (interval-alt-idx intrvl) idx)) intervals))
-                      (define condition
-                        (string-join (map (curryr interval->string repr) entry-ivals) " or "))
-                      `((h2 (code "if " (span ((class "condition")) ,condition)))
-                        (ol ,@(render-history entry pcontext ctx errcache mask*))))))
+                    (for/list ([entry (in-list prevs)]
+                               [condition (in-list (hash-ref json 'conditions))])
+                      `((h2 (code "if " (span ((class "condition")) ,(string-join condition " or "))))
+                        (ol ,@(render-history entry ctx))))))
        (li ((class "event")) "Recombined " ,(~a (length prevs)) " regimes into one program."))]
 
-    [(alt prog `(taylor ,loc ,pt ,var) `(,prev) _)
-     (define core (mixed->fpcore prog ctx))
-     `(,@(render-history prev pcontext ctx errcache mask)
-       (li (p "Taylor expanded in " ,(~a var) " around " ,(~a pt))
-           (div ((class "math"))
-                "\\[\\leadsto "
-                ,(core->tex core #:loc (and loc (cons 2 loc)) #:color "blue")
-                "\\]")))]
+    ["taylor"
+     (define-values (prev pt var loc) (apply values (map (curry hash-ref json) '(prev pt var loc))))
+     `(,@(render-history prev ctx)
+       (li (p "Taylor expanded in " ,var " around " ,pt)
+           (div ((class "math")) "\\[\\leadsto " ,(fpcore->tex prog #:loc loc) "\\]")))]
 
-    [(alt prog `(evaluate ,loc) `(,prev) _)
-     (define core (mixed->fpcore prog ctx))
-     (define err (altn-errors altn pcontext ctx errcache mask))
-     `(,@(render-history prev pcontext ctx errcache mask)
+    ["evaluate"
+     (define-values (prev loc) (apply values (map (curry hash-ref json) '(prev loc))))
+     `(,@(render-history prev ctx)
        (li (p "Evaluated real constant" (span ((class "error")) ,err))
-           (div ((class "math"))
-                "\\[\\leadsto "
-                ,(core->tex core #:loc (and loc (cons 2 loc)) #:color "blue")
-                "\\]")))]
+           (div ((class "math")) "\\[\\leadsto " ,(fpcore->tex prog #:loc loc) "\\]")))]
 
-    [(alt prog `(rr ,loc ,input ,proof) `(,prev) _)
-     (define err (altn-errors altn pcontext ctx errcache mask))
-     `(,@(render-history prev pcontext ctx errcache mask)
-       (li ,(if proof
-                (render-proof (render-proof-json proof pcontext ctx errcache mask) ctx)
-                ""))
+    ["rr"
+     (define-values (prev loc proof) (apply values (map (curry hash-ref json) '(prev loc proof))))
+     `(,@(render-history prev ctx)
+       (li ,(if (eq? proof (json-null))
+                ""
+                (render-proof proof ctx)))
        (li (p "Applied rewrites" (span ((class "error")) ,err))
-           (div ((class "math")) "\\[\\leadsto " ,(program->tex prog ctx #:loc loc) "\\]")))]))
+           (div ((class "math")) "\\[\\leadsto " ,(fpcore->tex prog #:loc loc) "\\]")))]))
 
 (define (errors-score-masked errs mask)
   (if (ormap identity mask)
@@ -191,29 +163,28 @@
       (errors-score errs)))
 
 (define (render-proof proof-json ctx)
-  `(div ([class "proof"])
-        (details (summary "Step-by-step derivation")
-                 (ol ,@(for/list ([step (in-list proof-json)])
-                         (define-values (direction err loc rule prog-str)
-                           (apply values (map (curry hash-ref step)
-                                              '(direction error loc rule program))))
-                         (define dir
-                           (match direction
-                             ["goal" "goal"]
-                             ["rtl" "right to left"]
-                             ["ltr" "left to right"]))
-                         (define prog (read (open-input-string prog-str)))
-                         (if (equal? dir "goal")
-                             ""
-                             `(li (p (code ([title ,dir]) ,rule)
-                                     (span ([class "error"])
-                                           ,(if (number? err)
-                                                (format-accuracy err (context-repr ctx) #:unit "%")
-                                                err)))
-                                  (div ((class "math"))
-                                       "\\[\\leadsto "
-                                       ,(core->tex prog #:loc (and loc (cons 2 loc)) #:color "blue")
-                                       "\\]"))))))))
+  `(div
+    ((class "proof"))
+    (details
+     (summary "Step-by-step derivation")
+     (ol ,@
+         (for/list ([step (in-list proof-json)])
+           (define-values (direction err loc rule prog-str)
+             (apply values (map (curry hash-ref step) '(direction error loc rule program))))
+           (define dir
+             (match direction
+               ["goal" "goal"]
+               ["rtl" "right to left"]
+               ["ltr" "left to right"]))
+           (define prog (read (open-input-string prog-str)))
+           (if (equal? dir "goal")
+               ""
+               `(li (p (code ([title ,dir]) ,rule)
+                       (span ((class "error"))
+                             ,(if (number? err)
+                                  (format-accuracy err (context-repr ctx) #:unit "%")
+                                  err)))
+                    (div ((class "math")) "\\[\\leadsto " ,(fpcore->tex prog #:loc loc) "\\]"))))))))
 
 (define (render-json altn pcontext ctx errcache [mask (make-list (pcontext-length pcontext) #f)])
   (define repr (context-repr ctx))
@@ -224,16 +195,17 @@
 
   (match altn
     [(alt prog 'start (list) _)
-     `#hash((program . ,(fpcore->string (expr->fpcore prog ctx))) (type . "start") (error . ,err))]
+     `#hash((program . ,(fpcore->string (program->fpcore prog ctx))) (type . "start") (error . ,err))]
 
     [(alt prog `(regimes ,splitpoints) prevs _)
      (define intervals
        (for/list ([start-sp (cons (sp -1 -1 #f) splitpoints)]
                   [end-sp splitpoints])
          (interval (sp-cidx end-sp) (sp-point start-sp) (sp-point end-sp) (sp-bexpr end-sp))))
 
-     `#hash((program . ,(fpcore->string (expr->fpcore prog ctx)))
+     `#hash((program . ,(fpcore->string (program->fpcore prog ctx)))
             (type . "regimes")
+            (error . ,err)
             (conditions . ,(for/list ([entry prevs]
                                       [idx (in-naturals)])
                              (define entry-ivals
@@ -245,7 +217,7 @@
                         (render-json entry pcontext ctx errcache mask*))))]
 
     [(alt prog `(taylor ,loc ,pt ,var) `(,prev) _)
-     `#hash((program . ,(fpcore->string (expr->fpcore prog ctx)))
+     `#hash((program . ,(fpcore->string (program->fpcore prog ctx)))
             (type . "taylor")
             (prev . ,(render-json prev pcontext ctx errcache mask))
             (pt . ,(~a pt))
@@ -254,14 +226,14 @@
             (error . ,err))]
 
     [(alt prog `(evaluate ,loc) `(,prev) _)
-     `#hash((program . ,(fpcore->string (expr->fpcore prog ctx)))
+     `#hash((program . ,(fpcore->string (program->fpcore prog ctx)))
             (type . "evaluate")
             (prev . ,(render-json prev pcontext ctx errcache mask))
             (loc . ,loc)
             (error . ,err))]
 
     [(alt prog `(rr ,loc ,input ,proof) `(,prev) _)
-     `#hash((program . ,(fpcore->string (expr->fpcore prog ctx)))
+     `#hash((program . ,(fpcore->string (program->fpcore prog ctx)))
             (type . "rr")
             (prev . ,(render-json prev pcontext ctx errcache mask))
             (proof . ,(if proof
@@ -271,7 +243,7 @@
             (error . ,err))]
 
     [(alt prog 'add-preprocessing `(,prev) preprocessing)
-     `#hash((program . ,(fpcore->string (expr->fpcore prog ctx)))
+     `#hash((program . ,(fpcore->string (program->fpcore prog ctx)))
             (type . "add-preprocessing")
             (prev . ,(render-json prev pcontext ctx errcache mask))
             (error . ,err)
@@ -283,14 +255,11 @@
     (define-values (err fpcore)
       (cond
         [(impl-prog? expr)
-         (values (errors-score-masked (hash-ref errcache expr) mask)
-                 (program->fpcore expr ctx))]
-        [else
-         (values "N/A" (mixed->fpcore expr ctx))]))
+         (values (errors-score-masked (hash-ref errcache expr) mask) (program->fpcore expr ctx))]
+        [else (values "N/A" (mixed->fpcore expr ctx))]))
 
     `#hash((error . ,err)
            (program . ,(fpcore->string fpcore))
-
            (direction . ,(match dir
                            ['Rewrite<= "rtl"]
                            ['Rewrite=> "ltr"]

src/reports/make-graph.rkt

@@ -86,10 +86,9 @@
             "Percentage Accurate"
             (format-accuracy (errors-score start-error) repr #:unit "%")
             (format-accuracy (errors-score end-error) repr #:unit "%")
-            #:title
-            (format "Minimum Accuracy: ~a → ~a"
-                    (format-accuracy (apply max (map ulps->bits start-error)) repr #:unit "%")
-                    (format-accuracy (apply max (map ulps->bits end-error)) repr #:unit "%")))
+            #:title (format "Minimum Accuracy: ~a → ~a"
+                            (format-accuracy (apply max (map ulps->bits start-error)) repr #:unit "%")
+                            (format-accuracy (apply max (map ulps->bits end-error)) repr #:unit "%")))
           ,(render-large "Time" (format-time time))
           ,(render-large "Alternatives" (~a (length end-exprs)))
           ,(if (*pareto-mode*)
@@ -175,17 +174,16 @@
          (define target-cost (hash-ref target 'cost))
          (define target-expr (read (open-input-string (hash-ref target 'expr))))
          (let-values ([(dropdown body) (render-program target-expr ctx #:ident identifier)])
-           `(section
-             ([id ,(format "target~a" i)] (class "programs"))
-             (h2 "Developer Target "
-                 ,(~a i)
-                 ": "
-                 (span ((class "subhead"))
-                       (data ,(format-accuracy (errors-score target-error) repr #:unit "%"))
-                       " accurate, "
-                       (data ,(~r (/ start-cost target-cost) #:precision '(= 1)) "×")
-                       " speedup")
-                 ,dropdown
-                 ,(render-help "report.html#target"))
-             ,body)))
+           `(section ([id ,(format "target~a" i)] (class "programs"))
+                     (h2 "Developer Target "
+                         ,(~a i)
+                         ": "
+                         (span ((class "subhead"))
+                               (data ,(format-accuracy (errors-score target-error) repr #:unit "%"))
+                               " accurate, "
+                               (data ,(~r (/ start-cost target-cost) #:precision '(= 1)) "×")
+                               " speedup")
+                         ,dropdown
+                         ,(render-help "report.html#target"))
+                     ,body)))
      ,(render-reproduction test))))

src/reports/timeline.rkt

@@ -309,19 +309,19 @@
 
 (define (render-phase-alts alts)
   `((dt "Alt Table")
-    (dd (details
-         (summary "Click to see full alt table")
-         (table ((class "times"))
-                (thead (tr (th "Status") (th "Accuracy") (th "Program")))
-                ,@(for/list ([rec (in-list alts)])
-                    (match-define (list expr status score repr-name) rec)
-                    (define repr (get-representation (read (open-input-string repr-name))))
-                    `(tr ,(match status
-                            ["next" `(td (span ([title "Selected for next iteration"]) "▶"))]
-                            ["done" `(td (span ([title "Selected in a prior iteration"]) "✓"))]
-                            ["fresh" `(td)])
-                         (td ,(format-accuracy score repr #:unit "%") "")
-                         (td (pre ,expr)))))))))
+    (dd (details (summary "Click to see full alt table")
+                 (table ((class "times"))
+                        (thead (tr (th "Status") (th "Accuracy") (th "Program")))
+                        ,@
+                        (for/list ([rec (in-list alts)])
+                          (match-define (list expr status score repr-name) rec)
+                          (define repr (get-representation (read (open-input-string repr-name))))
+                          `(tr ,(match status
+                                  ["next" `(td (span ([title "Selected for next iteration"]) "▶"))]
+                                  ["done" `(td (span ([title "Selected in a prior iteration"]) "✓"))]
+                                  ["fresh" `(td)])
+                               (td ,(format-accuracy score repr #:unit "%") "")
+                               (td (pre ,expr)))))))))
 
 (define (render-phase-times times)
   `((dt "Calls")
@@ -364,15 +364,15 @@
                            " saved)"))))
 
 (define (render-phase-branches branches)
-  `((dt "Results")
-    (dd (table ((class "times"))
-               (thead (tr (th "Accuracy") (th "Segments") (th "Branch")))
-               ,@(for/list ([rec (in-list branches)])
-                   (match-define (list expr score splits repr-name) rec)
-                   (define repr (get-representation (read (open-input-string repr-name))))
-                   `(tr (td ,(format-accuracy score repr #:unit "%") "")
-                        (td ,(~a splits))
-                        (td (code ,expr))))))))
+  `((dt "Results") (dd (table ((class "times"))
+                              (thead (tr (th "Accuracy") (th "Segments") (th "Branch")))
+                              ,@(for/list ([rec (in-list branches)])
+                                  (match-define (list expr score splits repr-name) rec)
+                                  (define repr
+                                    (get-representation (read (open-input-string repr-name))))
+                                  `(tr (td ,(format-accuracy score repr #:unit "%") "")
+                                       (td ,(~a splits))
+                                       (td (code ,expr))))))))
 
 (define (render-phase-outcomes outcomes)
   `((dt "Samples") (dd (table ((class "times"))

src/syntax/sugar.rkt

@@ -242,16 +242,19 @@
   (define (munge expr #:root? [root? #f])
     (match expr
       [(? literal?) (literal->fpcore expr)]
+      [(? number?) expr]
       [(? symbol?) expr]
       [(approx _ impl) (munge impl)]
+      [(hole _ spec) (munge spec)]
       [(list 'if cond ift iff) (list 'if (munge cond) (munge ift) (munge iff))]
       [(list (? impl-exists? impl) args ...)
        (define args* (map munge args))
        (define vars (impl-info impl 'vars))
        (define node (replace-vars (map cons vars args*) (impl-info impl 'fpcore)))
        (if root?
            node
-           (push! impl node))]))
+           (push! impl node))]
+      [(list spec-op args ...) (list* spec-op (map munge args))]))
 
   (define root (munge expr #:root? #t))
   (cons (list->vector (reverse instrs)) root))