<commit_before>! Copyright (C) 2003, 2009 <NAME>.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs byte-arrays byte-vectors classes
classes.algebra.private classes.intersection classes.maybe
classes.tuple classes.tuple.private classes.union colors
colors.constants combinators continuations effects generic
hash-sets hashtables io io.pathnames io.styles kernel
make math math.order math.parser namespaces prettyprint.config
prettyprint.custom prettyprint.sections prettyprint.stylesheet
quotations sbufs sequences strings vectors words words.symbol
classes.private ;
FROM: sets => members ;
IN: prettyprint.backend

M: effect pprint* effect>string text ;

: ?effect-height ( word -- n )
    stack-effect [ effect-height ] [ 0 ] if* ;

: ?start-group ( word -- )
    ?effect-height 0 > [ start-group ] when ;

: ?end-group ( word -- )
    ?effect-height 0 < [ end-group ] when ;

! Atoms
GENERIC: word-name* ( obj -- str )

M: maybe word-name*
    class-name "maybe{ " " }" surround ;

M: anonymous-complement word-name*
    class-name "not{ " " }" surround ;

M: anonymous-union word-name*
    class-name "union{ " " }" surround ;

M: anonymous-intersection word-name*
    class-name "intersection{ " " }" surround ;

M: word word-name* ( word -- str )
    [ name>> "( no name )" or ] [ record-vocab ] bi ;

: pprint-word ( word -- )
    [ word-name* ] [ word-style ] bi styled-text ;

GENERIC: pprint-class ( obj -- )

M: classoid pprint-class pprint* ;

M: class pprint-class \ f or pprint-word ;

M: word pprint-class pprint-word ;

: pprint-prefix ( word quot -- )
    <block swap pprint-word call block> ; inline

M: parsing-word pprint*
    \ POSTPONE: [ pprint-word ] pprint-prefix ;

M: word pprint*
    [ pprint-word ] [ ?start-group ] [ ?end-group ] tri ;

M: method pprint*
    <block
    [ \ M\ pprint-word "method-class" word-prop pprint* ]
    [ "method-generic" word-prop pprint-word ] bi
    block> ;

