Parse.hs

module Axel.Parse where

import Axel.Prelude

import Axel.Eff.Error (Error(ParseError))
import Axel.Haskell.Language
  ( haskellKeywords
  , haskellOperatorSymbols
  , haskellSyntaxSymbols
  , isOperator
  )
import Axel.Parse.AST
  ( Expression(LiteralChar, LiteralFloat, LiteralInt, LiteralString,
           SExpression, Symbol)
  , bottomUpFmapSplicing
  , getAnn
  )
import qualified Axel.Sourcemap as SM (Expression)
import Axel.Sourcemap
  ( Position(Position, _column, _line)
  , SourceMetadata
  , quoteSourceMetadata
  , wrapCompoundExpressions
  )
import Axel.Utils.List (remove, unsafeHead)
import qualified Axel.Utils.Text as T (remove)

import Control.Applicative ((<|>))
import Control.Lens (op)
import Control.Monad (void)

import Data.List ((\\), foldl')
import Data.Maybe (fromMaybe)
import Data.MonoTraversable (onotElem)
import qualified Data.Text as T
import Data.Void (Void)

import Effectful ((:>))
import qualified Effectful as Eff
import qualified Effectful.Error.Static as Eff

import qualified Text.Megaparsec as P
import qualified Text.Megaparsec.Char as P
import qualified Text.Megaparsec.Char.Lexer as P
  ( charLiteral
  , decimal
  , float
  , signed
  )

type Parser = P.Parsec Void Text

-- Adapted from https://hackage.haskell.org/package/megaparsec-7.0.5/docs/Text-Megaparsec-Char-Lexer.html#v:charLiteral.
stringLiteral :: Parser Text
stringLiteral = T.pack <$> (P.char '"' *> P.manyTill P.charLiteral (P.char '"'))

ann :: (SourceMetadata -> a -> b) -> Parser a -> Parser b
ann f x = do
  parsecPosition <- P.getSourcePos
  let sourcePosition =
        ( P.sourceName parsecPosition
        , Position
            { _line = P.unPos $ P.sourceLine parsecPosition
            , _column = P.unPos $ P.sourceColumn parsecPosition
            })
  f (Just sourcePosition) <$> x

parseReadMacro :: Text -> Text -> Parser SM.Expression
parseReadMacro prefix wrapper = do
  expr <- P.string prefix *> expression
  ann SExpression (pure [Symbol Nothing (T.unpack wrapper), expr])

eol :: Parser ()
eol = void P.eol <|> P.eof

ignored :: Parser ()
ignored =
  P.skipMany $ P.try singleLineComment <|> multiLineComment <|> void P.spaceChar

literalChar :: Parser SM.Expression
literalChar = ann LiteralChar (P.string "#\\" *> P.charLiteral)

literalInt :: Parser SM.Expression
literalInt = ann LiteralInt (P.signed mempty P.decimal)

literalFloat :: Parser SM.Expression
literalFloat = ann LiteralFloat (P.signed mempty P.float)

literalList :: Parser SM.Expression
literalList =
  ann
    SExpression
    ((Symbol Nothing "list" :) <$>
     (P.char '[' *> P.many sExpressionItem <* P.char ']'))

literalString :: Parser SM.Expression
literalString = ann LiteralString (T.unpack <$> stringLiteral)

quasiquotedExpression :: Parser SM.Expression
quasiquotedExpression = parseReadMacro "`" "quasiquote"

quotedExpression :: Parser SM.Expression
quotedExpression = parseReadMacro "'" "quote"

sExpressionItem :: Parser SM.Expression
sExpressionItem = ignored *> expression <* ignored

sExpression :: Parser SM.Expression
sExpression =
  ann SExpression (P.char '(' *> P.many sExpressionItem <* P.char ')')

infixSExpression :: Parser SM.Expression
infixSExpression =
  ann
    SExpression
    ((Symbol Nothing "applyInfix" :) <$>
     (P.char '{' *> P.many sExpressionItem <* P.char '}'))

spliceUnquotedExpression :: Parser SM.Expression
spliceUnquotedExpression = parseReadMacro "~@" "unquoteSplicing"

symbol :: Parser SM.Expression
symbol =
  ann Symbol $
  hygenisizeIdentifier <$>
  P.some
    (P.alphaNumChar <|> P.oneOf ['\'', '_'] <|>
     P.oneOf (map fst haskellSyntaxSymbols \\ syntaxSymbols) <|>
     P.oneOf (map fst haskellOperatorSymbols))

unquotedExpression :: Parser SM.Expression
unquotedExpression = parseReadMacro "~" "unquote"

singleLineComment :: Parser ()
singleLineComment =
  P.try (P.string "--" *> eol) <|>
  void (P.string "-- " *> P.manyTill (void P.anySingle) eol)

multiLineComment :: Parser ()
multiLineComment =
  void $ P.try (P.string "{-") *> P.manyTill (void P.anySingle) (P.string "-}")

expression :: Parser SM.Expression
expression =
  P.try literalFloat <|> P.try literalInt <|> sExpression <|> infixSExpression <|>
  literalList <|>
  literalString <|>
  quotedExpression <|>
  quasiquotedExpression <|>
  spliceUnquotedExpression <|>
  unquotedExpression <|>
  literalChar <|>
  symbol

-- Adapted from Appendix A of "Quasiquotation in Lisp" by Alan Bawden.
expandQuasiquote :: SM.Expression -> SM.Expression
expandQuasiquote (SExpression _ [Symbol _ "unquote", expr]) = expr
expandQuasiquote (SExpression _ [Symbol _ "unquoteSplicing", _]) =
  error
    "Illegal splicing unquote at the top level of a quasiquote! (`~@foo is not allowed, but `(~@foo) is.)"
expandQuasiquote (SExpression ann' xs) =
  SExpression
    ann'
    [ Symbol ann' "AxelRuntime_AST.SExpression"
    , quoteSourceMetadata ann'
    , SExpression
        ann'
        [ Symbol ann' "concat"
        , SExpression ann' (Symbol ann' "list" : map expandQuasiquoteInList xs)
        ]
    ]
expandQuasiquote expr =
  let ann' = getAnn expr
   in SExpression ann' [Symbol ann' "quote", expr]

