basis: use lint.vocabs tool to trim using lists

[factor.git] / basis / listener / listener.factor

diff --git a/basis/listener/listener.factor b/basis/listener/listener.factor
index 96db935f07cae6ada9e70c5d83049aaccb68bd13..73f87028934fa3b98a4959f3bc22e09b1c7a8b39 100644 (file)
--- a/basis/listener/listener.factor
+++ b/basis/listener/listener.factor
@@ -1,22 +1,46 @@
 ! Copyright (C) 2003, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays hashtables io kernel math math.parser memory
-namespaces parser lexer sequences strings io.styles
-vectors words generic system combinators continuations debugger
-definitions compiler.units accessors colors prettyprint fry
-sets vocabs.parser source-files.errors locals vocabs vocabs.loader ;
+USING: accessors colors combinators.short-circuit
+compiler.units continuations debugger fry io io.styles kernel lexer
+math math.parser namespaces parser parser.notes prettyprint
+sequences sets source-files.errors system vocabs vocabs.loader
+vocabs.parser ;
 IN: listener
 
 GENERIC: stream-read-quot ( stream -- quot/f )
+GENERIC#: prompt. 1 ( stream prompt -- )
+
+: prompt ( -- str )
+    manifest get current-vocab>> [ name>> "IN: " prepend ] [ "" ] if*
+    auto-use? get [ dup empty? "" " " ? "auto-use" 3append ] when ;
+
+SYMBOL: prompt-style
+H{
+    { background T{ rgba f 1 0.7 0.7 1 } }
+    { foreground COLOR: black }
+} prompt-style set-global
+
+M: object prompt.
+    nip [ prompt-style get-global format bl ] unless-empty ;
+
+SYMBOL: handle-ctrl-break
+
+: maybe-enable-ctrl-break ( -- )
+    handle-ctrl-break get-global [ enable-ctrl-break ] when ;
+
+: with-ctrl-break ( quot -- )
+    maybe-enable-ctrl-break
+    ! Always call disable-ctrl-break, no matter what handle-ctrl-break
+    ! says: it might've been changed just now by the user in the Listener.
+    ! It's a no-op if it's not enabled.
+    [ disable-ctrl-break ] finally ; inline
 
 : parse-lines-interactive ( lines -- quot/f )
-    [ parse-lines ] with-compilation-unit ;
+    [ [ parse-lines ] with-ctrl-break ] with-compilation-unit ;
 
 : read-quot-step ( lines -- quot/f )
-    [ parse-lines-interactive ] [
-        dup error>> unexpected-eof?
-        [ 2drop f ] [ rethrow ] if
-    ] recover ;
+    '[ _ parse-lines-interactive ]
+    [ error>> unexpected-eof? ] ignore-error/f ;
 
 : read-quot-loop ( stream accum -- quot/f )
     over stream-readln dup [
@@ -48,7 +72,7 @@ SYMBOL: error-hook
 
 : call-error-hook ( error -- )
     error-continuation get error-hook get
-    call( continuation error -- ) ;
+    call( error continuation -- ) ;
 
 [ drop print-error-and-restarts ] error-hook set-global
 
@@ -82,7 +106,7 @@ t error-summary? set-global
             ] each
         ] tabular-output nl
     ] unless-empty ;
-    
+
 : trimmed-stack. ( seq -- )
     dup length max-stack-items get > [
         max-stack-items get cut*
@@ -92,24 +116,18 @@ t error-summary? set-global
         ] dip
     ] when stack. ;
 
-: datastack. ( datastack -- )
-    display-stacks? get [
-        [ nl "--- Data stack:" title. trimmed-stack. ] unless-empty
-    ] [ drop ] if ;
+: ?datastack. ( datastack -- )
+    display-stacks? get [ datastack. ] [ drop ] if ;
 
-: prompt. ( -- )
-    current-vocab name>> auto-use? get [ " - auto" append ] when "( " " )" surround
-    H{ { background T{ rgba f 1 0.7 0.7 1 } } } format bl flush ;
-
-:: (listener) ( datastack -- )
+:: listener-step ( datastack -- datastack' )
     error-summary? get [ error-summary ] when
     visible-vars.
-    datastack datastack.
-    prompt.
-
+    datastack ?datastack.
+    input-stream get prompt prompt.
+    flush
     [
         read-quot [
-            '[ datastack _ with-datastack ]
+            '[ [ datastack _ with-datastack ] with-ctrl-break ]
             [ call-error-hook datastack ]
             recover
         ] [ return ] if*
@@ -118,9 +136,10 @@ t error-summary? set-global
         [ call-error-hook datastack ]
         [ rethrow ]
         if
-    ] recover
+    ] recover ;
 
-    (listener) ;
+: listener-loop ( datastack -- )
+    listener-step listener-loop ;
 
 PRIVATE>
 
@@ -168,7 +187,7 @@ SYMBOL: interactive-vocabs
     "tools.dispatch"
     "tools.errors"
     "tools.memory"
-    "tools.profiler"
+    "tools.profiler.sampling"
     "tools.test"
     "tools.threads"
     "tools.time"
@@ -178,27 +197,35 @@ SYMBOL: interactive-vocabs
     "vocabs.refresh"
     "vocabs.hierarchy"
     "words"
-    "scratchpad"
 } interactive-vocabs set-global
 
-: only-use-vocabs ( vocabs -- )
-    clear-manifest
-    [ vocab ] filter
-    [
-        vocab
+: loaded-vocab? ( vocab-spec -- ? )
+    {
         [ find-vocab-root not ]
-        [ source-loaded?>> +done+ eq? ] bi or
-    ] filter
-    [ use-vocab ] each ;
+        [ source-loaded?>> +done+ eq? ]
+    } 1|| ;
+
+: use-loaded-vocabs ( vocabs -- )
+    [
+        lookup-vocab [
+            dup loaded-vocab? [ use-vocab ] [ drop ] if
+        ] when*
+    ] each ;
 
 : with-interactive-vocabs ( quot -- )
     [
         "scratchpad" set-current-vocab
-        interactive-vocabs get only-use-vocabs
+        interactive-vocabs get use-loaded-vocabs
         call
     ] with-manifest ; inline
 
 : listener ( -- )
-    [ [ { } (listener) ] with-return ] with-interactive-vocabs ;
+    [
+        parser-quiet? off
+        [ { } listener-loop ] with-return
+    ] with-interactive-vocabs ;
+
+: listener-main ( -- )
+    "q" get [ version-info print flush ] unless listener ;
 
-MAIN: listener
+MAIN: listener-main