{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE LambdaCase #-}

module Minilang.Lambda.Parser where

import Control.Applicative (Alternative (many), (<|>))
import Data.Aeson (FromJSON, ToJSON)
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 GHC.Generics (Generic)
import Minilang.Lambda.Eval (Term)
import qualified Minilang.Lambda.Eval as Eval
import Text.Megaparsec (Parsec, between, empty, errorBundlePretty, parse, some, 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]
  | Def Text AST
  deriving (Eq, Show, Generic, ToJSON, FromJSON)

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
  Def _name _body ->
    undefined

resugar :: Term -> AST
resugar = \case
  Eval.Var s -> Sym s
  Eval.Lam x body -> case resugar body of
    Abs vars ast -> Abs (x : vars) ast
    other -> Abs [x] other
  Eval.App l r -> case resugar l of
    App f a rest -> App f a (rest ++ [r'])
      where
        r' = resugar r
    other -> App other r' []
      where
        r' = resugar r

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))) <> ")"
  Def name body -> "(def " <> name <> " " <> pretty body <> ")"

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

ast :: Parser AST
ast = try defExpr <|> 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
           )
    )

defExpr :: Parser AST
defExpr =
  between
    lpar
    rpar
    ( lexeme "def"
        *> ((Def . pack <$> identifier) <*> ast)
    )

letExpr :: Parser AST
letExpr =
  between
    lpar
    rpar
    ( do
        void $ lexeme "let"
        bindings <-
          between
            lpar
            rpar
            (some binding)
        body <- ast
        return $ foldr mkLet body bindings
    )

mkLet :: (Text, AST) -> AST -> AST
mkLet (var, bound) body = App (Abs [var] body) bound []

binding :: Parser (Text, AST)
binding =
  between
    lpar
    rpar
    (((,) . pack <$> 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