shell: resurrecting from unmaintained to extra.

extra/shell/parser/parser.factor

@@ -1,11 +1,8 @@
-
-USING: kernel arrays strings sequences sequences.deep accessors peg peg.ebnf
-       newfx ;
+USING: accessors kernel peg peg.ebnf sequences sequences.deep
+strings ;
 
 IN: shell.parser
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
 TUPLE: basic-expr         command  stdin stdout background ;
 TUPLE: pipeline-expr      commands stdin stdout background ;
 TUPLE: single-quoted-expr expr ;
@@ -15,33 +12,34 @@ TUPLE: glob-expr          expr ;
 TUPLE: variable-expr      expr ;
 TUPLE: factor-expr        expr ;
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: ast>basic-expr ( ast -- obj ) first4 basic-expr boa ;
+: ast>basic-expr ( ast -- obj )
+    first4 basic-expr boa ;
 
 : ast>pipeline-expr ( ast -- obj )
     pipeline-expr new
-    over [ 1st ] [ 4th [ 1st ] map ] [ 5th ] tri suffix prefix-on >>commands
-    over 2nd >>stdin
-    over 6th   >>stdout
-    swap 7th   >>background ;
+        over [ first ] [ fourth [ first ] map ] [ 4 swap nth ] tri
+        suffix swap prefix >>commands
+        over second >>stdin
+        over 5 swap nth >>stdout
+        swap 6 swap nth >>background ;
 
 : ast>single-quoted-expr ( ast -- obj )
-  2nd >string single-quoted-expr boa ;
+    second >string single-quoted-expr boa ;
 
 : ast>double-quoted-expr ( ast -- obj )
-  2nd >string double-quoted-expr boa ;
+    second >string double-quoted-expr boa ;
 
 : ast>back-quoted-expr ( ast -- obj )
-  2nd >string back-quoted-expr boa ;
+    second >string back-quoted-expr boa ;
 
-: ast>glob-expr ( ast -- obj ) flatten concat glob-expr boa ;
+: ast>glob-expr ( ast -- obj )
+    flatten concat glob-expr boa ;
 
-: ast>variable-expr ( ast -- obj ) 2nd variable-expr boa ;
+: ast>variable-expr ( ast -- obj )
+    second variable-expr boa ;
 
-: ast>factor-expr ( ast -- obj ) 2nd >string factor-expr boa ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: ast>factor-expr ( ast -- obj )
+    second >string factor-expr boa ;
 
 EBNF: expr
 

extra/shell/shell.factor

@@ -0,0 +1,88 @@
+USING: accessors continuations debugger environment eval io
+io.directories io.encodings.utf8 io.launcher io.pathnames
+io.pipes kernel namespaces sequences sequences.deep shell.parser
+splitting words ;
+IN: shell
+
+: cd ( args -- )
+    [ home ] [ first ] if-empty set-current-directory ;
+
+: pwd ( args -- )
+    drop current-directory get print ;
+
+CONSTANT: swords { "cd" "pwd" }
+
+GENERIC: expand ( expr -- expr )
+
+M: object expand ;
+
+M: single-quoted-expr expand expr>> ;
+
+M: double-quoted-expr expand expr>> ;
+
+M: variable-expr expand expr>> os-env ;
+
+M: glob-expr expand
+    expr>> dup "*" = [
+        drop current-directory get directory-files
+    ] when ;
+
+M: factor-expr expand expr>> eval>string ;
+
+DEFER: expansion
+
+M: back-quoted-expr expand
+  expr>> expr command>> expansion
+  utf8 [ contents ] with-process-reader
+  " \n" split harvest ;
+
+: expansion ( command -- command ) [ expand ] map flatten ;
+
+: run-sword ( basic-expr -- )
+    command>> expansion unclip
+    "shell" lookup-word execute( arguments -- ) ;
+
+: run-foreground ( process -- )
+    [ try-process ] [ print-error drop ] recover ;
+
+: run-background ( process -- )
+    run-detached drop ;
+
+: run-basic-expr ( basic-expr -- )
+    <process>
+        over command>> expansion >>command
+        over stdin>>             >>stdin
+        over stdout>>            >>stdout
+        swap background>>
+        [ run-background ] [ run-foreground ] if ;
+
+: basic-chant ( basic-expr -- )
+    dup command>> first swords member?
+    [ run-sword ] [ run-basic-expr ] if ;
+
+: pipeline-chant ( pipeline-chant -- )
+    commands>> run-pipeline drop ;
+
+: chant ( obj -- )
+    dup basic-expr? [ basic-chant ] [ pipeline-chant ] if ;
+
+: prompt ( -- )
+    current-directory get write " $ " write flush ;
+
+DEFER: shell
+
+: handle ( input -- )
+    dup { f "exit" } member? [
+        drop
+    ] [
+        [
+            expr [ chant ] [ "ix: ignoring input" print ] if*
+        ] unless-empty shell
+    ] if ;
+
+: shell ( -- )
+    prompt readln handle ;
+
+: ix ( -- ) shell ;
+
+MAIN: ix

