%% An Erlang module containing support functions for Yhc Core Erlang back-end. -module (yc2erl). -export ([hslist/1, force/1, cmp_w/2, cmp_l/2, cmp_c/2, cast_lf/1, cast_df/1, quot_w/2, quot_l/2, rem_w/2, rem_l/2, div_w/2, mod_w/2, div_l/2, mod_l/2, shows_w/3, shows_l/3, cast_wl/1, cast_lw/1, sel_elem/3, strict_app/2, uni_cat/1, uni_cat_ord/1, isaln_c/1, seq/2, div_f/2]). -compile(inline). -include ("unitable.hrl"). %% Force a Haskell-produced object to WHNF. %% Some expressions are outright irreducible. These are tagged with %% '@ird', and attention will be paid to them only when they are %% applied to anything. force ({'@ird', A}) -> ({'@ird', A}); %% CAFs are forced by calling them. force ({'@fun', M, F, 0}) -> force ((M:F) ()); force ({'@prim', M, F, 0}) -> force ((M:F) ()); %% Applications are tagged with '@ap'. %% Application of a CAF to anything causes CAF to evaluate first. This is just %% an accelerator pattern; the default entry might handle this as well. force ({'@ap', {'@fun', M, F, 0}, []}) -> force ((M:F) ()); force ({'@ap', {'@prim', M, F, 0}, []}) -> force ((M:F) ()); force ({'@ap', {'@fun', M, F, 0}, Args}) -> force ({'@ap', (M:F) (), Args}); force ({'@ap', {'@prim', M, F, 0}, Args}) -> force ({'@ap', (M:F) (), Args}); %% Application of another application to some arguments. Concatenate %% arguments and proceed on. force ({'@ap', {'@ap', F, Args1}, Args2}) -> force ({'@ap', F, Args1 ++ Args2}); %% Application of a data constructor is irreducible when undersaturated. %% If the constructor is nullary, it is returned as an atom. If application %% is saturated, it becomes a tuple with first member being constructor %% tag, and second member is a tuple with data fields. force ({'@tag', T, 0}) -> T; force (X = {'@ap', {'@tag', T, A}, Args}) -> Nargs = length (Args), if Nargs == A -> {T, erlang:list_to_tuple (Args)}; Nargs < A -> {'@ird', X}; true -> erlang:error (oversaturated, [X]) end; %% Saturated applications have somewhat shorter path. force ({'@sat', FP, M, F, Args}) -> force (do_app (FP, M, F, Args)); %% Application of a function/primitive to some number of arguments. It may be %% saturated, undersaturated, or oversaturated. Undersaturated applications %% are marked as irreducible. Oversaturated applications use some number of %% arguments, and then result is applied to the remainder. Saturated applications %% are called right away. force (X = {'@ap', {FP, M, F, A}, Args}) -> if FP == '@fun' orelse FP == '@prim' -> Nargs = length (Args), if Nargs == A -> force (do_app (FP, M, F, Args)); %% do the actual application Nargs < A -> {'@ird', X}; %% mark as irreducible true -> %% oversaturated {A1, A2} = lists:split (A, Args), force ({'@ap', do_app (FP, M, F, A1), A2}) end; true -> X %% not a valid application end; %% Expressions marked as irreducible are given second chance. force ({'@ap', {'@ird', X}, Args}) -> force ({'@ap', X, Args}); %% Application of anything to arguments results in forcing the "anything" first. force ({'@ap', X, Args}) -> force ({'@ap', force (X), Args}); %% An Erlang list lazily converted to a Haskell list. force ([H|T]) -> {'.CONS', {H, T}}; force ([]) -> '.EOL'; %% Anything else passes as is (irreducible). force (X) -> X. %% Do actual function application. Difference between functions and primitives: %% primitives' arguments are forced before passing on to the primitive. %% Function's arguments go as they are. do_app ('@fun', M, F, Args) -> erlang:apply (M, F, Args); do_app ('@prim', M, F, Args) -> erlang:apply (M, F, lists:map (fun force/1, Args)). %% Convert a Haskell list (.CONS/.EOL application) %% to Erlang-consumable form. The list must be finite otherwise the function %% would hang. List elements will be forced to their WHNF's as well (but hslist %% will not implicitly be applied to them). hslist ({'@tag', '.EOL', 0}) -> []; hslist ('.EOL') -> []; hslist ([]) -> []; hslist ([H|T]) -> [H | hslist (T)]; hslist ({'.CONS', {H, T}}) -> [force (H) | hslist (T)]; hslist (A = {'@sat', _FP, _M, _F, _Args}) -> hslist (force (A)); hslist (A = {'@ap', _Func, _Args}) -> hslist (force (A)); hslist (A = {'@fun', _M, _F, 0}) -> hslist (force (A)); hslist ({A}) -> hslist (A); hslist (X) -> throw ({"Not a Haskell list", X}). %% Support for normal Core primitives. divzero () -> erlang:throw ({'Prelude;ArithException', {'Prelude;DivideByZero'}}). cmp_l (A, B) -> cmp_w (A, B). cmp_c (A, B) -> cmp_w (A, B). cmp_w (A, B) -> if A > B -> '.GT'; A < B -> '.LT'; true -> '.EQ' end. quot_w (A, B) -> if B == 0 -> divzero (); true -> A div B end. quot_l (A, B) -> quot_w (A, B). rem_w (A, B) -> if B == 0 -> divzero (); true -> A rem B end. rem_l (A, B) -> rem_w (A, B). %% The following code for flooring division/modulus was proposed by Igor Ribeiro Sucupira, %% and it is also based on the Hugs implementation (in C) of the same. div_l (A, B) -> div_w (A, B). div_w (A, B) -> if B == 0 -> divzero (); true -> R = A rem B, X = A div B, if (B < 0 andalso R > 0) orelse (B > 0 andalso R < 0) -> X - 1; true -> X end end. mod_l (A, B) -> mod_w (A, B). mod_w (A, B) -> if B == 0 -> divzero (); true -> R = A rem B, if (R < 0 andalso B > 0) orelse (R > 0 andalso B < 0) -> R + B; true -> R end end. %% Emulation of showsPrec-like functions (primShowsInt etc.). Hugs has these as primitives. %% These functions ignore their first argument (precedence), convert their second argument %% to string representation (that is, integer_to_list and such are used on Erlang side), %% and the third argument is expected to be a String that will follow the result of conversion. %% We make a shortcut here, assuming that the third argument is a finite list, forcing %% its evaluation. If this is incorrect (time will show) then strictness of this primitive %% on its third argument should be removed. shows_gen (CFunc, CVal, Next) -> Val = CFunc (CVal), NList = hslist (Next), {Val ++ NList}. shows_w (_, CVal, Next) -> shows_gen ({'erlang','integer_to_list'}, CVal, Next). shows_l (_, CVal, Next) -> shows_gen ({'erlang','integer_to_list'}, CVal, Next). %% No difference between Haskell's Int and Integer, so casts are identity functions. cast_wl (A) -> A. cast_lw (A) -> A. cast_df (A) -> A. cast_lf (A) -> float (A). %% Regular math. div_f (A, B) -> A / B. %% Select a numbered component out of a data structure (tagged tuple). %% We make a shortcut here: value of the tag (that is supposed to be the first %% argument of this primitive) is ignored, so no validation is done. sel_elem (_, {_D, Fs}, N) -> erlang:element (N, Fs). %% Strict application. Since thunks are not updateable in this implementation, %% just applies the function to its argument forcing the latter. strict_app (F, A) -> {'@ap', F, [force (A)]}. %% Binary search using a large tuple as an indexable array. %% Based on http://ruslanspivak.com/2007/08/15/my-erlang-binary-search/ %% In the original code, lists:nth has been replaced with erlang:element. %% Also a comparison function has been added to the function's parameters. %% The comparison function should return negative when first arg less than second, etc. binsearch (List, Key, Fcomp, LowerBound, UpperBound) -> if UpperBound < LowerBound -> failed; true -> Mid = (LowerBound + UpperBound) div 2, Item = erlang:element (Mid, List), C = Fcomp (Key, Item), if C < 0 -> binsearch (List, Key, Fcomp, LowerBound, Mid-1); C > 0 -> binsearch (List, Key, Fcomp, Mid+1, UpperBound); true -> Item end end. %% Find a character's Unicode category via binary search. comp (Char, {Base, Length, _Props}) -> if Char < Base -> -1; Char >= Base + Length -> 1; true -> 0 end. uni_cat (C) -> binsearch (char_block(), C, fun comp/2, 1, ?NUM_BLOCKS). %% Ordering of Unicode categories. Same as in Hugs (src/char.c). uni_cat_ord ('GENCAT_Lu') -> 1; %% Letter, Uppercase uni_cat_ord ('GENCAT_Ll') -> 2; %% Letter, Lowercase uni_cat_ord ('GENCAT_Lt') -> 3; %% Letter, Titlecase uni_cat_ord ('GENCAT_Lm') -> 4; %% Letter, Modifier uni_cat_ord ('GENCAT_Lo') -> 5; %% Letter, Other uni_cat_ord ('GENCAT_Mn') -> 6; %% Mark, Non-Spacing uni_cat_ord ('GENCAT_Mc') -> 7; %% Mark, Spacing Combining uni_cat_ord ('GENCAT_Me') -> 8; %% Mark, Enclosing uni_cat_ord ('GENCAT_Nd') -> 9; %% Number, Decimal uni_cat_ord ('GENCAT_Nl') -> 10; %% Number, Letter uni_cat_ord ('GENCAT_No') -> 11; %% Number, Other uni_cat_ord ('GENCAT_Pc') -> 12; %% Punctuation, Connector uni_cat_ord ('GENCAT_Pd') -> 13; %% Punctuation, Dash uni_cat_ord ('GENCAT_Ps') -> 14; %% Punctuation, Open uni_cat_ord ('GENCAT_Pe') -> 15; %% Punctuation, Close uni_cat_ord ('GENCAT_Pi') -> 16; %% Punctuation, Initial quote uni_cat_ord ('GENCAT_Pf') -> 17; %% Punctuation, Final quote uni_cat_ord ('GENCAT_Po') -> 18; %% Punctuation, Other uni_cat_ord ('GENCAT_Sm') -> 19; %% Symbol, Math uni_cat_ord ('GENCAT_Sc') -> 20; %% Symbol, Currency uni_cat_ord ('GENCAT_Sk') -> 21; %% Symbol, Modifier uni_cat_ord ('GENCAT_So') -> 22; %% Symbol, Other uni_cat_ord ('GENCAT_Zs') -> 23; %% Separator, Space uni_cat_ord ('GENCAT_Zl') -> 24; %% Separator, Line uni_cat_ord ('GENCAT_Zp') -> 25; %% Separator, Paragraph uni_cat_ord ('GENCAT_Cc') -> 26; %% Other, Control uni_cat_ord ('GENCAT_Cf') -> 27; %% Other, Format uni_cat_ord ('GENCAT_Cs') -> 28; %% Other, Surrogate uni_cat_ord ('GENCAT_Co') -> 29; %% Other, Private Use uni_cat_ord ('GENCAT_Cn') -> 20. %% Other, Not Assigned %% Unicode category primitives. Based on Hugs implementation. isaln_c (C) -> case uni_cat (C) of failed -> false; {_, _, {Cat, _, _, _}} -> uni_cat_ord (Cat) =< uni_cat_ord ('GENCAT_No') end. %% Sequencing. Just forces the first argument, and then returns the second. seq (A, B) -> force (A), B.