fsharp/step9_try.fs

   1 module REPL
   2     open System
   3     open Node
   4     open Types
   5
   6     let rec iterPairs f = function
   7         | Pair(first, second, t) ->
   8             f first second
   9             iterPairs f t
  10         | Empty -> ()
  11         | _ -> raise <| Error.errExpectedX "list or vector"
  12
  13     let quasiquoteForm nodes =
  14         let transformNode f = function
  15             | Elements 1 [|a|] -> f a
  16             | _ -> raise <| Error.wrongArity ()
  17         let singleNode = transformNode (fun n -> n)
  18         let rec quasiquote node =
  19             match node with
  20             | Cons(Symbol("unquote"), rest) -> rest |> singleNode
  21             | Cons(Cons(Symbol("splice-unquote"), spliceRest), rest) ->
  22                 makeList [Symbol("concat"); singleNode spliceRest; quasiquote rest]
  23             | Cons(h, t) -> makeList [Symbol("cons"); quasiquote h; quasiquote t]
  24             | n -> makeList [Symbol("quote"); n]
  25         makeList nodes |> transformNode quasiquote
  26
  27     let quoteForm = function
  28         | [node] -> node
  29         | _ -> raise <| Error.wrongArity ()
  30
  31     let rec macroExpand env = function
  32         | Env.IsMacro env (Macro(_, _, f, _, _, _), rest) ->
  33             f rest |> macroExpand env
  34         | node -> node
  35
  36     let rec eval_ast env = function
  37         | Symbol(sym) -> Env.get env sym
  38         | List(_, lst) -> lst |> List.map (eval env) |> makeList
  39         | Vector(_, seg) -> seg |> Seq.map (eval env) |> Array.ofSeq |> Node.ofArray
  40         | Map(_, map) -> map |> Map.map (fun k v -> eval env v) |> makeMap
  41         | node -> node
  42
  43     and defBangForm env = function
  44         | [sym; form] ->
  45             match sym with
  46             | Symbol(sym) ->
  47                 let node = eval env form
  48                 Env.set env sym node
  49                 node
  50             | _ -> raise <| Error.errExpectedX "symbol"
  51         | _ -> raise <| Error.wrongArity ()
  52
  53     and defMacroForm env = function
  54         | [sym; form] ->
  55             match sym with
  56             | Symbol(sym) ->
  57                 let node = eval env form
  58                 match node with
  59                 | Func(_, _, f, body, binds, outer) ->
  60                     let node = Env.makeMacro f body binds outer
  61                     Env.set env sym node
  62                     node
  63                 | _ -> raise <| Error.errExpectedX "user defined func"
  64             | _ -> raise <| Error.errExpectedX "symbol"
  65         | _ -> raise <| Error.wrongArity ()
  66
  67     and macroExpandForm env = function
  68         | [form] -> macroExpand env form
  69         | _ -> raise <| Error.wrongArity ()
  70
  71     and setBinding env first second =
  72         let s = match first with
  73                 | Symbol(s) -> s
  74                 | _ -> raise <| Error.errExpectedX "symbol"
  75         let form = eval env second
  76         Env.set env s form
  77
  78     and letStarForm outer = function
  79         | [bindings; form] ->
  80             let inner = Env.makeNew outer [] []
  81             let binder = setBinding inner
  82             match bindings with
  83             | List(_) | Vector(_) -> iterPairs binder bindings
  84             | _ -> raise <| Error.errExpectedX "list or vector"
  85             inner, form
  86         | _ -> raise <| Error.wrongArity ()
  87
  88     and ifForm env = function
  89         | [condForm; trueForm; falseForm] -> ifForm3 env condForm trueForm falseForm
  90         | [condForm; trueForm] -> ifForm3 env condForm trueForm Nil
  91         | _ -> raise <| Error.wrongArity ()
  92
  93     and ifForm3 env condForm trueForm falseForm =
  94         match eval env condForm with
  95         | Bool(false) | Nil -> falseForm
  96         | _ -> trueForm
  97
  98     and doForm env = function
  99         | [a] -> a
 100         | a::rest ->
 101             eval env a |> ignore
 102             doForm env rest
 103         | _ -> raise <| Error.wrongArity ()
 104
 105     and fnStarForm outer nodes =
 106         let makeFunc binds body =
 107             let f = fun nodes ->
 108                         let inner = Env.makeNew outer binds nodes
 109                         eval inner body
 110             Env.makeFunc f body binds outer
 111
 112         match nodes with
 113         | [List(_, binds); body] -> makeFunc binds body
 114         | [Vector(_, seg); body] -> makeFunc (List.ofSeq seg) body
 115         | [_; _] -> raise <| Error.errExpectedX "bindings of list or vector"
 116         | _ -> raise <| Error.wrongArity ()
 117
 118     and catchForm env err = function
 119         | List(_, [Symbol("catch*"); Symbol(_) as sym; catchBody]) ->
 120             let inner = Env.makeNew env [sym] [err]
 121             catchBody |> eval inner
 122         | List(_, [_; _; _]) -> raise <| Error.argMismatch ()
 123         | _ -> raise <| Error.wrongArity ()
 124
 125     and tryForm env = function
 126         | [exp; catchClause] ->
 127             try
 128                 eval env exp
 129             with
 130             | Error.EvalError(str) -> catchForm env (String(str)) catchClause
 131             | Error.MalError(node) -> catchForm env node catchClause
 132         | _ -> raise <| Error.wrongArity ()
 133
 134     and eval env = function
 135         | List(_, _) as node ->
 136             match macroExpand env node with
 137             | List(_, Symbol("def!")::rest) -> defBangForm env rest
 138             | List(_, Symbol("defmacro!")::rest) -> defMacroForm env rest
 139             | List(_, Symbol("macroexpand")::rest) -> macroExpandForm env rest
 140             | List(_, Symbol("let*")::rest) ->
 141                 let inner, form = letStarForm env rest
 142                 form |> eval inner
 143             | List(_, Symbol("if")::rest) -> ifForm env rest |> eval env
 144             | List(_, Symbol("do")::rest) -> doForm env rest |> eval env
 145             | List(_, Symbol("fn*")::rest) -> fnStarForm env rest
 146             | List(_, Symbol("quote")::rest) -> quoteForm rest
 147             | List(_, Symbol("quasiquote")::rest) -> quasiquoteForm rest |> eval env
 148             | List(_, Symbol("try*")::rest) -> tryForm env rest
 149             | List(_, _) as node ->
 150                 let resolved = node |> eval_ast env
 151                 match resolved with
 152                 | List(_, BuiltInFunc(_, _, f)::rest) -> f rest
 153                 | List(_, Func(_, _, _, body, binds, outer)::rest) ->
 154                     let inner = Env.makeNew outer binds rest
 155                     body |> eval inner
 156                 | _ -> raise <| Error.errExpectedX "func"
 157             | node -> node
 158         | node -> node |> eval_ast env
 159
 160     let READ input =
 161         try
 162             Reader.read_str input
 163         with
 164         | Error.ReaderError(msg) ->
 165             printfn "%s" msg
 166             []
 167
 168     let EVAL env ast =
 169         try
 170             Some(eval env ast)
 171         with
 172         | Error.EvalError(msg) ->
 173             printfn "%s" msg
 174             None
 175
 176     let PRINT v =
 177         v
 178         |> Seq.singleton
 179         |> Printer.pr_str
 180         |> printfn "%s"
 181
 182     let RE env input =
 183         READ input
 184         |> Seq.ofList
 185         |> Seq.choose (fun form -> EVAL env form)
 186
 187     let REP env input =
 188         input
 189         |> RE env
 190         |> Seq.iter (fun value -> PRINT value)
 191
 192     let getReadlineMode args =
 193         if args |> Array.exists (fun e -> e = "--raw") then
 194             Readline.Mode.Raw
 195         else
 196             Readline.Mode.Terminal
 197
 198     let eval_func env = function
 199         | [ast] -> eval env ast
 200         | _ -> raise <| Error.wrongArity ()
 201
 202     let argv_func = function
 203         | file::rest -> rest |> List.map Types.String |> makeList
 204         | [] -> EmptyLIST
 205
 206     let configureEnv args =
 207         let env = Env.makeRootEnv ()
 208
 209         Env.set env "eval" <| Env.makeBuiltInFunc (fun nodes -> eval_func env nodes)
 210         Env.set env "*ARGV*" <| argv_func args
 211
 212         RE env """
 213             (def! not (fn* (a) (if a false true)))
 214             (def! load-file (fn* (f) (eval (read-string (slurp f)))))
 215             (defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_ ~(first xs)) (if or_ or_ (or ~@(rest xs))))))))
 216             (defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw "odd number of forms to cond")) (cons 'cond (rest (rest xs)))))))
 217             """ |> Seq.iter ignore
 218
 219         env
 220
 221     [<EntryPoint>]
 222     let main args =
 223         let mode = getReadlineMode args
 224         let args = Seq.ofArray args |> Seq.filter (fun e -> e <> "--raw") |> List.ofSeq
 225         let env = configureEnv args
 226
 227         match args with
 228         | file::_ ->
 229             System.IO.File.ReadAllText file
 230             |> REP env
 231             0
 232         | _ ->
 233             let rec loop () =
 234                 match Readline.read "user> " mode with
 235                 | null -> 0
 236                 | input ->
 237                     REP env input
 238                     loop ()
 239             loop ()