{-# 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, manyTill, optional, parse, some, try)
import Text.Megaparsec.Char (alphaNumChar, char, digitChar, 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
  | Lit Int
  | StrLit 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
  Lit n -> Eval.Num n
  StrLit s -> Eval.Str s
  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.Num n -> Lit n
  Eval.Str s -> StrLit 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
  Lit n -> prettyInt n
  StrLit s -> "\"" <> escapeString s <> "\""
  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 <> ")"

-- | Escape special characters in a string literal for pretty-printing.
-- Only @\"@ and @\\@ need escaping; the parser uses 'L.charLiteral' which
-- understands standard Haskell escape sequences.
escapeString :: Text -> Text
escapeString = Text.concatMap go
  where
    go '"'  = "\\\""
    go '\\' = "\\\\"
    go c    = Text.singleton c

-- | Render an integer with no space between '-' and digits for negative numbers.
prettyInt :: Int -> Text
prettyInt n
  | n < 0     = "-" <> Text.pack (show (abs n))
  | otherwise = Text.pack (show n)

parseProgram :: Text -> Either ParseError [AST]
parseProgram input =
  first (ParseError . pack . errorBundlePretty) $
    Text.Megaparsec.parse (many ast) "" input

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 strLit <|> try lit <|> 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

-- | Parse an integer literal.  The minus sign, if present, must immediately
-- precede the digits with no intervening whitespace; this distinguishes @-7@
-- (a negative number) from @- 7@ (the identifier @-@ applied to @7@).
lit :: Parser AST
lit = lexeme $ do
  sign <- optional (char '-')
  digits <- some digitChar
  let n = read digits
  pure $ Lit $ case sign of
    Just _  -> negate n
    Nothing -> n

-- | Parse a double-quoted string literal.
-- Uses 'L.charLiteral' for each character so that standard Haskell escape
-- sequences (e.g. @\"@, @\\@, @\n@, @\t@) are handled automatically.
strLit :: Parser AST
strLit = lexeme $ do
  chars <- char '"' *> manyTill L.charLiteral (char '"')
  pure $ StrLit $ pack chars

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