expandQuasiquoteInList :: SM.Expression -> SM.Expression
expandQuasiquoteInList (SExpression _ [Symbol _ "unquoteSplicing", expr]) =
  let ann' = getAnn expr
   in SExpression ann' [Symbol ann' "AxelRuntime_AST.toExpressionList", expr]
expandQuasiquoteInList expr =
  let ann' = getAnn expr
   in SExpression ann' [Symbol ann' "list", expandQuasiquote expr]

parseMultiple' ::
     (Eff.Error Error :> effs)
  => ([SM.Expression] -> [SM.Expression])
  -> Maybe FilePath
  -> Text
  -> Eff.Eff effs [SM.Expression]
parseMultiple' postProcess maybeFilePath input =
  either throwErr (pure . postProcess) $
  P.parse program (T.unpack $ op FilePath filePath) input
  where
    filePath = fromMaybe (FilePath "") maybeFilePath
    program = P.some (ignored *> expression <* ignored) <* P.eof
    throwErr =
      Eff.throwError . ParseError filePath . T.pack . P.errorBundlePretty

parseMultiple ::
     (Eff.Error Error :> effs)
  => Maybe FilePath
  -> Text
  -> Eff.Eff effs [SM.Expression]
parseMultiple = parseMultiple' expandQuasiquotes
  where
    expandQuasiquotes =
      map $
      bottomUpFmapSplicing
        (\case
           SExpression _ (Symbol _ "quasiquote":xs') -> map expandQuasiquote xs'
           x -> [x])

parseSource ::
     (Eff.Error Error :> effs)
  => Maybe FilePath
  -> Text
  -> Eff.Eff effs SM.Expression
parseSource filePath input =
  wrapCompoundExpressions <$> parseMultiple filePath input

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

charReplacements ::
     [(Char, String)] -> [(Char, String)] -> String -> [(Char, String)]
charReplacements syntaxCharReplacements operatorCharReplacements x =
  let targetCharReplacements =
        syntaxCharReplacements <>
        if isOperator x
          then []
          else operatorCharReplacements
   in allowQualifiedNames $
      filter (\(sym, _) -> sym `onotElem` syntaxSymbols) targetCharReplacements
  where
    allowQualifiedNames = remove $ (== '.') . fst

valueHygienePrefix :: Text
valueHygienePrefix = "aXEL_VALUE_"

hygenisizeIdentifier :: String -> String
hygenisizeIdentifier x
  | [(_, new)] <- filter ((x ==) . fst) haskellKeywords = new
  | otherwise =
    let prefix =
          if unsafeHead x `elem` map fst replacements
            then valueHygienePrefix
            else ""
     in T.unpack $
        prefix <>
        foldl'
          (\acc (old, new) -> T.replace (T.singleton old) (T.pack new) acc)
          (T.pack x)
          replacements
  where
    replacements =
      charReplacements haskellSyntaxSymbols haskellOperatorSymbols x

unhygenisizeIdentifier :: String -> String
unhygenisizeIdentifier x
  | [(old, _)] <- filter ((x ==) . snd) haskellKeywords = old
  | otherwise -- There _could_ be multiple matches, but that would be VERY, VERY BAD™.
   =
    T.unpack $
    T.remove valueHygienePrefix $ -- The prefix isn't always there, in which case this just no-ops.
    foldl'
      (\acc (old, new) -> T.replace (T.pack new) (T.singleton old) acc)
      (T.pack x) $
    charReplacements haskellSyntaxSymbols haskellOperatorSymbols x