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

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

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

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

parseTypeBasic : Parser Type
parseTypeBasic = Parser.lazy <| \() -> Parser.oneOf
    [ Parser.succeed TInt |. Parser.keyword "tint"
    , Parser.succeed TStr |. Parser.keyword "tstr"
    , Parser.backtrackable <| Parser.map (\(a, b) -> TPair a b) <| parsePair parseType
    , parseParenthed parseType
    ]

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

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

parseExprApps : Parser Expr
parseExprApps =
    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 = parseExprBasic
            , trailing = Optional
            }
        |> Parser.andThen handle

parseExprBasic : Parser Expr
parseExprBasic = Parser.lazy <| \() -> Parser.oneOf
    [ Parser.backtrackable (Parser.succeed IntLit |= Parser.int)
    , Parser.backtrackable <| Parser.map (\(a, b) -> Pair a b) <| parsePair parseExpr
    , Parser.succeed Fst
        |. Parser.keyword "fst"
        |. Parser.spaces
        |= parseParenthed parseExpr
    , Parser.succeed Snd
        |. Parser.keyword "snd"
        |. Parser.spaces
        |= parseParenthed parseExpr
    , Parser.succeed Abs
        |. Parser.symbol "\\"
        |. Parser.spaces
        |= parseVariable
        |. Parser.spaces
        |. Parser.symbol ":"
        |. Parser.spaces
        |= parseType
        |. Parser.spaces
        |. Parser.symbol "."
        |. Parser.spaces
        |= parseExpr
    , Parser.succeed Ref |= parseVariable
    , parseParenthed parseExpr
    ]

typeToTerm : Type -> Syntax.Term Metavariable
typeToTerm t =
    case t of
        TInt -> Syntax.Call "tint" []
        TStr -> Syntax.Call "tstr" []
        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 []]