path: root/src/Parser.hs

-- MIT License, Copyright (c) 2022 Marvin Borner
module Parser
  ( parseBlock
  , parseReplLine
  ) where

import           Control.Monad                  ( ap
                                                , void
                                                )
import           Conversion
import           Data.Void
import           GHC.Real                       ( (%) )
import           Text.Megaparsec         hiding ( parseTest )
import           Text.Megaparsec.Char

import           Helper

type Parser = Parsec Void String

-- exactly one space
sc :: Parser ()
sc = void $ char ' '

-- lower or upper
greekLetter :: Parser Char
greekLetter = satisfy isGreek
  where isGreek c = ('Α' <= c && c <= 'Ω') || ('α' <= c && c <= 'ω')

emoticon :: Parser Char
emoticon = satisfy isEmoticon
  where isEmoticon c = '\128512' <= c && c <= '\128591'

mathematicalOperator :: Parser Char
mathematicalOperator =
  satisfy isMathematicalUnicodeBlock
    <|> satisfy isMiscMathematicalAUnicodeBlock
    <|> oneOf "¬₀₁₂₃₄₅₆₇₈₉₊₋₌₍₎⁰¹²³⁴⁵⁶⁷⁸⁹⁺⁻⁼⁽⁾"
 where
  isMathematicalUnicodeBlock c = '∀' <= c && c <= '⋿'
  isMiscMathematicalAUnicodeBlock c = '⟀' <= c && c <= '⟯'

mathematicalArrow :: Parser Char
mathematicalArrow = satisfy isMathematicalOperator
  where isMathematicalOperator c = '←' <= c && c <= '⇿'

generalPunctuation :: Parser Char
generalPunctuation = satisfy isGeneralPunctuation
  where isGeneralPunctuation c = '‐' <= c && c <= '⁞' && c /= '…' && c /= '‣'

shapes :: Parser Char
shapes = satisfy isShapes where isShapes c = '─' <= c && c <= '◿'

-- "'" can't be in special chars because of 'c' char notation and prefixation
-- "." can't be in special chars because of namespaced functions and UFCS syntax
-- "," can't be in special chars because of unquote
specialChar :: Parser Char
specialChar =
  oneOf "!?*@:;+-_#$%^&<>/\\|{}~="
    <|> mathematicalOperator
    <|> mathematicalArrow
    <|> generalPunctuation
    <|> shapes

mixfixNone :: Parser MixfixIdentifierKind
mixfixNone = char '…' >> pure MixfixNone

mixfixSome :: Parser MixfixIdentifierKind
mixfixSome = MixfixSome <$> some specialChar

mixfixOperator :: Parser Identifier
mixfixOperator = normalMixfix <|> namespacedMixfix
 where
  normalMixfix     = MixfixFunction <$> some (mixfixNone <|> mixfixSome)
  namespacedMixfix = NamespacedFunction <$> dottedNamespace <*> mixfixOperator

prefixOperator :: Parser Identifier
prefixOperator = normalPrefix <|> namespacedPrefix
 where
  normalPrefix     = PrefixFunction <$> some specialChar
  namespacedPrefix = NamespacedFunction <$> dottedNamespace <*> prefixOperator

defIdentifier :: Parser Identifier
defIdentifier =
  try
      (   NormalFunction
      <$> ((:) <$> (lowerChar <|> greekLetter <|> emoticon) <*> many
            (alphaNumChar <|> specialChar <|> char '\'')
          )
      )
    <|> try (prefixOperator <* char '‣')
    <|> mixfixOperator
    <?> "defining identifier"

identifier :: Parser Identifier
identifier =
  try (NamespacedFunction <$> dottedNamespace <*> defIdentifier)
    <|> defIdentifier
    <?> "identifier"

namespace :: Parser String
namespace = (:) <$> upperChar <*> many letterChar <?> "namespace"

typeIdentifier :: Parser String
typeIdentifier = (:) <$> upperChar <*> many letterChar <?> "type"

