{-# LANGUAGE LambdaCase #-}

module Minilang.Lambda.Parser where

import Control.Applicative (Alternative (many), (<|>))
import Data.Bifunctor (first)
import Data.Functor (void)
import qualified Data.List as List
import Data.Text (Text, pack)
import qualified Data.Text as Text
import Data.Void (Void)
import Minilang.Lambda.Eval (Term)
import qualified Minilang.Lambda.Eval as Eval
import Text.Megaparsec (Parsec, between, empty, errorBundlePretty, parse, try)
import Text.Megaparsec.Char (alphaNumChar, char, letterChar, space1, symbolChar)
import qualified Text.Megaparsec.Char.Lexer as L

type Parser = Parsec Void Text

data ParseError = ParseError Text
  deriving (Eq, Show)

data AST = Sym Text | Abs [Text] AST | App AST AST [AST]
  deriving (Eq, Show)

desugar :: AST -> Term
desugar = \case
  Sym symb -> Eval.Var symb
  Abs bound body ->
    foldr
      Eval.Lam
      (desugar body)
      bound
  App x y rest ->
    foldl
      (\acc a -> Eval.App acc (desugar a))
      (Eval.App (desugar x) (desugar y))
      rest

pretty :: AST -> Text
pretty = \case
  Sym symb -> symb
  Abs bound body -> "(lam (" <> Text.unwords bound <> ") " <> pretty body <> ")"
  App x y rest -> "(" <> mconcat (List.intersperse " " (pretty <$> (x : y : rest))) <> ")"

parse :: Text -> Either ParseError AST
parse =
  first (ParseError . pack . errorBundlePretty) . Text.Megaparsec.parse ast ""

ast :: Parser AST
ast = try letExpr <|> try lambda <|> try sym <|> try app

app :: Parser AST
app =
  between
    lpar
    rpar
    (App <$> ast <*> ast <*> many ast)

lambda :: Parser AST
lambda =
  between
    lpar
    rpar
    ( lexeme "lam"
        *> ( (Abs . fmap pack <$> between lpar rpar (many identifier))
               <*> ast
           )
    )

letExpr :: Parser AST
letExpr =
  between
    lpar
    rpar
    ( do
        void $ lexeme "let"
        (bound, binding) <-
          between
            lpar
            rpar
            ( (,) <$> identifier <*> ast
            )
        body <- ast
        let fun = Abs [pack bound] body
        return $ App fun binding []
    )

lpar :: Parser Text
lpar = symbol "("

rpar :: Parser Text
rpar = symbol ")"

symbol :: Text -> Parser Text
symbol = L.symbol spaceConsumer

sym :: Parser AST
sym = Sym . pack <$> identifier

identifier :: Parser String
identifier =
  lexeme $
    (:)
      <$> (letterChar <|> extraChars)
      <*> many (alphaNumChar <|> extraChars)

lexeme :: Parser a -> Parser a
lexeme = L.lexeme spaceConsumer

extraChars :: Parser Char
extraChars =
  foldl (\b a -> char a <|> b) symbolChar extraIdentifierChars

initialChars :: [Char]
initialChars =
  ['a' .. 'z'] <> ['A' .. 'Z'] <> extraIdentifierChars

restChars :: [Char]
restChars =
  initialChars <> ['0' .. '9']

extraIdentifierChars :: String
extraIdentifierChars = ['-', '_', '*', '#', '%', '&', ':', '@', '/']

spaceConsumer :: Parser ()
spaceConsumer =
  L.space space1 (L.skipLineComment ";") empty