Lisp.elm

module Lisp exposing
  ( Expression
  , Error
  , run
  )

{- Imports ------------------------------------------------------------------ -}
import Dict exposing (Dict)
import Result.Extra
import Parser exposing (Parser, (|=), (|.))

{- Types -------------------------------------------------------------------- -}
{-| -}
type Expression
  = Reference String
  | Literal Value
  | List (List Expression)
  | Function (List Expression -> Result Error Expression)

{-| -}
expression_to_string : Expression -> String
expression_to_string expr =
  case expr of
    Reference ref -> 
      ref

    Literal val -> 
      literal_to_string val

    List exprs -> 
      "(" ++ (List.map expression_to_string exprs |> String.join " ") ++ ")"

    Function _ ->
      "<Function>"

{-| -}
type Value
  = Number Float
  | String String
  | Boolean Bool

{-| -}
literal_to_number : Value -> Float
literal_to_number val =
  case val of
    Number f  -> f
    String s  -> String.toFloat s |> Maybe.withDefault (0/0)
    Boolean b -> if b then 1 else 0

{-| -}
literal_to_string : Value -> String
literal_to_string val =
  case val of
    Number f  -> String.fromFloat f
    String s  -> s
    Boolean b -> if b then "true" else "false"

literal_to_bool : Value -> Bool
literal_to_bool val =
  case val of
    Number f  -> if f /= 0 then True else False
    String s  -> if s /= "" then True else False
    Boolean b -> b

{-| -}
type alias ReferenceTable
  = Dict String Expression

{-| -}
type Context
  = Context ReferenceTable (Maybe Error) Expression

{-| -}
type Error
  = UnboundReference String
  | BadArgs (List String) (List Expression)
  | NotAFunction Expression

{-| -}
error_to_string : Error -> String
error_to_string err =
  case err of
    UnboundReference ref ->
      "<Error> UnboundReference: " ++ ref

    BadArgs expecting got ->
      "<Error> BadArgs: expecting (" ++ String.join " " expecting ++ ") "
        ++ "but got (" ++ (List.map expression_to_string got |> String.join " ") ++ ")"

    NotAFunction got ->
      "<Error> NotAFunction: expecting a function but got ("
        ++ expression_to_string got ++ ")"

{- Interpreter -------------------------------------------------------------- -}
{-| -}
run : String -> Result String String
run input =
  parse input
    |> List.map (evaluate core >> Result.map (Tuple.second >> expression_to_string))
    |> Result.Extra.combine
    |> Result.map (String.join "\n")
    |> Result.mapError error_to_string

{-| -}
evaluate : ReferenceTable -> Expression -> Result Error (ReferenceTable, Expression)
evaluate refs expr =
  case expr of
    Reference ref ->
      Dict.get ref refs
        |> Maybe.map (evaluate refs)
        |> Maybe.withDefault (Err <| UnboundReference ref)

    Literal val ->
      Ok (refs, Literal val)

    List (Reference ref :: exprs) ->
      let
        f = 
          Dict.get ref refs 
            |> Maybe.map (evaluate refs >> Result.map Tuple.second) 
            |> Maybe.withDefault (Err <| UnboundReference ref)
        args = 
          List.map (evaluate refs >> Result.map Tuple.second) exprs
            |> Result.Extra.combine
      in
      Result.map2 apply f args
        |> Result.andThen identity
        |> Result.map (Tuple.pair refs)

    List _ ->
      Ok (refs, expr)

    Function f ->
      Ok (refs, Function f)

{-| -}
apply : Expression -> List Expression -> Result Error Expression
apply expr args =
  case expr of
    Function f ->
      f args

    _ ->
      Err <| NotAFunction expr

{- Core Library ------------------------------------------------------------- -}
{-| -}
core : ReferenceTable
core =
  Dict.fromList
    [ ("+", Function add)
    , ("*", Function mul)
    , ("-", Function sub)
    , ("/", Function div)
    ]

{-| -}
add : List Expression -> Result Error Expression
add args =
  List.foldl (\expr val ->
    case (expr, val) of
      (Literal x, Ok (Literal y)) ->
        Ok <| Literal <| Number <| literal_to_number x + literal_to_number y

      _ ->
        Err <| BadArgs ["number|string|bool"] args

  ) (Ok <| Literal <| Number 0) args

{-| -}
mul : List Expression -> Result Error Expression
mul args =
  List.foldl (\expr val ->
    case (expr, val) of
      (Literal x, Ok (Literal y)) ->
        Ok <| Literal <| Number <| literal_to_number x * literal_to_number y

      _ ->
        Err <| BadArgs ["number|string|bool"] args

  ) (Ok <| Literal <| Number 1) args