polymorphicTypeIdentifier :: Parser String
polymorphicTypeIdentifier = many lowerChar <?> "polymorphic type"

dottedNamespace :: Parser String
dottedNamespace = (\n d -> n ++ [d]) <$> namespace <*> char '.'

parens :: Parser a -> Parser a
parens = between (string "(") (string ")")

importPath :: Parser String
importPath = some $ oneOf "./_+-" <|> letterChar <|> digitChar

parseAbstraction :: Parser Expression
parseAbstraction = do
  _ <- string "[" <?> "abstraction start"
  e <- parseExpression
  _ <- string "]" <?> "abstraction end"
  pure $ Abstraction e

parseBruijn :: Parser Expression
parseBruijn = do
  idx <- digitChar <?> "bruijn index"
  pure $ Bruijn $ (read . pure) idx

parseNumeral :: Parser Expression
parseNumeral = do
  _    <- string "(" <?> "number start"
  num  <- number <?> "signed number"
  base <- try (oneOf "dubt") <|> return 't'
  _    <- string ")" <?> "number end"
  pure $ f base num
 where
  f 't' = decimalToTernary
  f 'b' = decimalToBinary
  f 'u' = decimalToUnary
  f 'd' = decimalToDeBruijn
  f _   = invalidProgramState
  sign :: Parser (Integer -> Integer)
  sign = (char '-' >> return negate) <|> (char '+' >> return id)
  nat :: Parser Integer
  nat = read <$> some digitChar
  number :: Parser Integer
  number = ap sign nat

-- parsed float a.b to rational p/q
convertToRational :: Integer -> Integer -> Rational
convertToRational a b =
  let denominator :: Integer
      denominator = 10 ^ length (show b)
      numerator   = b + a * denominator
      common      = gcd numerator denominator
  in  (numerator `div` common) % (denominator `div` common)

parseFloat :: Parser Expression
parseFloat = do
  _    <- string "(" <?> "float start"
  num  <- signedFloat <?> "signed float"
  base <- try (oneOf "qr") <|> return 'q'
  _    <- string ")" <?> "float end"
  pure $ f base num
 where
  f 'q' = floatToRational
  f 'r' = floatToReal
  f _   = invalidProgramState
  sign :: Parser (Rational -> Rational)
  sign = (char '-' >> return negate) <|> (char '+' >> return id)
  float :: Parser Rational
  float = do
    a <- read <$> some digitChar <?> "digits"
    _ <- char '.' <?> "float delimiter"
    -- TODO: THIS IS WRONG! 4.002 is read as 4.2!
    b <- read <$> some digitChar <?> "digits"
    return $ convertToRational a b
  signedFloat :: Parser Rational
  signedFloat = ap sign float

parseComplex :: Parser Expression
parseComplex = do
  _         <- string "(" <?> "complex start"
  real      <- signedFloat <?> "signed complex"
  imaginary <- signedFloat <?> "signed complex"
  _         <- char 'i'
  _         <- string ")" <?> "complex end"
  pure $ floatToComplex real imaginary
 where
  sign :: Parser (Rational -> Rational)
  sign = (char '-' >> return negate) <|> (char '+' >> return id)
  float :: Parser Rational
  float = do
    a <- read <$> some digitChar <?> "digits"
    _ <- char '.' <?> "float delimiter"
    b <- read <$> some digitChar <?> "digits"
    return $ convertToRational a b
  signedFloat :: Parser Rational
  signedFloat = ap sign float

specialEscape :: Parser Char
specialEscape =
  choice (zipWith (\c r -> r <$ char c) "bnfrt\\\"/" "\b\n\f\r\t\\\"/")

parseString :: Parser Expression
parseString = do
  str <-
    between
        (char '\"')
        (char '\"')
        (some $ (char '\\' *> specialEscape) <|> satisfy (`notElem` "\"\\"))
      <?> "quoted string"
  pure $ stringToExpression str

