#lang racket/base ;;; SPDX-License-Identifier: LGPL-3.0-or-later ;;; SPDX-FileCopyrightText: Copyright © 2017-2022 Tony Garnock-Jones (provide read-msd) (require (only-in racket/format ~a ~r)) (require (only-in racket/list flatten)) (require racket/match) (require racket/set) (require preserves) (require preserves-schema/methods) (require syndicate/schemas/trace) (require (prefix-in P: syndicate/schemas/protocol)) (require "types.rkt") (define (read-msd port #:config [config (render-config)]) (define max-lane -1) (define logical-time 1) (define swimlane-map (make-hash)) (define turn-map (make-hash)) (define handle-map (make-hash)) (define events-rev '()) (define (emit! e) (when e (set! logical-time (+ logical-time 1)) (set! events-rev (cons e events-rev)))) (define (find-unused-lane swimlane-map) (let ((used-lanes (list->set (hash-values swimlane-map)))) (do ((i 0 (+ i 1))) ((not (set-member? used-lanes i)) i)))) (define (translate! actor-id [moment logical-time]) (define new? #f) (define p (diagram-position (hash-ref! swimlane-map actor-id (lambda () (define lane (find-unused-lane swimlane-map)) (when (> lane max-lane) (set! max-lane lane)) (set! new? #t) lane)) moment)) (when new? (emit! (begin-swimlane p))) p) (define (vacate-lane! actor-id) (hash-remove! swimlane-map actor-id)) (define (turn-actor turn-id) (car (hash-ref turn-map turn-id))) (define (turn-moment turn-id) (cdr (hash-ref turn-map turn-id))) (define (connection* #:bidirectional? [bidirectional? #f] source-actor-id sink-actor-id) (and source-actor-id (connection bidirectional? (translate! source-actor-id) (translate! sink-actor-id)))) (define (format-turn-label actor-id turn-id turn-cause) (define sub-label (match turn-cause [(TurnCause-turn other) (emit! (connection #f (translate! (turn-actor other) (turn-moment other)) (translate! actor-id))) (format "caused by ~a" (~turn other))] [(TurnCause-cleanup) "cleanup"] [(TurnCause-linkedTaskRelease task reason) (format "task ~a ended: ~a" task (->preserve reason))] [(TurnCause-periodicActivation period) (format "timer: every ~as" period)] [(TurnCause-delay other-turn delay-amount) (emit! (connection* (turn-actor other-turn) actor-id)) (format "delay: ~as" delay-amount)] [(TurnCause-external desc) (format "external: ~a" desc)])) (format "~a: ~a" (~turn turn-id) sub-label)) (define (~actor-id a) (~a (ActorId-value a))) (define (~turn t) (format "#~a" (TurnId-value t))) (define (~target e) (match-define (Target actor-id facet-id oid) e) (format "~a/~a:~a" (~actor-id actor-id) (FacetId-value facet-id) (let ((oid (Oid-value oid))) (if (number? oid) (~r oid #:base 16 #:min-width 16 #:pad-string "0") oid)))) (define (~handle h) (format "H~a" (P:Handle-value h))) (define (~adesc adesc) (match adesc [(AssertionDescription-value v) (preserve->string v #:encode-embedded values #:commas? #f)] [(AssertionDescription-opaque d) (format "⌜~a⌝" d)])) (define (~turn-event te is-action?) (match te [(TurnEvent-assert adesc handle) (when is-action? (when (hash-has-key? handle-map handle) (log-error "Duplicate use of handle ~a" (~handle handle))) (hash-set! handle-map handle adesc)) (format "assert ~a: ~a" (~handle handle) (~adesc adesc))] [(TurnEvent-retract handle) (define adesc (hash-ref handle-map handle #f)) (format "retract ~a: ~a" (~handle handle) (if adesc (~adesc adesc) "(missing)"))] [(TurnEvent-message adesc) (format "message ~a" (~adesc adesc))] [(TurnEvent-sync peer) (format "sync ~a" (~target peer))] [(TurnEvent-breakLink source-actor-id handle) (format "break link from ~a" (~actor-id source-actor-id))])) (define (~targeted-turn-event tte is-action?) (match-define (TargetedTurnEvent target detail) tte) (format "~a <-- ~a" (~target target) (~turn-event detail is-action?))) (define (process-action! actor-id action) (let-values (((variation label) (match action [(ActionDescription-dequeue tte) (values 'event (~targeted-turn-event tte #f))] [(ActionDescription-enqueue tte) (values 'action (~targeted-turn-event tte #t))] [(ActionDescription-dequeueInternal tte) (values 'event (format "(internal) ~a" (~targeted-turn-event tte #f)))] [(ActionDescription-enqueueInternal tte) (values 'action (format "(internal) ~a" (~targeted-turn-event tte #t)))] [(ActionDescription-spawn linked? child-actor-id) (translate! child-actor-id) ;; allocates swimlane (define L (annotate-swimlane (translate! actor-id) (render-config-action-color config) (format "spawn~a ~a" (if linked? "/link" "") (~actor-id child-actor-id)))) (define C (and (not linked?) (connection* actor-id child-actor-id))) (emit! L) (when C (emit! C)) (values #f #f)] [(ActionDescription-link parent-actor-id handle-child->parent child-actor-id handle-parent->child) (define L1 (annotate-swimlane (translate! parent-actor-id) (render-config-action-color config) (format "linked to ~a" (~actor-id child-actor-id)))) (define L2 (annotate-swimlane (translate! child-actor-id) (render-config-action-color config) (format "linked to ~a" (~actor-id parent-actor-id)))) (define C (connection* #:bidirectional? #t parent-actor-id child-actor-id)) (emit! L1) (emit! L2) (emit! C) (values #f #f)] [(ActionDescription-facetStart facet-ids) (values 'action (format "+facet ~a" (map FacetId-value facet-ids)))] [(ActionDescription-facetStop facet-ids reason) (values 'action (format "-facet ~a ~a" (map FacetId-value facet-ids) (->preserve reason)))] [(ActionDescription-linkedTaskStart name task-id) (values 'action (format "task ~a started: ~a" task-id name))]))) (when label (emit! (annotate-swimlane (translate! actor-id) (match variation ['event (render-config-event-color config)] ['action (render-config-action-color config)]) label))))) (define (process-trace-entry! entry) (match-define (TraceEntry _timestamp actor-id activation) entry) (match activation [(ActorActivation-start name) (emit! (annotate-swimlane (translate! actor-id) (render-config-label-color config) (match name [(Name-anonymous) "(anonymous)"] [(Name-named n) (preserve->string n #:encode-embedded values #:indent 2 #:commas? #f)])))] [(ActorActivation-turn (TurnDescription turn-id turn-cause actions)) (emit! (activate-swimlane (translate! actor-id))) (let ((label (format-turn-label actor-id turn-id turn-cause))) (emit! (annotate-swimlane (translate! actor-id) (render-config-event-color config) label))) (for [(a (in-list actions))] (process-action! actor-id a)) ;; (let ((action-count (length actions))) ;; (when (positive? action-count) ;; (emit! (annotate-swimlane (translate! actor-id) ;; (render-config-action-color config) ;; (match action-count ;; [1 "1 action"] ;; [n (format "~a actions" n)]))))) (hash-set! turn-map turn-id (cons actor-id logical-time)) (emit! (deactivate-swimlane (translate! actor-id))) ] [(ActorActivation-stop status) (emit! (end-swimlane (translate! actor-id))) (when (ExitStatus-Error? status) (emit! (annotate-swimlane (translate! actor-id) (render-config-label-color config) (format "crashed: ~a" (->preserve status))))) (vacate-lane! actor-id)])) (let loop () (match (read-preserve port #:decode-embedded values) [(? eof-object?) (msd max-lane (reverse events-rev))] [input (match (parse-TraceEntry input) [(? eof-object?) (error 'read-msd "Invalid trace entry: ~v" input)] [entry (process-trace-entry! entry)]) (loop)])))