fsharp/core.fs

   1 module Core
   2
   3     open Types
   4
   5     let inline toBool b = if b then Node.TRUE else Node.FALSE
   6
   7     let inline twoNumberOp (f : int64 -> int64 -> Node) = function
   8         | [Number(a); Number(b)] -> f a b
   9         | [_; _] -> raise <| Error.argMismatch ()
  10         | _ -> raise <| Error.wrongArity ()
  11
  12     let inline twoNodeOp (f : Node -> Node -> Node) = function
  13         | [a; b] -> f a b
  14         | _ -> raise <| Error.wrongArity ()
  15
  16     let add = twoNumberOp (fun a b -> a + b |> Number)
  17     let subtract = twoNumberOp (fun a b -> a - b |> Number)
  18     let multiply = twoNumberOp (fun a b -> a * b |> Number)
  19     let divide = twoNumberOp (fun a b -> a / b |> Number)
  20     let lt = twoNodeOp (fun a b -> a < b |> toBool)
  21     let le = twoNodeOp (fun a b -> a <= b |> toBool)
  22     let ge = twoNodeOp (fun a b -> a >= b |> toBool)
  23     let gt = twoNodeOp (fun a b -> a > b |> toBool)
  24     let eq = twoNodeOp (fun a b -> a = b |> toBool)
  25
  26     let list nodes = List(nodes)
  27     let isList = function
  28         | [List(_)] -> Node.TRUE
  29         | [_] -> Node.FALSE
  30         | _ -> raise <| Error.wrongArity ()
  31
  32     let isEmpty = function
  33         | [List([])] -> Node.TRUE
  34         | [Vector(seg)] when seg.Count <= 0 -> Node.TRUE
  35         | _ -> Node.FALSE
  36
  37     let count = function
  38         | [List(lst)] -> lst |> List.length |> int64 |> Number
  39         | [Vector(seg)] -> seg.Count |> int64 |> Number
  40         | [Nil] -> Node.ZERO
  41         | [_] -> raise <| Error.argMismatch ()
  42         | _ -> raise <| Error.wrongArity ()
  43
  44     let pr_str nodes = nodes |> Printer.pr_str |> String
  45     let str nodes = nodes |> Printer.str |> String
  46     let prn nodes = nodes |> Printer.prn |> printfn "%s"; Nil
  47     let println nodes = nodes |> Printer.println |> printfn "%s"; Nil
  48
  49     let read_str = function
  50         | [String(s)] ->
  51             match Reader.read_str s with
  52             | [node] -> node
  53             | nodes -> List(Symbol("do")::nodes)
  54         | [_] -> raise <| Error.argMismatch ()
  55         | _ -> raise <| Error.wrongArity ()
  56
  57     let slurp = function
  58         | [String(s)] -> System.IO.File.ReadAllText s |> String
  59         | [_] -> raise <| Error.argMismatch ()
  60         | _ -> raise <| Error.wrongArity ()
  61
  62     let cons = function
  63         | [node; List(lst)] -> List(node::lst)
  64         | [node; Vector(seg)] -> List(node::(List.ofSeq seg))
  65         | [_; _] -> raise <| Error.argMismatch ()
  66         | _ -> raise <| Error.wrongArity ()
  67
  68     let concat nodes =
  69         let cons st node = node::st
  70         let accumNode acc = function
  71             | List(lst) -> lst |> List.fold cons acc
  72             | Vector(seg) -> seg |> Seq.fold cons acc
  73             | _ -> raise <| Error.argMismatch ()
  74
  75         nodes
  76         |> List.fold accumNode []
  77         |> List.rev
  78         |> List
  79
  80     let nth = function
  81         | [List(lst); Number(n)] ->
  82             let rec nth_list n = function
  83                 | [] -> raise <| Error.indexOutOfBounds ()
  84                 | h::_ when n = 0L -> h
  85                 | _::t -> nth_list (n - 1L) t
  86             nth_list n lst
  87         | [Vector(seg); Number(n)] ->
  88             if n < 0L || n >= int64(seg.Count) then
  89                 raise <| Error.indexOutOfBounds ()
  90             else
  91                 seg.Array.[int(n)]
  92         | [_; _] -> raise <| Error.argMismatch ()
  93         | _ -> raise <| Error.wrongArity ()
  94
  95     let first = function
  96         | [List([])] -> Node.NIL
  97         | [List(h::_)] -> h
  98         | [Vector(seg)] when seg.Count > 0 -> seg.Array.[0]
  99         | [Vector(_)] -> Node.NIL
 100         | [Nil] -> Node.NIL
 101         | [_] -> raise <| Error.argMismatch ()
 102         | _ -> raise <| Error.wrongArity ()
 103
 104     let rest = function
 105         | [List([]) as lst] -> lst
 106         | [List(_::t)] -> List(t)
 107         | [Vector(seg)] when seg.Count < 2 -> Node.EmptyLIST
 108         | [Vector(seg)] -> seg |> Seq.skip 1 |> List.ofSeq |> List
 109         | [_] -> raise <| Error.argMismatch ()
 110         | _ -> raise <| Error.wrongArity ()
 111
 112     let throw = function
 113         | [node] -> raise <| Error.MalError(node)
 114         | _ -> raise <| Error.wrongArity ()
 115
 116     let map = function
 117         | [BuiltInFunc(_, f); Node.Seq seq]
 118         | [Func(_, f, _, _, _); Node.Seq seq] ->
 119             seq |> Seq.map (fun node -> f [node]) |> List.ofSeq |> List
 120         | [_; _] -> raise <| Error.argMismatch ()
 121         | _ -> raise <| Error.wrongArity ()
 122
 123     let apply = function
 124         | BuiltInFunc(_, f)::rest
 125         | Func(_, f, _, _, _)::rest ->
 126             let rec getArgsAndCall acc = function
 127                 | [] -> raise <| Error.wrongArity ()
 128                 | [Node.Seq seq] ->
 129                     seq |> Seq.fold (fun acc node -> node::acc) acc |> List.rev |> f
 130                 | [_] -> raise <| Error.argMismatch ()
 131                 | h::rest -> getArgsAndCall (h::acc) rest
 132             getArgsAndCall [] rest
 133         | _::_ -> raise <| Error.argMismatch ()
 134         | [] -> raise <| Error.wrongArity ()
 135
 136     let isConst cmp = function
 137         | [node] -> if node = cmp then Node.TRUE else Node.FALSE
 138         | _ -> raise <| Error.wrongArity ()
 139
 140     let isSymbol = function
 141         | [Symbol(_)] -> Node.TRUE
 142         | [_] -> Node.FALSE
 143         | _ -> raise <| Error.wrongArity ()