-- NOTE Because `Axel.Parse.AST` will be used as the header of auto-generated macro programs,
--      it can't have any project-specific dependencies. As such, the instance definition for
--      `BottomUp Expression` can't be defined in the same file as `Expression` itself
--      (due to the dependency on `BottomUp`). Fortunately, `Axel.Parse.AST` will (should)
--      never be imported by itself but only implicitly as part of this module.
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}

module Axel.Parse
  ( module Axel.Parse
  , module Axel.Parse.AST
  ) where

import Axel.Error (Error(ParseError), fatal)

-- Re-exporting these so that consumers of parsed ASTs do not need
-- to know about the internal file.
import Axel.Haskell.Language (haskellOperatorSymbols, haskellSyntaxSymbols)
import Axel.Parse.AST
  ( Expression(LiteralChar, LiteralInt, LiteralString, SExpression,
           Symbol)
  )
import Axel.Utils.List (takeUntil)
import Axel.Utils.Recursion
  ( Recursive(bottomUpFmap, bottomUpTraverse, topDownFmap)
  )

import Control.Monad.Freer (Eff, Member)
import Control.Monad.Freer.Error (throwError)
import qualified Control.Monad.Freer.Error as Effs (Error)

import Data.Functor.Identity (Identity)
import Data.List ((\\))

import Text.Parsec (ParsecT, Stream, (<|>), eof, parse, try)
import Text.Parsec.Char (alphaNum, char, digit, noneOf, oneOf, space, string)
import Text.Parsec.Combinator (many1, optional)
import Text.Parsec.Language (haskellDef)
import Text.Parsec.Prim (many)
import Text.Parsec.Token (makeTokenParser, stringLiteral)

-- TODO `Expression` should probably instead be an instance of `Traversable`, use recursion schemes, etc.
--      If so, should I provide `toFix` and `fromFix` functions for macros to take advantage of?
--      (Maybe all macros have the argument automatically `fromFix`-ed to make consumption simpler?)
instance Recursive Expression where
  bottomUpFmap :: (Expression -> Expression) -> Expression -> Expression
  bottomUpFmap f x =
    f $
    case x of
      LiteralChar _ -> x
      LiteralInt _ -> x
      LiteralString _ -> x
      SExpression xs -> SExpression (map (bottomUpFmap f) xs)
      Symbol _ -> x
  bottomUpTraverse ::
       (Monad m) => (Expression -> m Expression) -> Expression -> m Expression
  bottomUpTraverse f x =
    f =<<
    case x of
      LiteralChar _ -> pure x
      LiteralInt _ -> pure x
      LiteralString _ -> pure x
      SExpression xs -> SExpression <$> traverse (bottomUpTraverse f) xs
      Symbol _ -> pure x
  topDownFmap :: (Expression -> Expression) -> Expression -> Expression
  topDownFmap f x =
    case f x of
      LiteralChar _ -> x
      LiteralInt _ -> x
      LiteralString _ -> x
      SExpression xs -> SExpression (map (topDownFmap f) xs)
      Symbol _ -> x

parseReadMacro :: String -> String -> ParsecT String u Identity Expression
parseReadMacro prefix wrapper = applyWrapper <$> (string prefix *> expression)
  where
    applyWrapper x = SExpression [Symbol wrapper, x]

any' :: (Stream s m Char) => ParsecT s u m Char
any' = noneOf ""

whitespace :: (Stream s m Char) => ParsecT s u m String
whitespace = many space

