Lexer.hs

-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

-- TODO [#712]: Remove this next major release
{-# OPTIONS_GHC -Wno-redundant-constraints #-}

module Morley.Michelson.Parser.Lexer
  ( lexeme
  , mSpace
  , spaces
  , symbol
  , symbol'
  , symbol1
  , symbol1'
  , word
  , word'
  , string'
  , parens
  , braces
  , brackets
  , brackets'
  , semicolon
  , comma
  , varID
  ) where

import Prelude hiding (try)

import Data.Char (isDigit, isLower, toLower)
import Data.Text qualified as T
import Text.Megaparsec (Tokens, between, choice, eof, hidden, lookAhead, satisfy, try)
import Text.Megaparsec.Char (lowerChar, space, space1, string)
import Text.Megaparsec.Char.Lexer qualified as L

import Morley.Michelson.Parser.Types (Parser, Parser')
import Morley.Michelson.Untyped qualified as U

-- Lexing
lexeme :: Parser le a -> Parser le a
lexeme = L.lexeme spaces

mSpace :: Parser le ()
mSpace = L.space space1
  (L.skipLineComment "#" >> optionalSemicolon)
  (L.skipBlockComment "/*" "*/" >> optionalSemicolon)
  where
    optionalSemicolon = space >> void (optional semicolon)

spaces :: Parser le ()
spaces =
  (mandatorySpaceOrComment >> mSpace)
  <|> hasFollowingDelimiter ["}", "{", "]", ")", "|", ",", ";", ":", "."]
  <|> eof
  where
    mandatorySpaceOrComment = hidden (space1 <|> L.skipBlockComment "/*" "*/")
    hasFollowingDelimiter = hidden . choice . map (void . lookAhead . string)

symbol :: Tokens Text -> Parser le ()
symbol = void . L.symbol mSpace

symbol' :: Text -> Parser le ()
symbol' str = symbol str <|> symbol (T.map toLower str)

symbol1 :: Tokens Text -> Parser le ()
symbol1 = try . void . L.symbol spaces

symbol1' :: Text -> Parser le ()
symbol1' str = symbol1 str <|> symbol1 (T.map toLower str)

word :: Tokens Text -> a -> Parser le a
word str val = symbol1 str $> val

word' :: Tokens Text -> a -> Parser le a
word' str val = symbol1' str $> val

string' :: Text -> Parser le Text
string' str = string str <|> string (T.map toLower str)

parens :: Parser le a -> Parser le a
parens = between (symbol "(") (symbol ")")

braces :: Parser le a -> Parser le a
braces = between (symbol "{") (symbol "}")

brackets :: Parser le a -> Parser le a
brackets = between (symbol "[") (symbol "]")

brackets' :: Parser le a -> Parser le a
brackets' = between (string "[") (string "]")

semicolon :: Parser le ()
semicolon = symbol ";"

comma :: Parser le ()
comma = symbol ","

varID :: Parser le U.Var
varID = lexeme $ do
  v <- lowerChar
  vs <- many lowerAlphaNumChar
  return $ U.Var (toText (v:vs))
  where
    lowerAlphaNumChar :: Parser' le Char
    lowerAlphaNumChar = satisfy (\x -> isLower x || isDigit x)