bergamot-elm/src/Bergamot/ObjectLanguage.elm

module Bergamot.ObjectLanguage exposing (..)

import Bergamot.Syntax as Syntax exposing (Metavariable)

import Parser exposing (Parser, Trailing(..), (|.), (|=))
import Set

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

type Expr
    = IntLit Int
    | 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.succeed IntLit |= Parser.int)
    , 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 Metavariable
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 Metavariable
exprToTerm e =
    case e of
        IntLit i -> Syntax.Call "intlit" [Syntax.IntLit i]
        StrLit s -> Syntax.Call "strlit" [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 []]