literalChar :: (Stream s m Char) => ParsecT s u m Expression
literalChar = LiteralChar <$> (string "#\\" *> any')

literalInt :: (Stream s m Char) => ParsecT s u m Expression
literalInt = LiteralInt . read <$> many1 digit

literalList :: ParsecT String u Identity Expression
literalList =
  SExpression . (Symbol "list" :) <$> (char '[' *> many item <* char ']')
  where
    item = try (whitespace *> expression) <|> expression

literalString :: ParsecT String u Identity Expression
literalString = LiteralString <$> stringLiteral (makeTokenParser haskellDef)

quasiquotedExpression :: ParsecT String u Identity Expression
quasiquotedExpression = parseReadMacro "`" "quasiquote"

quotedExpression :: ParsecT String u Identity Expression
quotedExpression = parseReadMacro "'" "quote"

sExpressionItem :: ParsecT String u Identity Expression
sExpressionItem = try (whitespace *> expression) <|> expression

sExpression :: ParsecT String u Identity Expression
sExpression = SExpression <$> (char '(' *> many sExpressionItem <* char ')')

infixSExpression :: ParsecT String u Identity Expression
infixSExpression =
  SExpression . (Symbol "applyInfix" :) <$>
  (char '{' *> many sExpressionItem <* char '}')

spliceUnquotedExpression :: ParsecT String u Identity Expression
spliceUnquotedExpression = parseReadMacro "~@" "unquoteSplicing"

symbol :: (Stream s Identity Char) => ParsecT s u Identity Expression
symbol =
  Symbol <$>
  many1
    (alphaNum <|> oneOf "'_" <|>
     oneOf (map fst haskellSyntaxSymbols \\ syntaxSymbols) <|>
     oneOf (map fst haskellOperatorSymbols))

unquotedExpression :: ParsecT String u Identity Expression
unquotedExpression = parseReadMacro "~" "unquote"

expression :: ParsecT String u Identity Expression
expression =
  literalChar <|> literalInt <|> literalList <|> literalString <|>
  quotedExpression <|>
  quasiquotedExpression <|>
  try spliceUnquotedExpression <|>
  unquotedExpression <|>
  sExpression <|>
  infixSExpression <|>
  symbol

-- TODO Derive this with Template Haskell (it's really brittle, currently).
quoteParseExpression :: Expression -> Expression
quoteParseExpression (LiteralChar x) =
  SExpression [Symbol "AST.LiteralChar", LiteralChar x]
quoteParseExpression (LiteralInt x) =
  SExpression [Symbol "AST.LiteralInt", LiteralInt x]
quoteParseExpression (LiteralString x) =
  SExpression [Symbol "AST.LiteralString", LiteralString x]
quoteParseExpression (SExpression xs) =
  SExpression
    [ Symbol "AST.SExpression"
    , SExpression (Symbol "list" : map quoteParseExpression xs)
    ]
quoteParseExpression (Symbol x) =
  SExpression [Symbol "AST.Symbol", LiteralString (handleEscapes x)]
  where
    handleEscapes =
      concatMap $ \case
        '\\' -> "\\\\"
        c -> [c]

parseMultiple ::
     (Member (Effs.Error Error) effs) => String -> Eff effs [Expression]
parseMultiple =
  either (throwError . ParseError . show) (pure . map expandQuotes) .
  parse
    (many1 (optional whitespace *> expression <* optional whitespace) <* eof)
    ""
  where
    expandQuotes =
      topDownFmap
        (\case
           SExpression [Symbol "quote", x] -> quoteParseExpression x
           x -> x)

parseSingle :: (Member (Effs.Error Error) effs) => String -> Eff effs Expression
parseSingle input =
  parseMultiple input >>= \case
    [x] -> pure x
    _ -> throwError $ ParseError "Only one expression was expected"

stripComments :: String -> String
stripComments = unlines . map cleanLine . lines
  where
    cleanLine = takeUntil "--"

parseSource :: (Member (Effs.Error Error) effs) => String -> Eff effs Expression
parseSource input = do
  statements <- parseMultiple $ stripComments input
  pure $ SExpression (Symbol "begin" : statements)

programToTopLevelExpressions :: Expression -> [Expression]
programToTopLevelExpressions (SExpression (Symbol "begin":stmts)) = stmts
programToTopLevelExpressions _ = fatal "programToTopLevelExpressions" "0001"

topLevelExpressionsToProgram :: [Expression] -> Expression
topLevelExpressionsToProgram stmts = SExpression (Symbol "begin" : stmts)

syntaxSymbols :: String
syntaxSymbols = "()[]{}"