parseChar :: Parser Expression
parseChar = do
  ch <-
    between (char '\'')
            (char '\'')
            ((char '\\' *> specialEscape) <|> satisfy (`notElem` "\"\\"))
      <?> "quoted char"
  pure $ charToExpression ch

parseFunction :: Parser Expression
parseFunction = Function <$> identifier

parseMixfix :: Parser Expression
parseMixfix = do
  s <- sepEndBy1
    (   try prefixAsMixfix
    <|> try prefixOperatorAsMixfix
    <|> try operatorAsMixfix
    <|> singletonAsMixfix
    )
    sc
  pure $ MixfixChain s
 where -- TODO: Rethink this.
  prefixAsMixfix = MixfixExpression <$> parsePrefix
  prefixOperatorAsMixfix =
    MixfixExpression . Function <$> prefixOperator <* char '‣'
  operatorAsMixfix  = MixfixOperator . MixfixFunction <$> some mixfixSome
  singletonAsMixfix = MixfixExpression <$> parseSingleton

parseQuote :: Parser Expression
parseQuote = do
  _ <- char '`' <?> "quote start"
  e <- parseSingleton
  pure $ Quote e

parseUnquote :: Parser Expression
parseUnquote = do
  _ <- char ',' <?> "unquote start"
  e <- parseSingleton
  pure $ Unquote e

parsePrefix :: Parser Expression
parsePrefix = do
  p <- prefixOperator
  e <- parseSingleton
  pure $ Prefix p e

parseSingleton :: Parser Expression
parseSingleton =
  let parseSingletonExpression =
        parseBruijn
          <|> try parseComplex
          <|> try parseNumeral
          <|> try parseFloat
          <|> parseString
          <|> try parseChar
          <|> parseQuote
          <|> parseUnquote
          <|> parseAbstraction
          <|> try parseFunction
          <|> parsePrefix
          <|> try (parens parseMixfix <?> "enclosed mixfix chain")
      parseUniformCall = do
        g <- parseSingletonExpression
        f <- some $ char '.' >> parseSingletonExpression
        pure $ foldr1 Application (reverse (g : f))
  in  try parseUniformCall <|> parseSingletonExpression

parseExpression :: Parser Expression
parseExpression = do
  e <- parseMixfix
  pure e <?> "expression"

parseEvaluate :: Parser Instruction
parseEvaluate = do
  inp <- getInput
  e   <- parseExpression
  pure $ ContextualInstruction (Evaluate e) inp

parseFunctionType :: Parser ()
parseFunctionType =
  sepBy1 (parseTypeSingleton <* optional (char '*')) (sc *> char '→' <* sc)
    >>  return ()
    <?> "function type"

parseConstructorType :: Parser ()
parseConstructorType = do
  _ <- typeIdentifier <|> polymorphicTypeIdentifier
  sc
  _ <- sepBy1 parseTypeSingleton sc
  return () <?> "constructor type"

parseTypeIdentifier :: Parser ()
parseTypeIdentifier = typeIdentifier >> return () <?> "type identifier"

parsePolymorphicTypeIdentifier :: Parser ()
parsePolymorphicTypeIdentifier =
  polymorphicTypeIdentifier >> return () <?> "polymorphic type identifier"

parseTypeSingleton :: Parser ()
parseTypeSingleton =
  try (parens parseFunctionType)
    <|> try (parens parseConstructorType)
    <|> try parseTypeIdentifier
    <|> try parsePolymorphicTypeIdentifier

parseTypeExpression :: Parser ()
parseTypeExpression = parseFunctionType <?> "type expression"

parseDefineType :: Parser ()
parseDefineType = do
  try (char '⧗' <* sc *> parseTypeExpression) <|> return ()