{-| -}
sub : List Expression -> Result Error Expression
sub args =
  List.foldr (\expr val ->
    case (expr, val) of
      (Literal x, Ok (Literal y)) ->
        Ok <| Literal <| Number <| literal_to_number x - literal_to_number y

      _ ->
        Err <| BadArgs ["number|string|bool"] args

  ) (Ok <| Literal <| Number 0) args

{-| -}
div : List Expression -> Result Error Expression
div args =
  List.foldr (\expr val ->
    case (expr, val) of
      (Literal x, Ok (Literal y)) ->
        Ok <| Literal <| Number <| literal_to_number x / literal_to_number y

      _ ->
        Err <| BadArgs ["number|string|bool"] args

  ) (Ok <| Literal <| Number 1) args


{- Parser ------------------------------------------------------------------- -}
parse : String -> List Expression
parse input =
  Parser.run program input
    |> Result.withDefault []

{- Parser Constants --------------------------------------------------------- -}
{-| These symbols are all valid as references, basically everything but the
various brackets are good to go.
-}
symbols : List Char
symbols =
  [ '!', '#', '$', '%', '&', '|', '*', '+', '-', '/', ':', '<', '=', '>', '?', '@', '^', '_', '~' ]

{- Expression Parsers ------------------------------------------------------- -}
{-| -}
program : Parser (List Expression)
program =
  Parser.loop [] (\exprs ->
    Parser.oneOf
      [ Parser.succeed (\expr -> Parser.Loop (expr :: exprs))
          |. Parser.spaces
          |= expression
          |. Parser.spaces
      , Parser.succeed ()
          |> Parser.map (\_ -> Parser.Done (List.reverse exprs))
      ]
  )

{-| -}
expression : Parser Expression
expression =
  Parser.lazy (\_ -> 
    Parser.oneOf
      [ literal
      , list
      , reference
      ]
  )

{-| -}
reference : Parser Expression
reference =
  Parser.succeed ((<<) Reference << (++))
    |. Parser.spaces
    |= Parser.getChompedString (Parser.chompIf (\c -> Char.isAlpha c || List.member c symbols))
    |= Parser.getChompedString (Parser.chompWhile (\c -> Char.isAlphaNum c || List.member c symbols))
    |. Parser.spaces

{-| -}
literal : Parser Expression
literal =
  Parser.succeed Literal
    |= value

{-| -}
list : Parser Expression
list =
  Parser.succeed List
    |. Parser.token "("
    |= loop expression
    |. Parser.token ")"

{- Literal Parsers ---------------------------------------------------------- -}
{-| -}
value : Parser Value
value =
  Parser.oneOf
    [ Parser.backtrackable int
    , Parser.backtrackable float
    , Parser.backtrackable string
    , Parser.backtrackable boolean
    ]

{-| -}
int : Parser Value
int =
  Parser.succeed (Basics.toFloat >> Number)
    |. Parser.spaces
    |= Parser.int
    |. Parser.spaces

{-| -}
float : Parser Value
float =
  Parser.succeed Number
    |. Parser.spaces
    |= Parser.float
    |. Parser.spaces

{-| -}
string : Parser Value
string =
  Parser.succeed String |= Parser.oneOf
    [ Parser.succeed identity
      |. Parser.spaces
      |. Parser.token "'"
      |= Parser.getChompedString (Parser.chompUntil "'")
      |. Parser.token "'"
      |. Parser.spaces
    , Parser.succeed identity
      |. Parser.spaces
      |. Parser.token "\""
      |= Parser.getChompedString (Parser.chompUntil "\"")
      |. Parser.token "\""
      |. Parser.spaces
    ]

{-| -}
boolean : Parser Value
boolean =
  Parser.oneOf
    [ Parser.map (\_ -> Boolean True) (Parser.keyword "true")
    , Parser.map (\_ -> Boolean False) (Parser.keyword "false")
    ]

{- Util Parsers ------------------------------------------------------------- -}
{-| -}
loop : Parser a -> Parser (List a)
loop parser =
  let
    helper items =
      Parser.oneOf
      [ Parser.succeed (\item -> Parser.Loop (item :: items))
          |. Parser.spaces
          |= parser
          |. Parser.spaces
      , Parser.succeed ()
          |> Parser.map (\_ -> Parser.Done (List.reverse items))
      ]
  in
  Parser.loop [] helper