! Copyright (C) 2008 Marc Fauconneau.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences math hints math.ranges locals sequences.private 
       math.functions math.private kernel.private assocs math.parser 
       arrays ;
USING: lexer namespaces parser strings.parser splitting compiler.units 
       io prettyprint quotations accessors strings stack-checker combinators
       effects ;
IN: interpolate

: lexer-rest ( lexer -- rest )
  [ [ text>> ] [ line>> ] bi cut nip ]
  [ [ line-text>> ] [ column>> ] bi cut nip ]
  bi prefix "\n" join ;

: (parse-quot-body) ( str -- str' quot )
  " ]" append
  string-lines <lexer> lexer set
  \ ] parse-until >quotation 
  lexer get lexer-rest 1 cut nip 2 cut* drop
  swap ;

: shadow ( var quot -- )
  swap [ get ] keep 2slip set ;

: parse-quot-body ( acc str -- acc quot rest )
  lexer [ (parse-quot-body) ] shadow ;

: wordify-quot-ends ( str -- str' )
  "]" split "] " join ;

: 1to-string ( obj -- str )
  dup string? [ ] [ unparse ] if ;

: 3to-string ( char pad obj -- str )
  1to-string -rot
  swap first [ prepend ] padding >string ;

: 2to-string ( pad obj -- str )
  " " -rot 3to-string ;

: to-string-curry ( quot -- quot' )
  ! dup infer [ out>> ] [ in>> ] bi [ length ] bi@
  ! drop ! 0 assert= ! make sure we have ( -- ... )
  dup infer effect-height
  { { [ dup 1 = ] [ drop [ 1to-string ] compose ] }
    { [ dup 2 = ] [ drop [ 2to-string ] compose ] }
    { [ dup 3 = ] [ drop [ 3to-string ] compose ] }
    [ "I: quotes have to push between 1 and 3 elements" throw ]
  } cond ;
  

: (interpolate) ( vec str -- vec )
  dup [ CHAR: [ = ] find drop dup
  [ cut rest parse-quot-body swap 
    [ [ ] curry ] 2dip
    [ to-string-curry ] dip
    [ 2array append ] dip
    (interpolate)
  ] [ drop [ ] curry suffix ] if ;

: interpolate ( acc str -- acc )
  wordify-quot-ends
  { } clone swap (interpolate)
  [ { } ] [ [ dip swap suffix ] curry compose ] reduce
  [ "" join ] compose parsed 
  \ call parsed ;

: I: scan-word \ " = [ parse-string interpolate ] [ "I: string expected" throw ] if ; parsing