parseDefine :: Int -> Parser Instruction
parseDefine lvl = do
  inp <- getInput
  var <- defIdentifier
  sc
  e    <- parseExpression
  _    <- parseDefineType
  subs <-
    try (newline *> many (parseBlock $ lvl + 1)) <|> (try eof >> return [])
  pure $ ContextualInstruction (Define var e subs) inp

parseReplDefine :: Parser Instruction
parseReplDefine = do
  inp <- getInput
  var <- defIdentifier
  _   <- sc *> char '=' <* sc
  e   <- parseExpression
  _   <- parseDefineType
  pure $ ContextualInstruction (Define var e []) inp

parseComment :: Parser ()
parseComment = do
  _ <- char '#' <* sc <?> "comment"
  _ <- some $ noneOf "\r\n"
  return ()

parseTime :: Parser Command
parseTime = do
  _ <- string ":time" <* sc <?> "time instruction"
  e <- parseExpression
  pure $ Time e

parseLength :: Parser Command
parseLength = do
  _ <- string ":length" <* sc <?> "length instruction"
  e <- parseExpression
  pure $ Length e

parseBlc :: Parser Command
parseBlc = do
  _ <- string ":blc" <* sc <?> "blc instruction"
  e <- parseExpression
  pure $ Blc e

parseJot :: Parser Command
parseJot = do
  _   <- string ":jot" <* sc <?> "jot binary string"
  str <- some $ noneOf "\r\n"
  pure $ Jot str

parseClearState :: Parser Command
parseClearState = do
  _ <- string ":free" <?> "free instruction"
  pure ClearState

parseImport :: Parser Command
parseImport = do
  _    <- string ":import" <* sc <?> "import instruction"
  path <- importPath
  ns   <- try (sc *> (namespace <|> string ".")) <|> return ""
  pure $ Import (path ++ ".bruijn") ns

parseInput :: Parser Command
parseInput = do
  _    <- string ":input" <* sc <?> "input instruction"
  path <- importPath
  pure $ Input $ path ++ ".bruijn"

parseWatch :: Parser Command
parseWatch = do
  _    <- string ":watch" <* sc <?> "watch instruction"
  path <- importPath
  pure $ Watch $ path ++ ".bruijn"

parseTest :: Parser Command
parseTest = do
  _  <- string ":test" <* sc <?> "test"
  e1 <- parens parseExpression <?> "first expression"
  sc
  e2 <- parens parseExpression <?> "second expression"
  pure $ Test e1 e2

parseCommentBlock :: Parser Instruction
parseCommentBlock = do
  inp <- getInput
  _   <- sepEndBy1 parseComment newline
  eof
  return $ ContextualInstruction Comment inp

parseCommandBlock :: Parser Instruction
parseCommandBlock = do
  inp      <- getInput
  commands <-
    sepEndBy1 parseTest newline
    <|> sepEndBy1 parseInput  newline
    <|> sepEndBy1 parseImport newline
  return $ ContextualInstruction (Commands commands) inp

parseDefBlock :: Int -> Parser Instruction
parseDefBlock lvl =
  sepEndBy (try parseComment) newline *> string (replicate lvl '\t') *> try
    (parseDefine lvl)

parseBlock :: Int -> Parser Instruction
parseBlock lvl =
  try parseCommentBlock <|> try (parseDefBlock lvl) <|> parseCommandBlock

parseReplLine :: Parser Instruction
parseReplLine =
  try parseReplDefine -- TODO: This is kinda hacky
    <|> (Commands . (: []) <$> try parseTest)
    <|> (Commands . (: []) <$> try parseInput)
    <|> (Commands . (: []) <$> try parseWatch)
    <|> (Commands . (: []) <$> try parseImport)
    <|> (Commands . (: []) <$> try parseTime)
    <|> (Commands . (: []) <$> try parseLength)
    <|> (Commands . (: []) <$> try parseBlc)
    <|> (Commands . (: []) <$> try parseJot)
    <|> (Commands . (: []) <$> try parseClearState)
    <|> try parseEvaluate