Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

271 lines (236 sloc) 7.599 kb
(function(primitives, ast, interpreter){
primitives.prim = function(env) {
// data Char#
// gtChar# :: Char# -> Char# -> Bool
env.bind("gtChar#", ["a", "b"], gtPrim);
// geChar# :: Char# -> Char# -> Bool
env.bind("geChar#", ["a", "b"], gePrim);
// eqChar# :: Char# -> Char# -> Bool
env.bind("eqChar#", ["a", "b"], eqPrim);
// neChar# :: Char# -> Char# -> Bool
env.bind("neChar#", ["a", "b"], nePrim);
// ltChar# :: Char# -> Char# -> Bool
env.bind("ltChar#", ["a", "b"], ltPrim);
// leChar# :: Char# -> Char# -> Bool
env.bind("leChar#", ["a", "b"], lePrim);
// ord# :: Char# -> Int#
env.bind("ord#", ["a"],
function(env) {
var a = env.lookup("a");
return a.charCodeAt(0);
});
// data Int#
var intSize = 32;
// (+#) :: Int# -> Int# -> Int#
env.bind("+#", ["a", "b"], primAdd(intSize, true));
// (-#) :: Int# -> Int# -> Int#
env.bind("-#", ["a", "b"], primSub(intSize, true));
// (*#) :: Int# -> Int# -> Int#
env.bind("*#", ["a", "b"], primMul(intSize, true));
// mulIntMayOflo# :: Int# -> Int# -> Int#
// quotInt# :: Int# -> Int# -> Int#
env.bind("quotInt#", ["a", "b"], primQuot(intSize, true));
// remInt# :: Int# -> Int# -> Int#
env.bind("remInt#", ["a", "b"], primRem(intSize, true));
// negateInt# :: Int# -> Int#
env.bind("negateInt#", ["a", "b"], primNegate(intSize, true));
// addIntC# :: Int# -> Int# -> (#Int#, Int##)
// subIntC# :: Int# -> Int# -> (#Int#, Int##)
// (>#) :: Int# -> Int# -> Bool
env.bind(">#", ["a", "b"], gtPrim);
// (>=#) :: Int# -> Int# -> Bool
env.bind(">=#", ["a", "b"], gePrim);
// (==#) :: Int# -> Int# -> Bool
env.bind("==#", ["a", "b"], eqPrim);
// (/=#) :: Int# -> Int# -> Bool
env.bind("/=#", ["a", "b"], nePrim);
// (<#) :: Int# -> Int# -> Bool
env.bind("<#", ["a", "b"], ltPrim);
// (<=#) :: Int# -> Int# -> Bool
env.bind("<=#", ["a", "b"], lePrim);
// chr# :: Int# -> Char#
// int2Word# :: Int# -> Word#
env.bind("int2Word#", ["a"], primNarrow(32, false));
// int2Float# :: Int# -> Float#
env.bind("int2Word#", ["a"], primNarrow(32, true));
// int2Double# :: Int# -> Double#
env.bind("int2Word#", ["a"], primNarrow(64, true));
// uncheckedIShiftL# :: Int# -> Int# -> Int#
// uncheckedIShiftRA# :: Int# -> Int# -> Int#
// uncheckedIShiftRL# :: Int# -> Int# -> Int#
};
primitives.init = function(env) {
primitives.prim(env);
// (+) :: Num a => a -> a -> a
env.bind("+", createPrimitive(env, ["a", "b"],
function(env) {
var a = forceHead(env.lookup("a"));
var b = forceHead(env.lookup("b"));
return new interpreter.ConstantThunk(new ast.Num(a.value.num+b.value.num));
}));
// (-) :: Num a => a -> a -> a
env.bind("-", createPrimitive(env, ["a", "b"],
function(env) {
var a = forceHead(env.lookup("a"));
var b = forceHead(env.lookup("b"));
return new interpreter.ConstantThunk(new ast.Num(a.value.num-b.value.num));
}));
// (*) :: Num a => a -> a -> a
env.bind("*", createPrimitive(env, ["a", "b"],
function(env) {
var a = forceHead(env.lookup("a"));
var b = forceHead(env.lookup("b"));
return new interpreter.ConstantThunk(new ast.Num(a.value.num*b.value.num));
}));
// primAlert :: String -> a
env.bind("alert", createPrimitive(env, ["l"],
function(env) {
var l = forceHead(env.lookup("l"));
alert(l.value.num);
return new interpreter.Data("()", []);
}));
// seq :: a -> b -> b
env.bind("seq", createPrimitive(env, ["a", "b"],
function(env) {
env.lookup("a").forceHead();
return env.lookup("b");
}));
// Can print all different haskell types (including functions...)
// Should be hidden away and only used for the deriving Show implementation.
// defaultShow :: a -> String
env.bind("defaultShow", createPrimitive(env, ["s"],
function(env) {
var t = env.lookup("s");
}));
env.bind(":", createDataConstructor(env, ":", 2));
env.bind("[]", createDataConstructor(env, "[]", 0));
};
function createPrimitive(env, args, func) {
var expr = new ast.Primitive(func);
var argsR = [].concat(args).reverse();
for (var i in argsR) {
expr = new ast.Lambda(new ast.VariableBinding(argsR[i]), expr);
};
return new interpreter.Closure(env, expr);
};
function createDataConstructor(env, ident, num) {
var args = [];
for (var i = 0; i<num; i++) {
args[i] = "__p" + i;
};
var prim = function(env) {
var givenArgs=[];
for (var i in args) {
givenArgs[i] = env.lookup(args[i]);
};
return new interpreter.Data(ident, givenArgs);
};
return createPrimitive(env, args, prim);
};
function forceHead(thunk) {
while(thunk.type!="ConstantThunk" && thunk.type!="Data") {
thunk=thunk.force();
};
return thunk;
};
function boxBool(env, b) {
if (b) {
return env.lookup("True");
};
return env.lookup("False");
};
function gtPrim(env) {
var a = env.lookup("a");
var b = env.lookup("b");
return boxBool(env, a > b);
};
function gePrim(env) {
var a = env.lookup("a");
var b = env.lookup("b");
return boxBool(env, a >= b);
};
function eqPrim(env) {
var a = env.lookup("a");
var b = env.lookup("b");
return boxBool(env, a == b);
};
function nePrim(env) {
var a = env.lookup("a");
var b = env.lookup("b");
return boxBool(env, a != b);
};
function ltPrim(env) {
var a = env.lookup("a");
var b = env.lookup("b");
return boxBool(env, a < b);
};
function lePrim(env) {
var a = env.lookup("a");
var b = env.lookup("b");
return boxBool(env, a <= b);
};
function primAdd(bits, twoComplement) {
return function(env) {
var a = env.lookup("a");
var b = env.lookup("b");
var result = a + b;
return doPrimOverflow(bits, twoComplement, result);
};
};
function primSub(bits, twoComplement) {
return function(env) {
var a = env.lookup("a");
var b = env.lookup("b");
var result = a - b;
return doPrimOverflow(bits, twoComplement, result);
};
};
function primMul(bits, twoComplement) {
return function(env) {
var a = env.lookup("a");
var b = env.lookup("b");
var result = a * b;
return doPrimOverflow(bits, twoComplement, result);
};
};
function primQuot(bits, twoComplement) {
return function(env) {
var a = env.lookup("a");
var b = env.lookup("b");
var result = parseInt(a / b);
return doPrimOverflow(bits, twoComplement, result);
};
};
function primRem(bits, twoComplement) {
return function(env) {
var a = env.lookup("a");
var b = env.lookup("b");
var result = a % b;
return doPrimOverflow(bits, twoComplement, result);
};
};
function primNegate(bits, twoComplement) {
return function(env) {
var a = env.lookup("a");
var result = -a;
return doPrimOverflow(bits, twoComplement, result);
};
};
function primNarrow(bits, twoComplement) {
return function(env) {
return doPrimNarrow(bits, twoComplement, env.lookup("a"));
};
};
// Narrows a number by chopping of the higher bits
function doPrimNarrow(bits, twoComplement, num) {
num = num & (Math.pow(2, bits+1) - 1);
if (twoComplement && (num & Math.pow(2, bits))) {
return num - Math.pow(2, bits);
};
return num;
};
// Narrows a number by overflowing it
function doPrimOverflow(bits, twoComplement, num) {
return doPrimNarrow(bits, twoComplement, num);
};
})(haskell.primitives, haskell.ast, haskell.interpreter);
Jump to Line
Something went wrong with that request. Please try again.