typeof := λ(: args FragmentList). (: (tail(
(let r TAny)
(match args (
()
( (FLSeq( rst f )) (tail(
(let rst-tt (maybe-deref(typeof rst)))
(let f-tt (maybe-deref(fragment::get-type f)))
(if (non-zero rst-tt) (tail(
(let r2 (t3( 'Cons_s rst-tt f-tt )))
(set r r2)
)) (
(set r f-tt)
))
)))
( _ () )
))
r
)) Type);
fragment-size-args := λ(: args FragmentList). (: (tail(
(match args (
()
( (FLSeq( rst f )) (tail(
(let f-tt (maybe-deref(fragment::get-type f)))
(let f-tt-sized (maybe-deref(typecheck-annotate-size f-tt)))
(let f-sized (maybe-deref(fragment::set-type( f f-tt-sized ))))(set f f-sized)
(set args (FLSeq(
(close(fragment-size-args rst))
f
)))
)))
( _ () )
))
args
)) FragmentList);
fragment-apply := λ(: ctx FContext)(: offset I64)(: k String)(: args FragmentList)(: direct-type Type)(: sloc AST). (: (tail(
(let args-sized (maybe-deref(fragment-size-args args)))(set args args-sized)
(let e-proto (maybe-deref(fragment::new())))
(let e-proto-2 (maybe-deref(fragment::set-context( e-proto ctx ))))(set e-proto e-proto-2)
(let e-proto-3 (maybe-deref(fragment::set-offset( e-proto offset ))))(set e-proto e-proto-3)
(let at (maybe-deref(typeof args)))
(if (non-zero at) () (tail(
(print 'Apply\s_s)(print k)(print args)
(let msg (clone-rope(SCons( (close(SAtom 'Untyped\sFragment\sArguments:\s_s)) (close(SAtom k)) ))))
(exit-error( msg sloc ))
)))
(let arrow (maybe-deref(fragment-context::lookup( ctx k at sloc ))))
(let arrow-tt (maybe-deref(fragment::get-type arrow)))
(let return-tt TAny)
(match (slot( arrow-tt 'Arrow_s )) (
()
( (TGround( 'Arrow_s (TypeSeq( (TypeSeq( TypeEOF lt )) rt )) )) (set return-tt rt) )
( _ (tail(
(print 'Apply\sDirect\sFragment\sIs\sNot\sAn\sArrow:\s_s)
(print k)(print '\s:\s_s)
(print arrow-tt)(print '\n_s)
)))
))
(let chain True_u8)
(match (slot( arrow-tt 'DontChain_s )) (
()
( (TGround( 'DontChain_s _ )) (set chain False_u8) )
( _ () )
))
(let lhs-type (typeof(fragment::get( arrow 'fragment_s ))))
(let tctx (unify( lhs-type direct-type )))
(let ctx-2 (union( ctx tctx )))(set ctx ctx-2)
(let return (maybe-deref(fragment-apply-direct( ctx arrow args e-proto chain ))))
(let comment (SAtom '\oCall\sFragment\s_s))
(set comment (SCons( (close comment) (close(SAtom k)) )))
(set comment (SCons( (close comment) (close(SAtom '\s:\s_s)) )))
(set comment (SCons( (close comment) (close(SAtom(to-string arrow-tt))) )))
(set comment (SCons( (close comment) (close(SAtom '\n\oArgument:\s_s)) )))
(set comment (SCons( (close comment) (close(SAtom k)) )))
(set comment (SCons( (close comment) (close(SAtom '\s:\s_s)) )))
(set comment (SCons( (close comment) (close(SAtom(to-string at))) )))
(set comment (SCons( (close comment) (close(SAtom '\n_s)) )))
(set comment (SCons( (close comment) (close(SAtom '\oReturn:\s_s)) )))
(set comment (SCons( (close comment) (close(SAtom k)) )))
(set comment (SCons( (close comment) (close(SAtom '\s:\s_s)) )))
(set comment (SCons( (close comment) (close(SAtom(to-string return-tt))) )))
(set comment (SCons( (close comment) (close(SAtom '\n_s)) )))
(let r2 (maybe-deref(fragment::set( return 'program_s (SCons(
(close comment)
(close(fragment::get( return 'program_s )))
))))))(set return r2)
(let r3 (maybe-deref(fragment::set-type( return return-tt ))))(set return r3)
return
)) Fragment);
fragment-destructure-lhs := λ(: ctx FContext)(: lhs S)(: args FragmentList). (: (tail(
(match lhs (
()
( (SCons( (SAtom 'Var_s) (SAtom k) )) (tail(
(let a-type (maybe-deref(typeof lhs)))
(match args (
()
( (FLSeq( _ f )) (tail(
(let ft (maybe-deref(fragment::get-type f)))
(if (non-zero ft) () (tail(
(print 'Fragment\sHas\sNo\sType:\n_s)
(print f)
(exit 1_u64)
)))
(let tctx (unify( a-type ft )))
(let ctx-2 (union( ctx tctx )))(set ctx ctx-2)
(let new-ctx (FCtxBind( (close ctx) k ft f )))(set ctx new-ctx)
)))
))
)))
( (SCons( (SAtom 'App_s) (SCons( lhs-rst (SCons( (SAtom 'Var_s) (SAtom k) )) )) )) (tail(
(let a-type TAny)
(match lhs (
()
( (SCons( (SAtom 'App_s) (SCons( _ binding )) )) (tail(
(let a-type-2 (maybe-deref(typeof binding)))
(set a-type a-type-2)
)))
))
(match args (
()
( (FLSeq( fl-rst f )) (tail(
(let ft (maybe-deref(fragment::get-type f)))
(if (non-zero ft) () (tail(
(print 'Fragment\sHas\sNo\sType:\n_s)
(print f)
(exit 1_u64)
)))
(let tctx (unify( a-type ft )))
(let ctx-2 (union( ctx tctx )))(set ctx ctx-2)
(let new-ctx (FCtxBind( (close ctx) k ft f )))(set ctx new-ctx)
(set args fl-rst)
)))
))
(let ctx-3 (maybe-deref(fragment-destructure-lhs( ctx lhs-rst args ))))(set ctx ctx-3)
)))
( SNil () )
( _ (tail(
(print 'Unexpected\sDestructure\sLHS:\s_s)
(print lhs)(print '\n_s)
(exit 1_u64)
)))
))
ctx
)) FContext);
fragment-apply-direct := λ(: ctx FContext)(: arrow Fragment)(: args FragmentList)(: e-proto Fragment)(: chain U8). (: (tail(
(match (maybe-deref(fragment::get( arrow 'fragment_s ))) (
()
( (SCons( (SAtom 'Abs_s) (SCons( lhs rhs )) )) (tail(
(let f-ctx-2 (maybe-deref(fragment-destructure-lhs( ctx lhs args ))))
(let f-app (maybe-deref(fragment::render( f-ctx-2 rhs e-proto ))))
(set e-proto f-app)
)))
( _ (tail(
(print 'Invalid\sFragment\sApplied:\n_s)
(print arrow)(print '\n_s)
)))
))
(if (==( chain True_u8 )) (tail(
(let r (maybe-deref(fragment-chain( args e-proto ))))
(set e-proto r)
)) ())
e-proto
)) Fragment);
fragment::chain := λ(: l Fragment)(: r Fragment). (: (tail(
(let e1 (maybe-deref(fragment::set-context(
l
(maybe-deref(fragment::get-context( r )))
))))
(if (non-zero(fragment::get( r 'frame_s ))) (tail(
(let e1-2 (maybe-deref(fragment::set(
e1 'frame_s
(SCons(
(close(fragment::get( l 'frame_s )))
(close(fragment::get( r 'frame_s )))
))
))))
(set e1 e1-2)
)) ())
(if (non-zero(fragment::get( r 'unframe_s ))) (tail(
(let e1-3 (maybe-deref(fragment::set(
e1 'unframe_s
(SCons(
(close(fragment::get( l 'unframe_s )))
(close(fragment::get( r 'unframe_s )))
))
))))
(set e1 e1-3)
)) ())
(if (non-zero(fragment::get( r 'program_s ))) (tail(
(let e1-4 (maybe-deref(fragment::set(
e1 'program_s
(SCons(
(close(fragment::get( l 'program_s )))
(close(fragment::get( r 'program_s )))
))
))))
(set e1 e1-4)
)) ())
(let e1-5 (maybe-deref(fragment::set-context( e1
(maybe-deref(fragment::get-context r))
))))(set e1 e1-5)
(let e1-6 (maybe-deref(fragment::set-offset( e1
(maybe-deref(fragment::get-offset r))
))))(set e1 e1-6)
(let e1-7 (maybe-deref(fragment::set(
e1 'expression_s
(maybe-deref(fragment::get( r 'expression_s )))
))))(set e1 e1-7)
e1
)) Fragment);
#TODO remove indirect reference of return value
fragment-chain := λ(: fragment-ctx FragmentList)(: e Fragment). (: (tail(
(while (non-zero fragment-ctx) (match fragment-ctx (
()
( (FLSeq( rst cf )) (tail(
(let e1 (maybe-deref(fragment::chain( cf e ))))
(set e e1)
(set fragment-ctx rst)
)))
)))
(close e)
)) Fragment[]);