extra/modern/out/out.factor

   1 ! Copyright (C) 2017 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs combinators.short-circuit
   4 constructors continuations fry io io.encodings.utf8 io.files
   5 io.streams.string kernel modern modern.paths modern.slices
   6 multiline prettyprint sequences sequences.extras splitting
   7 strings vocabs.loader ;
   8 IN: modern.out
   9
  10 : token? ( obj -- ? )
  11     { [ slice? ] [ seq>> string? ] } 1&& ;
  12
  13 TUPLE: renamed slice string ;
  14 CONSTRUCTOR: <renamed> renamed ( slice string -- obj ) ;
  15
  16 : trim-before-newline ( seq -- seq' )
  17     dup [ CHAR: \s = not ] find
  18     { CHAR: \r CHAR: \n } member?
  19     [ tail-slice ] [ drop ] if ;
  20
  21 : write-whitespace ( last obj -- )
  22     swap
  23     [ swap slice-between ] [ slice-before ] if*
  24     trim-before-newline io:write ;
  25
  26 GENERIC: write-literal* ( last obj -- last' )
  27 M: slice write-literal* [ write-whitespace ] [ write ] [ ] tri ;
  28 M: array write-literal* [ write-literal* ] each ;
  29 M: renamed write-literal* [ slice>> write-whitespace ] [ string>> write ] [ slice>> ] tri ; ! for refactoring
  30
  31
  32
  33 DEFER: map-literals
  34 : (map-literals) ( obj quot: ( obj -- obj' ) -- seq )
  35     over [ array? ] any? [
  36         [ call drop ] [ map-literals ] 2bi
  37     ] [
  38         over array? [ map-literals ] [ call ] if
  39     ] if ; inline recursive
  40
  41 : map-literals ( obj quot: ( obj -- obj' ) -- seq )
  42     '[ _ (map-literals) ] map ; inline recursive
  43
  44
  45
  46 ! Start with no slice as ``last``
  47 : write-literal ( obj -- ) f swap write-literal* drop ;
  48
  49 : write-modern-string ( seq -- string )
  50     [ write-literal ] with-string-writer ; inline
  51
  52 : write-modern-path ( seq path -- )
  53     utf8 [ write-literal nl ] with-file-writer ; inline
  54
  55 : write-modern-vocab ( seq vocab -- )
  56     vocab-source-path write-modern-path ; inline
  57
  58 : rewrite-path ( path quot: ( obj -- obj' ) -- )
  59     ! dup print
  60     '[ [ path>literals _ map-literals ] [ ] bi write-modern-path ]
  61     [ drop . ] recover ; inline recursive
  62
  63 : rewrite-string ( string quot: ( obj -- obj' ) -- )
  64     ! dup print
  65     [ string>literals ] dip map-literals write-modern-string ; inline recursive
  66
  67 : rewrite-paths ( seq quot: ( obj -- obj' ) -- ) '[ _ rewrite-path ] each ; inline recursive
  68
  69 : rewrite-vocab ( vocab quot: ( obj -- obj' ) -- )
  70     [ [ vocab>literals ] dip map-literals ] 2keep drop write-modern-vocab ; inline recursive
  71
  72 : rewrite-string-exact ( string -- string' )
  73     string>literals write-modern-string ;
  74
  75 ![[
  76 : rewrite-path-exact ( path -- )
  77     [ path>literals ] [ ] bi write-modern-path ;
  78
  79 : rewrite-vocab-exact ( name -- )
  80     vocab-source-path rewrite-path-exact ;
  81
  82 : rewrite-paths ( paths -- )
  83     [ rewrite-path-exact ] each ;
  84 ]]
  85
  86 : strings-core-to-file ( -- )
  87     core-vocabs
  88     [ ".private" ?tail drop vocab-source-path utf8 file-contents ] zip-with
  89     [ "[========[" dup matching-delimiter-string surround ] assoc-map
  90     [
  91         first2 [ "VOCAB: " prepend ] dip " " glue
  92     ] map
  93     [ "    " prepend ] map "\n\n" join
  94     "<VOCAB-ROOT: factorcode-core \"https://factorcode.org/git/factor.git\" \"core/\"\n"
  95     "\n;VOCAB-ROOT>" surround "resource:core-strings.factor" utf8 set-file-contents ;
  96
  97 : parsed-core-to-file ( -- )
  98     core-vocabs
  99     [ vocab>literals ] zip-with
 100     [
 101         first2 [ "<VOCAB: " prepend ] dip
 102         >strings
 103         ! [ 3 head ] [ 3 tail* ] bi [ >strings ] bi@ { "..." } glue
 104         ";VOCAB>" 3array
 105     ] map 1array
 106
 107     { "<VOCAB-ROOT:" "factorcode-core" "https://factorcode.org/git/factor.git" "core/" }
 108     { ";VOCAB-ROOT>" } surround "resource:core-parsed.factor" utf8 [ ... ] with-file-writer ;