impls/fsharp/core.fs

   1 module Core
   2
   3     open System
   4     open Types
   5
   6     let inline toBool b = if b then Node.TRUE else Node.FALSE
   7
   8     let inline twoNumberOp (f : int64 -> int64 -> Node) = function
   9         | [Number(a); Number(b)] -> f a b
  10         | [_; _] -> raise <| Error.argMismatch ()
  11         | _ -> raise <| Error.wrongArity ()
  12
  13     let inline twoNodeOp (f : Node -> Node -> Node) = function
  14         | [a; b] -> f a b
  15         | _ -> raise <| Error.wrongArity ()
  16
  17     let add = twoNumberOp (fun a b -> a + b |> Number)
  18     let subtract = twoNumberOp (fun a b -> a - b |> Number)
  19     let multiply = twoNumberOp (fun a b -> a * b |> Number)
  20     let divide = twoNumberOp (fun a b -> a / b |> Number)
  21     let lt = twoNodeOp (fun a b -> a < b |> toBool)
  22     let le = twoNodeOp (fun a b -> a <= b |> toBool)
  23     let ge = twoNodeOp (fun a b -> a >= b |> toBool)
  24     let gt = twoNodeOp (fun a b -> a > b |> toBool)
  25     let eq = twoNodeOp (fun a b -> a = b |> toBool)
  26
  27     let time_ms _ =
  28         DateTime.Now.Ticks / TimeSpan.TicksPerMillisecond |> int64 |> Number
  29
  30     let list = Node.makeList
  31     let isList = function
  32         | [List(_, _)] -> Node.TRUE
  33         | [_] -> Node.FALSE
  34         | _ -> raise <| Error.wrongArity ()
  35
  36     let isEmpty = function
  37         | [List(_, [])] -> Node.TRUE
  38         | [Vector(_, seg)] when seg.Count <= 0 -> Node.TRUE
  39         | _ -> Node.FALSE
  40
  41     let count = function
  42         | [List(_, lst)] -> lst |> List.length |> int64 |> Number
  43         | [Vector(_, seg)] -> seg.Count |> int64 |> Number
  44         | [Nil] -> Node.ZERO
  45         | [_] -> raise <| Error.argMismatch ()
  46         | _ -> raise <| Error.wrongArity ()
  47
  48     let pr_str nodes = nodes |> Printer.pr_str |> String
  49     let str nodes = nodes |> Printer.str |> String
  50     let prn nodes = nodes |> Printer.prn |> printfn "%s"; Nil
  51     let println nodes = nodes |> Printer.println |> printfn "%s"; Nil
  52
  53     let read_str = function
  54         | [String(s)] ->
  55             match Reader.read_str s with
  56             | [node] -> node
  57             | nodes -> Symbol("do")::nodes |> Node.makeList
  58         | [_] -> raise <| Error.argMismatch ()
  59         | _ -> raise <| Error.wrongArity ()
  60
  61     let slurp = function
  62         | [String(s)] -> System.IO.File.ReadAllText s |> String
  63         | [_] -> raise <| Error.argMismatch ()
  64         | _ -> raise <| Error.wrongArity ()
  65
  66     let cons = function
  67         | [node; List(_, lst)] -> node::lst |> Node.makeList
  68         | [node; Vector(_, seg)] -> node::(List.ofSeq seg) |> Node.makeList
  69         | [_; _] -> raise <| Error.argMismatch ()
  70         | _ -> raise <| Error.wrongArity ()
  71
  72     let concat nodes =
  73         let cons st node = node::st
  74         let accumNode acc = function
  75             | List(_, lst) -> lst |> List.fold cons acc
  76             | Vector(_, seg) -> seg |> Seq.fold cons acc
  77             | _ -> raise <| Error.argMismatch ()
  78
  79         nodes
  80         |> List.fold accumNode []
  81         |> List.rev
  82         |> Node.makeList
  83
  84     let nth = function
  85         | [List(_, lst); Number(n)] ->
  86             let rec nth_list n = function
  87                 | [] -> raise <| Error.indexOutOfBounds ()
  88                 | h::_ when n = 0L -> h
  89                 | _::t -> nth_list (n - 1L) t
  90             nth_list n lst
  91         | [Vector(_, seg); Number(n)] ->
  92             if n < 0L || n >= int64(seg.Count) then
  93                 raise <| Error.indexOutOfBounds ()
  94             else
  95                 seg.Array.[int(n)]
  96         | [_; _] -> raise <| Error.argMismatch ()
  97         | _ -> raise <| Error.wrongArity ()
  98
  99     let first = function
 100         | [List(_, [])] -> Node.NIL
 101         | [List(_, h::_)] -> h
 102         | [Vector(_, seg)] when seg.Count > 0 -> seg.Array.[0]
 103         | [Vector(_, _)] -> Node.NIL
 104         | [Nil] -> Node.NIL
 105         | [_] -> raise <| Error.argMismatch ()
 106         | _ -> raise <| Error.wrongArity ()
 107
 108     let rest = function
 109         | [List(_, [])] -> Node.EmptyLIST
 110         | [List(_, _::t)] -> t |> Node.makeList
 111         | [Vector(_, seg)] when seg.Count < 2 -> Node.EmptyLIST
 112         | [Vector(_, seg)] -> seg |> Seq.skip 1 |> List.ofSeq |> Node.makeList
 113         | [Nil] -> Node.EmptyLIST
 114         | [_] -> raise <| Error.argMismatch ()
 115         | _ -> raise <| Error.wrongArity ()
 116
 117     let throw = function
 118         | [node] -> raise <| Error.MalError(node)
 119         | _ -> raise <| Error.wrongArity ()
 120
 121     let map = function
 122         | [BuiltInFunc(_, _, f); Node.Seq seq]
 123         | [Func(_, _, f, _, _, _); Node.Seq seq] ->
 124             seq |> Seq.map (fun node -> f [node]) |> List.ofSeq |> Node.makeList
 125         | [_; _] -> raise <| Error.argMismatch ()
 126         | _ -> raise <| Error.wrongArity ()
 127
 128     let apply = function
 129         | BuiltInFunc(_, _, f)::rest
 130         | Func(_, _, f, _, _, _)::rest ->
 131             let rec getArgsAndCall acc = function
 132                 | [] -> raise <| Error.wrongArity ()
 133                 | [Node.Seq seq] ->
 134                     seq |> Seq.fold (fun acc node -> node::acc) acc |> List.rev |> f
 135                 | [_] -> raise <| Error.argMismatch ()
 136                 | h::rest -> getArgsAndCall (h::acc) rest
 137             getArgsAndCall [] rest
 138         | _::_ -> raise <| Error.argMismatch ()
 139         | [] -> raise <| Error.wrongArity ()
 140
 141     let isConst cmp = function
 142         | [node] -> if node = cmp then Node.TRUE else Node.FALSE
 143         | _ -> raise <| Error.wrongArity ()
 144
 145     let isPattern f = function
 146         | [node] -> if f node then Node.TRUE else Node.FALSE
 147         | _ -> raise <| Error.wrongArity ()
 148
 149     let isSymbol = isPattern (function Symbol(_) -> true | _ -> false)
 150     let isKeyword = isPattern (function Keyword(_) -> true | _ -> false)
 151     let isString = isPattern (function String(_) -> true | _ -> false)
 152     let isNumber = isPattern (function Number(_) -> true | _ -> false)
 153     let isFn = isPattern (function BuiltInFunc(_, _, _) | Func(_, _, _, _, _, _) -> true | _ -> false)
 154     let isMacro = isPattern (function Macro(_, _, _, _, _, _) -> true | _ -> false)
 155     let isSequential = isPattern (function Node.Seq(_) -> true | _ -> false)
 156     let isVector = isPattern (function Vector(_, _) -> true | _ -> false)
 157     let isMap = isPattern (function Map(_, _) -> true | _ -> false)
 158     let isAtom = isPattern (function Atom(_, _) -> true | _ -> false)
 159
 160     let fromString f = function
 161         | [String(str)] -> f str
 162         | [_] -> raise <| Error.argMismatch ()
 163         | _ -> raise <| Error.wrongArity ()
 164
 165     let symbol = fromString (fun s -> Symbol(s))
 166     let keyword = fromString (fun s -> Keyword(s))
 167     let vector lst =  lst |> Array.ofList |> Node.ofArray
 168
 169     let rec getPairs lst =
 170         seq {
 171             match lst with
 172             | first::second::t ->
 173                 yield first, second
 174                 yield! getPairs t
 175             | [_] -> raise <| Error.expectedEvenNodeCount ()
 176             | [] -> ()
 177         }
 178
 179     let mapOpN f = function
 180         | Map(_, map)::rest -> f rest map
 181         | [_] -> raise <| Error.argMismatch ()
 182         | _ -> raise <| Error.wrongArity ()
 183
 184     let mapOp1 f =
 185         mapOpN (fun rest map ->
 186                     match rest with
 187                     | [v] -> f v map
 188                     | _ -> raise <| Error.wrongArity ())
 189
 190     let mapOp0 f =
 191         mapOpN (fun rest map ->
 192                     match rest with
 193                     | [] -> f map
 194                     | _ -> raise <| Error.wrongArity ())
 195
 196     let mapKV f =
 197         mapOp0 (fun map -> map |> Map.toSeq |> Seq.map f |> List.ofSeq |> Node.makeList)
 198
 199     let hashMap lst = lst |> getPairs |> Map.ofSeq |> Node.makeMap
 200     let assoc = mapOpN (fun rest map ->
 201                             rest
 202                             |> getPairs
 203                             |> Seq.fold (fun map (k, v) -> Map.add k v map) map
 204                             |> Node.makeMap)
 205     let dissoc = mapOpN (fun keys map ->
 206                             keys
 207                             |> List.fold (fun map k -> Map.remove k map) map
 208                             |> Node.makeMap)
 209     let get = function
 210         | [Nil; _] -> Node.NIL
 211         | _ as rest ->
 212             rest |> mapOp1 (fun key map ->
 213                                 match Map.tryFind key map with
 214                                 | Some(node) -> node
 215                                 | None -> Node.NIL)
 216     let containsKey key map = if Map.containsKey key map then Node.TRUE else Node.FALSE
 217     let contains = mapOp1 containsKey
 218     let keys = mapKV (fun (k, v) -> k)
 219     let vals = mapKV (fun (k, v) -> v)
 220
 221     let atom nextValue = function
 222         | [node] -> Atom((nextValue ()), ref node)
 223         | _ -> raise <| Error.wrongArity ()
 224
 225     let deref = function
 226         | [Atom(_, r)] -> !r
 227         | [_] -> raise <| Error.argMismatch ()
 228         | _ -> raise <| Error.wrongArity ()
 229
 230     let reset = function
 231         | [Atom(_, r); node] ->
 232             r := node
 233             !r
 234         | [_; _] -> raise <| Error.argMismatch ()
 235         | _ -> raise <| Error.wrongArity ()
 236
 237     let swap = function
 238         | Atom(_, r)
 239             ::(BuiltInFunc(_, _, f) | Func(_, _, f, _, _, _))
 240             ::rest ->
 241                 r := f (!r::rest)
 242                 !r
 243         | [_; _] -> raise <| Error.argMismatch ()
 244         | _ -> raise <| Error.wrongArity ()
 245
 246     let conj = function
 247         | List(_, lst)::rest ->
 248             rest
 249             |> List.fold (fun lst node -> node::lst) lst
 250             |> Node.makeList
 251         | Vector(_, seg)::rest ->
 252             (* Might be nice to implement a persistent vector here someday. *)
 253             let cnt = List.length rest
 254             if cnt > 0 then
 255                 let target : Node array = seg.Count + cnt |> Array.zeroCreate
 256                 System.Array.Copy(seg.Array :> System.Array, seg.Offset,
 257                     target :> System.Array, 0, seg.Count)
 258                 let rec copyElem i = function
 259                     | h::t ->
 260                         Array.set target i h
 261                         copyElem (i + 1) t
 262                     | [] -> ()
 263                 copyElem (seg.Count) rest
 264                 target |> Node.ofArray
 265             else
 266                 seg |> Node.makeVector
 267         | [_; _] -> raise <| Error.argMismatch ()
 268         | _ -> raise <| Error.wrongArity ()
 269
 270     let seq = function
 271         | [Nil] -> Node.NIL
 272         | [List(_, [])] -> Node.NIL
 273         | [List(_, _) as l] -> l
 274         | [Vector(_, seg)] when seg.Count < 1 -> Node.NIL
 275         | [Vector(_, seg)] -> seg |> List.ofSeq |> Node.makeList
 276         | [String(s)] when String.length s < 1 -> Node.NIL
 277         | [String(s)] -> s |> Seq.map Node.ofChar |> List.ofSeq |> Node.makeList
 278         | [_] -> raise <| Error.argMismatch ()
 279         | _ -> raise <| Error.wrongArity ()
 280
 281     let withMeta = function
 282         | [List(_, lst); m] -> List(m, lst)
 283         | [Vector(_, seg); m] -> Vector(m, seg)
 284         | [Map(_, map); m] -> Map(m, map)
 285         | [BuiltInFunc(_, tag, f); m] -> BuiltInFunc(m, tag, f)
 286         | [Func(_, tag, f, a, b, c); m] -> Func(m, tag, f, a, b, c)
 287         | [Macro(_, tag, f, a, b, c); m] -> Macro(m, tag, f, a, b, c)
 288         | [_; _] -> raise <| Error.argMismatch ()
 289         | _ -> raise <| Error.wrongArity ()
 290
 291     let meta = function
 292         | [List(m, _)]
 293         | [Vector(m, _)]
 294         | [Map(m, _)]
 295         | [BuiltInFunc(m, _, _)]
 296         | [Func(m, _, _, _, _, _)]
 297         | [Macro(m, _, _, _, _, _)] -> m
 298         | [_] -> Node.NIL
 299         | _ -> raise <| Error.wrongArity ()