{-# LANGUAGE LambdaCase #-}

module Minilang.Lambda.Parser where

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

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 sym -> Eval.Var sym
  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 sym -> sym
  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 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
           )
    )

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