unmaintained/shell/shell.factor

@@ -1,140 +0,0 @@
-USING: kernel parser words continuations namespaces debugger
-sequences combinators splitting prettyprint system io io.files
-io.pathnames io.launcher io.directories io.encodings.utf8 io.pipes
-sequences.deep accessors multi-methods newfx shell.parser
-combinators.short-circuit eval environment ;
-IN: shell
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: cd ( args -- )
-  dup empty?
-    [ drop home set-current-directory ]
-    [ first     set-current-directory ]
-  if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: pwd ( args -- )
-  drop
-  current-directory get
-  print ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: swords ( -- seq ) { "cd" "pwd" } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: expand ( expr -- expr )
-
-METHOD: expand { single-quoted-expr } expr>> ;
-
-METHOD: expand { double-quoted-expr } expr>> ;
-
-METHOD: expand { variable-expr } expr>> os-env ;
-
-METHOD: expand { glob-expr }
-  expr>>
-  dup "*" =
-    [ drop current-directory get directory-files ]
-    [ ]
-  if ;
-
-METHOD: expand { factor-expr } expr>> eval>string ;
-
-DEFER: expansion
-
-METHOD: expand { back-quoted-expr }
-  expr>>
-  expr
-  command>>
-  expansion
-  utf8 <process-stream>
-  contents
-  " \n" split
-  "" remove ;
-
-METHOD: expand { object } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: expansion ( command -- command ) [ expand ] map flatten ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: run-sword ( basic-expr -- )
-  command>> expansion unclip "shell" lookup execute( arguments -- ) ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: run-foreground ( process -- )
-  [ try-process ] [ print-error drop ] recover ;
-
-: run-background ( process -- ) run-detached drop ;
-
-: run-basic-expr ( basic-expr -- )
-  <process>
-    over command>> expansion >>command
-    over stdin>>             >>stdin
-    over stdout>>            >>stdout
-  swap background>>
-    [ run-background ]
-    [ run-foreground ]
-  if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: basic-chant ( basic-expr -- )
-  dup command>> first swords member-of?
-    [ run-sword ]
-    [ run-basic-expr ]
-  if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: pipeline-chant ( pipeline-chant -- ) commands>> run-pipeline drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: chant ( obj -- )
-  dup basic-expr?
-    [ basic-chant    ]
-    [ pipeline-chant ]
-  if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: prompt ( -- )
-  current-directory get write
-  " $ " write
-  flush ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-DEFER: shell
-
-: handle ( input -- )
-  {
-    { [ dup f = ]      [ drop ] }
-    { [ dup "exit" = ] [ drop ] }
-    { [ dup "" = ]     [ drop shell ] }
-    { [ dup expr ]     [ expr chant shell ] }
-    { [ t ]            [ drop "ix: ignoring input" print shell ] }
-  }
-    cond ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: shell ( -- )
-  prompt
-  readln
-  handle ;
-  
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: ix ( -- ) shell ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-MAIN: ix