bergamot-elm/src/Bergamot/ObjectLanguage.elm

port module Bergamot.ObjectLanguage exposing (..)

import Bergamot.Syntax as Syntax exposing (toString)
import Bergamot.Parser exposing (strLit)

import Platform exposing (worker)
import Parser exposing (Parser, Trailing(..), (|.), (|=), run)
import Set

type Type
    = TInt
    | TStr
    | TPair Type Type
    | TArr Type Type

type Expr
    = IntLit Int
    | FloatLit Float
    | StrLit String
    | Plus Expr Expr
    | Pair Expr Expr
    | Fst Expr
    | Snd Expr
    | Abs String Type Expr
    | App Expr Expr
    | Ref String

parenthed : Parser a -> Parser a
parenthed val = Parser.succeed (\x -> x)
    |. Parser.symbol "("
    |. Parser.spaces
    |= val
    |. Parser.spaces
    |. Parser.symbol ")"

pair : Parser a -> Parser (a, a)
pair elem = parenthed <|
    Parser.succeed Tuple.pair
    |= elem
    |. Parser.spaces
    |. Parser.symbol ","
    |. Parser.spaces
    |= elem

type_ : Parser Type
type_ = Parser.lazy <| \() -> Parser.oneOf
    [ Parser.backtrackable <| Parser.succeed TArr
        |= typeBasic
        |. Parser.spaces
        |. Parser.symbol "->"
        |. Parser.spaces
        |= type_
    , typeBasic
    ]

typeBasic : Parser Type
typeBasic = Parser.lazy <| \() -> Parser.oneOf
    [ Parser.succeed TInt |. Parser.keyword "number"
    , Parser.succeed TStr |. Parser.keyword "string"
    , Parser.backtrackable <| Parser.map (\(a, b) -> TPair a b) <| pair type_
    , parenthed type_
    ]

variable : Parser String
variable = Parser.variable
    { start = Char.isAlphaNum
    , inner = Char.isAlphaNum
    , reserved = Set.fromList ["fst", "snd", "let", "in"]
    }

expr : Parser Expr
expr = Parser.lazy <| \() -> Parser.oneOf
    [ Parser.backtrackable <| Parser.succeed Plus
        |= exprBasic
        |. Parser.spaces
        |. Parser.symbol "+"
        |. Parser.spaces
        |= expr
    , exprApps
    ]

topLevelExpr : Parser Expr
topLevelExpr = expr |. Parser.end

exprApps : Parser Expr
exprApps =
    let
        handle l =
            case l of
                [] -> Parser.problem "no applications found"
                x :: xs -> Parser.succeed <| List.foldl (\a b -> App b a) x xs
    in
        Parser.sequence
            { start = ""
            , separator = " "
            , end = ""
            , spaces = Parser.succeed ()
            , item = exprBasic
            , trailing = Optional
            }
        |> Parser.andThen handle

exprBasic : Parser Expr
exprBasic = Parser.lazy <| \() -> Parser.oneOf
    [ Parser.backtrackable <|
      Parser.number
        { int = Just IntLit
        , hex = Nothing
        , octal = Nothing
        , binary = Nothing
        , float = Just FloatLit
        }
    , Parser.backtrackable (Parser.succeed StrLit |= strLit)
    , Parser.backtrackable <| Parser.map (\(a, b) -> Pair a b) <| pair expr
    , Parser.succeed Fst
        |. Parser.keyword "fst"
        |. Parser.spaces
        |= parenthed expr
    , Parser.succeed Snd
        |. Parser.keyword "snd"
        |. Parser.spaces
        |= parenthed expr
    , Parser.succeed Abs
        |. Parser.symbol "\\"
        |. Parser.spaces
        |= variable
        |. Parser.spaces
        |. Parser.symbol ":"
        |. Parser.spaces
        |= type_
        |. Parser.spaces
        |. Parser.symbol "."
        |. Parser.spaces
        |= expr
    , Parser.succeed Ref |= variable
    , parenthed expr
    ]

typeToTerm : Type -> Syntax.Term ()
typeToTerm t =
    case t of
        TInt -> Syntax.Call "number" []
        TStr -> Syntax.Call "string" []
        TPair t1 t2 -> Syntax.Call "tpair" [ typeToTerm t1, typeToTerm t2 ]
        TArr t1 t2 -> Syntax.Call "tarr" [ typeToTerm t1, typeToTerm t2 ]

exprToTerm : Expr -> Syntax.Term ()
exprToTerm e =
    case e of
        IntLit i -> Syntax.Call "lit" [Syntax.IntLit i]
        FloatLit f -> Syntax.Call "lit" [Syntax.FloatLit f]
        StrLit s -> Syntax.Call "lit" [Syntax.StringLit s]
        Plus e1 e2 -> Syntax.Call "plus" [exprToTerm e1, exprToTerm e2]
        Pair e1 e2 -> Syntax.Call "pair" [exprToTerm e1, exprToTerm e2]
        Fst ep -> Syntax.Call "fst" [exprToTerm ep]
        Snd ep -> Syntax.Call "snd" [exprToTerm ep]
        Abs s t ep -> Syntax.Call "abs" [Syntax.Call s [], typeToTerm t, exprToTerm ep]
        App e1 e2 -> Syntax.Call "app" [exprToTerm e1, exprToTerm e2]
        Ref x -> Syntax.Call "var" [Syntax.Call x []]

-- Receives requests from JS code to apply the parser
port parseString : (String -> msg) -> Sub msg

-- Used to send the result of parsing back to JS
port parsedString : { string : String, term : Maybe String } -> Cmd msg

type Msg = ParseString String
type alias Model = ()
type alias Flags = ()

init : Flags -> (Model, Cmd Msg)
init _ = ((), Cmd.none)

update : Msg -> Model -> (Model, Cmd Msg)
update (ParseString s) _ =
    case run topLevelExpr s of
        Ok e ->
            ( ()
            , parsedString
                { string = s
                , term =
                    exprToTerm e
                    |> toString (\_ -> "")
                    |> Just
                }
            )
        Err _ -> ((), parsedString { string = s, term = Nothing })

subscriptions : Model -> Sub Msg
subscriptions _ = parseString ParseString

main = worker { init = init, update = update, subscriptions = subscriptions }