
fragment-substitute-context := λ ctx fragment-rhs . (match fragment-rhs (
   ()
   ( () () )
   ( (Variable Dontchain) () )
   ( DontChain () )
   ( (Variable( v )) (tail(
      (while ctx (tail(
         (if (eq( v (head (tail ctx)) )) (
            (set v (expr::get-expr (tail (tail ctx))))
         ) ())
         (set ctx (head ctx))
      )))
      v
   )))
   ( ('label v) (tail(
      (while ctx (tail(
         (if (eq( v (head (tail ctx)) )) (
            (set v (expr::get-expr (tail (tail ctx))))
         ) ())
         (set ctx (head ctx))
      )))
      v
   )))
   ( (App( (Variable 'label) (Variable v) )) (tail(
      (while ctx (tail(
         (if (eq( v (head (tail ctx)) )) (
            (set v (expr::get-expr (tail (tail ctx))))
         ) ())
         (set ctx (head ctx))
      )))
      v
   )))
   ( ('inv( x )) (tail(
      (set x (fragment-substitute-context( ctx x )))
      (i2s(inv( (s2i x) )))
   )))
   ( (App( (Variable 'inv) x )) (tail(
      (set x (fragment-substitute-context( ctx x )))
      (i2s(inv( (s2i x) )))
   )))
   ( ('+( l r )) (tail(
      (set l (fragment-substitute-context( ctx l )))
      (set r (fragment-substitute-context( ctx r )))
      (i2s(add( (s2i l) (s2i r) )))
   )))
   ( (App( (Variable '+) (App( l r )) )) (tail(
      (set l (fragment-substitute-context( ctx l )))
      (set r (fragment-substitute-context( ctx r )))
      (i2s(add( (s2i l) (s2i r) )))
   )))
   ( ('*( l r )) (tail(
      (set l (fragment-substitute-context( ctx l )))
      (set r (fragment-substitute-context( ctx r )))
      (i2s(mul( (s2i l) (s2i r) )))
   )))
   ( (App( (Variable '*) (App( l r )) )) (tail(
      (set l (fragment-substitute-context( ctx l )))
      (set r (fragment-substitute-context( ctx r )))
      (i2s(mul( (s2i l) (s2i r) )))
   )))
   ( ('/( l r )) (tail(
      (set l (fragment-substitute-context( ctx l )))
      (set r (fragment-substitute-context( ctx r )))
      (i2s(div( (s2i l) (s2i r) )))
   )))
   ( (App( (Variable '/) (App( l r )) )) (tail(
      (set l (fragment-substitute-context( ctx l )))
      (set r (fragment-substitute-context( ctx r )))
      (i2s(div( (s2i l) (s2i r) )))
   )))
   ( (App( (Variable 'range) (App( low high )) )) (tail(
      (set low (fragment-substitute-context( ctx low )))
      (set high (fragment-substitute-context( ctx high )))
      (local return)
      (while (not(eq( low high ))) (tail(
         (set return (return low))
         (set low (i2s(inc(s2i( low )))) )
      )))
      (reverse-list return)
   )))
   ( (App(
        (App(
           (App(
              (App(
                 (Variable 'for)
                 (Variable v)
              ))
              (Variable 'in)
           ))
           iterator
        ))
        body
     )) (tail(
      (local result)
      (set iterator (fragment-substitute-context( ctx iterator )))
      (while iterator (tail(
         (local inner-e)
         (set inner-e (expr::new()))
         (set inner-e (expr::set-expr( inner-e (head iterator) )))
         (local inner-ctx)
         (set inner-ctx (ctx (
            (v inner-e)
         )))
         (set result (result (
            (fragment-substitute-context( inner-ctx body ))
         )))
         (set iterator (tail iterator))
      )))
      result
   )))
   ( (App(
        (App(
           (App(
              (Variable 'if-eq)
              l
           ))
           r
        ))
        body
     )) (tail(
      (set l (fragment-substitute-context( ctx l )))
      (set r (fragment-substitute-context( ctx r )))
      (local result)
      (if (eq( l r )) (
         (set result (
            (fragment-substitute-context( ctx body ))
         ))
      ) ())
      result
   )))
   ( ('.expression v ) (tail(
      (if (is-atom v) (
         (while ctx (tail(
            (if (eq( v (head (tail ctx)) )) (
               (set v (expr::get-expr (tail (tail ctx))))
            ) ())
            (set ctx (head ctx))
         )))
      ) (
         (set v (fragment-substitute-context( ctx v )))
      ))
      v
   )))
   ( (App( (Variable '.expression) (Variable v) )) (tail(
      (while ctx (tail(
         (if (eq( v (head (tail ctx)) )) (
            (set v (expr::get-expr (tail (tail ctx))))
         ) ())
         (set ctx (head ctx))
      )))
      v
   )))
   ( (App( (Variable '.program) (Variable v) )) (tail(
      (while ctx (tail(
         (if (eq( v (head (tail ctx)) )) (
            (set v (expr::get-prog (tail (tail ctx))))
         ) ())
         (set ctx (head ctx))
      )))
      v
   )))
   ( (Literal v) (
      (match v (
         ()
         (\\[ \[)
         (\\] \])
         (\\s \s)
         (\\t \t)
         (\\n \n)
         (u u)
      ))
   ))
   ( (App( l r )) (
      (fragment-substitute-context( ctx l ))
      (fragment-substitute-context( ctx r ))
   ))
   ( (l r) (
      (fragment-substitute-context( ctx l ))
      (fragment-substitute-context( ctx r ))
   ))
   ( u u )
));

fragment-gensym-labels := λctx fragment . (match fragment (
   ()
   (() ctx)
   ( ('label l) (tail(
     (set ctx (ctx (
        (l (expr::set-expr( () (uuid()) )))
     )))
     ctx
   )))
   ( (App( (Variable 'label) (Variable l) )) (tail(
     (set ctx (ctx (
        (l (expr::set-expr( () (uuid()) )))
     )))
     ctx
   )))
   ( (l r) (tail(
     (set ctx (fragment-gensym-labels( ctx l )))
     (set ctx (fragment-gensym-labels( ctx r )))
     ctx
   )))
   ( x ctx )
));

fragment-apply-context := λctx fragment-rhs e . (tail(
   (assert-typeof( 'fragment-apply-context::ctx ctx List<[Atom,StrictExpr]> ))
   (assert-typeof( 'fragment-apply-context::e e StrictExpr ))
   (local return)
   (set ctx (fragment-gensym-labels( ctx fragment-rhs )))
   (set return (match fragment-rhs (
      ()
      ( Nil (
         e
      ))
      ( (App( (App( (Literal ':) fe )) ft )) (
         (fragment-apply-context( ctx fe e ))
      ))
      ( (App( (Variable '.program) f )) (
         (expr::set-prog( e (
            (expr::get-prog e)
            (fragment-substitute-context( ctx f ))
         )))
      ))
      ( (App( inner (App( (Variable '.program) f )) )) (
         (fragment-apply-context(
            ctx inner
            (expr::set-prog( e (
               (expr::get-prog e)
               (fragment-substitute-context( ctx f ))
            )))
         ))
      ))
      ( (App( (Variable '.expression) f )) (
         (expr::set-expr( e (
            (fragment-substitute-context( ctx f ))
         )))
      ))
      ( (App( inner (App( (Variable '.expression) f )) )) (
         (fragment-apply-context(
            ctx inner
            (expr::set-expr( e (
               (fragment-substitute-context( ctx f ))
            )))
         ))
      ))
      ( u (fail (UnknownSubstituteFragment fragment-rhs)))
   )))
   (assert-typeof( 'fragment-apply-context::return return StrictExpr ))
   return
));

fragment-is-dont-chain := λ f . (match f (
   ()
   ( DontChain DontChain )
   ( (l r) (
      if (fragment-is-dont-chain l) DontChain
         (fragment-is-dont-chain r)
   ))
   ( _ () )
));

fragment-apply := λ ctx function-name function-type function-args e-proto . (tail(
   (assert-typeof( 'fragment-apply::e-proto e-proto StrictExpr ))
   (assert-typeof( 'fragment-apply::function-name function-name Atom ))
   (assert-typeof( 'fragment-apply::function-args function-args List<StrictExpr> ))
   (local arrow)
   (set arrow (get-strict-function( ctx function-name function-type )))
   (if arrow () (tail(
      (print-s NoSuchFragment)(print-s \s)
      (print-s function-name)(print-s \s)
      (print-s function-type)(print-s \n)
      (exit 1)
   )))
   (local dont-chain)
   (match (typecheck-slot( function-type DontChain )) (
      ()
      ( DontChain (set dont-chain DontChain))
   ))
   (if (fragment-is-dont-chain arrow) (
      (set dont-chain DontChain)
   ) ())
   (local return)
   (set return (fragment-apply-direct( arrow function-args e-proto dont-chain )))
   (assert-typeof( 'fragment-apply::return return StrictExpr ))
   return
));

fragment-chain := λ fragment-ctx e . (tail(
   (assert-typeof( 'fragment-chain::fragment-ctx fragment-ctx List<[Atom,StrictExpr]> ))
   (assert-typeof( 'fragment-chain::e e StrictExpr ))
   (while fragment-ctx (tail(
      (set e (expr::chain( (tail(tail fragment-ctx)) e )))
      (set fragment-ctx (head fragment-ctx))
   )))
   e
));

fragment-apply-direct := λ fragment function-args e-proto dont-chain . (tail(
   (assert-typeof( 'fragment-apply-direct::fragment fragment Fragment ))
   (assert-typeof( 'fragment-apply-direct::function-args function-args List<StrictExpr> ))
   (assert-typeof( 'fragment-apply-direct::e-proto e-proto StrictExpr ))
   (match fragment (
      ()
      ( (Fragment( (Lambda( lhs
           (App( (App( (Literal ':) rhs )) rtype ))
        )) )) (tail(
         (set rtype (typecheck-infer-type-compound rtype))
         (local fctx)
         (set fctx (fragment-destructure-lhs( () lhs function-args )))
         (assert-typeof( 'fragment-apply-direct::fctx fctx List<[Atom,StrictExpr]> ))
         (local e-seed)
         (set e-seed (expr::new()))
         (set e-seed (expr::set-offset( e-seed (expr::get-offset e-proto) )))
         (set e-seed (expr::set-context( e-seed (expr::get-context e-proto) )))
         (local e-return)
         (set e-return (fragment-apply-context( fctx rhs e-seed )))
         (if dont-chain () (
            (set e-return (fragment-chain( fctx e-return )))
         ))
         (assert-typeof( 'fragment-apply-direct::return e-return StrictExpr ))
         (set e-return (expr::set-type( e-return rtype )))
         e-return
      )))
      ( (Fragment( (Lambda( lhs rhs )) )) (tail(
         (local fctx)
         (set fctx (fragment-destructure-lhs( () lhs function-args )))
         (assert-typeof( 'fragment-apply-direct::fctx fctx List<[Atom,StrictExpr]> ))
         (local e-seed)
         (set e-seed (expr::new()))
         (set e-seed (expr::set-offset( e-seed (expr::get-offset e-proto) )))
         (set e-seed (expr::set-context( e-seed (expr::get-context e-proto) )))
         (local e-return)
         (set e-return (fragment-apply-context( fctx rhs e-seed )))
         (if dont-chain () (
            (set e-return (fragment-chain( fctx e-return )))
         ))
         (assert-typeof( 'fragment-apply-direct::return e-return StrictExpr ))
         e-return
      )))
      ( u (fail (InvalidFragment fragment)))
   ))
));

fragment-bind-types := λctx tctx . (match tctx (
   ()
   ( (Bind( k v )) (tail(
      (local e)
      (set e (expr::new()))
      (set e (expr::set-expr( e v )))
      (ctx (k e))
   )))
   ( () ctx )
   ( Accept ctx )
   ( (l r) (tail(
      (set ctx (fragment-bind-types( ctx l )))
      (set ctx (fragment-bind-types( ctx r )))
      ctx
   )))
));

fragment-destructure-lhs := λ ctx lhs args . (tail(
   (assert-typeof( 'fragment-destructure-lhs::ctx ctx List<[Atom,StrictExpr]> ))
   (assert-typeof( 'fragment-destructure-lhs::args args List<StrictExpr> ))
   (assert-not-typeof( 'fragment-destructure-lhs::args args Nil ))
   (local return)
   (set return (match lhs (
      ()
      ( Nil (tail(
         (set ctx ())
         ctx
      )))
      ( (App( (App( (Literal ':) (Variable vname) )) vtype )) (tail(
         (local ctype)
         (set ctype (typecheck-infer-type-compound vtype))
         (local tctx)
         (set tctx (typecheck-unify-args( ctype (expr::get-type (tail args)) )))
         (set ctx (fragment-bind-types( ctx tctx )))
         (set ctx ( ctx (vname (tail args)) ))
         ctx
      )))
      ( (App( inner (App( (App( (Literal ':) (Variable vname) )) vtype )) )) (tail(
         (local ctype)
         (set ctype (typecheck-infer-type-compound vtype))
         (local tctx)
         (set tctx (typecheck-unify-args( ctype (expr::get-type (tail args)) )))
         (set ctx (fragment-bind-types( ctx tctx )))
         (set ctx ( ctx (vname (tail args)) ))
         (set ctx (fragment-destructure-lhs( ctx inner (head args) )))
         ctx
      )))
      ( u (fail (PatternDefaultCase 'fragment-destructure-lhs u)))
   )))
   (assert-typeof( 'fragment-destructure-lhs::return return List<[Atom,StrictExpr]> ))
   return
));

fragment-get-local := λctx v offset . (tail(
   (assert-typeof( 'fragment-get-local::ctx ctx Context ))
   (assert-typeof( 'fragment-get-local::v v Atom ))
   (assert-typeof( 'fragment-get-local::offset offset Atom ))
   (local r)
   (match (context::lookup( ctx v () )) (
      ()
      ( (Label( uid )) (tail(
         (set r (expr::new()) )
         (set r (expr::set-expr( r uid )))
         (set r (expr::set-context( r ctx )))
         (set r (expr::set-offset( r offset )))
      )))
      ( (LocalVariable( loffset )) (tail(
         (set r (expr::new()) )
         (set r (expr::set-expr( r loffset )))
         (set r (expr::set-context( r ctx )))
         (set r (expr::set-offset( r offset )))
      )))
      ( (GlobalVariable( uid )) (tail(
         (set r (expr::new()) )
         (set r (expr::set-expr( r uid )))
         (set r (expr::set-context( r ctx )))
         (set r (expr::set-offset( r offset )))
      )))
      ( u (fail (InvalidFragmentLocal v u)))
   ))
   (assert-typeof( 'fragment-get-local::return r StrictExpr ))
   r
));