: pprint-prefixed-number ( n quot: ( n -- n' ) pre -- )
    pick neg?
    [ [ neg ] [ call ] [ prepend ] tri* "-" prepend text ]
    [ [ call ] [ prepend ] bi* text ] if ; inline

M: real pprint*
    number-base get {
        { 16 [ [ >hex ] "0x" pprint-prefixed-number ] }
        {  8 [ [ >oct ] "0o" pprint-prefixed-number ] }
        {  2 [ [ >bin ] "0b" pprint-prefixed-number ] }
        [ drop number>string text ]
    } case ;

M: float pprint*
    dup fp-nan? [
        \ NAN: [ fp-nan-payload >hex text ] pprint-prefix
    ] [
        number-base get {
            { 16 [ [ >hex ] "0x" pprint-prefixed-number ] }
            [ drop number>string text ]
        } case
    ] if ;

M: f pprint* drop \ f pprint-word ;

: pprint-effect ( effect -- )
    [ effect>string ] [ effect-style ] bi styled-text ;

! Strings
: ch>ascii-escape ( ch -- ch' ? )
    H{
        { CHAR: \a CHAR: a  }
        { CHAR: \b CHAR: b  }
        { CHAR: \e CHAR: e  }
        { CHAR: \f CHAR: f  }
        { CHAR: \n CHAR: n  }
        { CHAR: \r CHAR: r  }
        { CHAR: \t CHAR: t  }
        { CHAR: \v CHAR: v  }
        { CHAR: \0 CHAR: 0  }
        { CHAR: \\ CHAR: \\ }
        { CHAR: \" CHAR: \" }
    } ?at ; inline

: unparse-ch ( ch -- )
    ch>ascii-escape [ "\\" % , ] [
        dup 32 < [ dup 16 < "\\x0" "\\x" ? % >hex % ] [ , ] if
    ] if ;

: do-string-limit ( str -- trimmed )
    string-limit? get [
        dup length margin get > [
            margin get 3 - head "..." append
        ] when
    ] when ;

: unparse-string ( str prefix suffix -- str )
    [ [ % do-string-limit [ unparse-ch ] each ] dip % ] "" make ;

: pprint-string ( obj str prefix suffix -- )
    unparse-string swap string-style styled-text ;

M: string pprint*
    dup "\"" "\"" pprint-string ;

M: sbuf pprint*
    dup "SBUF\" " "\"" pprint-string ;<commit_msg>prettyprint.backend: use , not % in unparse-ch.<commit_after>! Copyright (C) 2003, 2009 <NAME>.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs byte-arrays byte-vectors classes
classes.algebra.private classes.intersection classes.maybe
classes.tuple classes.tuple.private classes.union colors
colors.constants combinators continuations effects generic
hash-sets hashtables io io.pathnames io.styles kernel
make math math.order math.parser namespaces prettyprint.config
prettyprint.custom prettyprint.sections prettyprint.stylesheet
quotations sbufs sequences strings vectors words words.symbol
classes.private ;
FROM: sets => members ;
IN: prettyprint.backend

M: effect pprint* effect>string text ;

: ?effect-height ( word -- n )
    stack-effect [ effect-height ] [ 0 ] if* ;

: ?start-group ( word -- )
    ?effect-height 0 > [ start-group ] when ;

: ?end-group ( word -- )
    ?effect-height 0 < [ end-group ] when ;

! Atoms
GENERIC: word-name* ( obj -- str )

M: maybe word-name*
    class-name "maybe{ " " }" surround ;

M: anonymous-complement word-name*
    class-name "not{ " " }" surround ;

M: anonymous-union word-name*
    class-name "union{ " " }" surround ;

M: anonymous-intersection word-name*
    class-name "intersection{ " " }" surround ;

M: word word-name* ( word -- str )
    [ name>> "( no name )" or ] [ record-vocab ] bi ;

: pprint-word ( word -- )
    [ word-name* ] [ word-style ] bi styled-text ;

GENERIC: pprint-class ( obj -- )

M: classoid pprint-class pprint* ;

M: class pprint-class \ f or pprint-word ;

M: word pprint-class pprint-word ;

: pprint-prefix ( word quot -- )
    <block swap pprint-word call block> ; inline

M: parsing-word pprint*
    \ POSTPONE: [ pprint-word ] pprint-prefix ;

M: word pprint*
    [ pprint-word ] [ ?start-group ] [ ?end-group ] tri ;

M: method pprint*
    <block
    [ \ M\ pprint-word "method-class" word-prop pprint* ]
    [ "method-generic" word-prop pprint-word ] bi
    block> ;

: pprint-prefixed-number ( n quot: ( n -- n' ) pre -- )
    pick neg?
    [ [ neg ] [ call ] [ prepend ] tri* "-" prepend text ]
    [ [ call ] [ prepend ] bi* text ] if ; inline

M: real pprint*
    number-base get {
        { 16 [ [ >hex ] "0x" pprint-prefixed-number ] }
        {  8 [ [ >oct ] "0o" pprint-prefixed-number ] }
        {  2 [ [ >bin ] "0b" pprint-prefixed-number ] }
        [ drop number>string text ]
    } case ;

M: float pprint*
    dup fp-nan? [
        \ NAN: [ fp-nan-payload >hex text ] pprint-prefix
    ] [
        number-base get {
            { 16 [ [ >hex ] "0x" pprint-prefixed-number ] }
            [ drop number>string text ]
        } case
    ] if ;

M: f pprint* drop \ f pprint-word ;

: pprint-effect ( effect -- )
    [ effect>string ] [ effect-style ] bi styled-text ;

! Strings
: ch>ascii-escape ( ch -- ch' ? )
    H{
        { CHAR: \a CHAR: a  }
        { CHAR: \b CHAR: b  }
        { CHAR: \e CHAR: e  }
        { CHAR: \f CHAR: f  }
        { CHAR: \n CHAR: n  }
        { CHAR: \r CHAR: r  }
        { CHAR: \t CHAR: t  }
        { CHAR: \v CHAR: v  }
        { CHAR: \0 CHAR: 0  }
        { CHAR: \\ CHAR: \\ }
        { CHAR: \" CHAR: \" }
    } ?at ; inline

: unparse-ch ( ch -- )
    ch>ascii-escape [ CHAR: \\ , , ] [
        dup 32 < [ dup 16 < "\\x0" "\\x" ? % >hex % ] [ , ] if
    ] if ;

: do-string-limit ( str -- trimmed )
    string-limit? get [
        dup length margin get > [
            margin get 3 - head "..." append
        ] when
    ] when ;

: unparse-string ( str prefix suffix -- str )
    [ [ % do-string-limit [ unparse-ch ] each ] dip % ] "" make ;

: pprint-string ( obj str prefix suffix -- )
    unparse-string swap string-style styled-text ;

M: string pprint*
    dup "\"" "\"" pprint-string ;

M: sbuf pprint*
    dup "SBUF\" " "\"" pprint-string ;
{'fraction_non_alphanumeric': 0.15136054421768708, 'fraction_numerical': 0.007587650444793302, 'mean_word_length': 2.1920668058455113, 'pattern_counts': {'":': 0, '<': 15, '<?xml version=': 0, '>': 43, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '3856314', 'n_tokens_mistral': 2738, 'n_tokens_neox': 2622, 'n_words': 725}