content: module Data.SCargot.Common
    ( -- $intro
      parseR5RSIdent,
      parseR6RSIdent,
      parseR7RSIdent,
      parseXIDIdentStrict,
      parseXIDIdentGeneral,
      parseHaskellIdent,
      parseHaskellVariable,
      parseHaskellConstructor,
  
      -- * Numeric Literal Parsers
      signed,
      prefixedNumber,
      signedPrefixedNumber,
      binNumber,
      signedBinNumber,
      octNumber,
      signedOctNumber,
      decNumber,
      signedDecNumber,
      dozNumber,
      signedDozNumber,
      hexNumber,
      signedHexNumber,
  
      -- ** Numeric Literals for Arbitrary Bases
      commonLispNumberAnyBase,
      gnuM4NumberAnyBase,
  
      -- ** Source locations
      Location (..),
      Located (..),
      located,
      dLocation,
    )
  where
  
  #if !MIN_VERSION_base(4,8,0)
  import Control.Applicative hiding ((<|>), many)
  #endif
  import Control.Monad (guard)
  import Data.Char
  import Data.Text (Text)
  import qualified Data.Text as T
  import Text.Parsec
  import Text.Parsec.Pos (newPos)
  import Text.Parsec.Text (Parser)
  
  -- | Parse an identifier according to the R5RS Scheme standard. This
  --   will not normalize case, even though the R5RS standard specifies
  --   that all identifiers be normalized to lower case first.
  --
  --   An R5RS identifier is, broadly speaking, alphabetic or numeric
  --   and may include various symbols, but no escapes.
  parseR5RSIdent :: Parser Text
  parseR5RSIdent =
    T.pack <$> ((:) <$> initial <*> many subsequent <|> peculiar)
    where
      initial = letter <|> oneOf "!$%&*/:<=>?^_~"
      subsequent = initial <|> digit <|> oneOf "+-.@"
      peculiar = string "+" <|> string "-" <|> string "..."
  
  hasCategory :: Char -> [GeneralCategory] -> Bool
  hasCategory c cs = generalCategory c `elem` cs
  
  -- | Parse an identifier according to the R6RS Scheme standard. An
  --   R6RS identifier may include inline hexadecimal escape sequences
  --   so that, for example, @foo@ is equivalent to @f\\x6f;o@, and is
  --   more liberal than R5RS as to which Unicode characters it may
  --   accept.
  parseR6RSIdent :: Parser Text
  parseR6RSIdent =
    T.pack <$> ((:) <$> initial <*> many subsequent <|> peculiar)
    where
      initial = constituent <|> oneOf "!$%&*/:<=>?^_~" <|> inlineHex
      constituent =
        letter
          <|> uniClass
            ( \c ->
                isLetter c
                  || isSymbol c
                  || hasCategory
                    c
                    [ NonSpacingMark,
                      LetterNumber,
                      OtherNumber,
                      DashPunctuation,
                      ConnectorPunctuation,
                      OtherPunctuation,
                      PrivateUse
                    ]
            )
      inlineHex = (chr . fromIntegral) <$> (string "\\x" *> hexNumber <* char ';')
      subsequent =
        initial <|> digit <|> oneOf "+-.@"
          <|> uniClass
            ( \c ->
                hasCategory
                  c
                  [ DecimalNumber,
                    SpacingCombiningMark,
                    EnclosingMark
                  ]
            )
      peculiar =
        string "+" <|> string "-" <|> string "..."
          <|> ((++) <$> string "->" <*> many subsequent)
      uniClass :: (Char -> Bool) -> Parser Char
      uniClass sp = satisfy (\c -> c > '\x7f' && sp c)
  
  -- | Parse an identifier according to the R7RS Scheme standard. An
  --   R7RS identifier, in addition to a typical identifier format,
  --   can also be a chunk of text surrounded by vertical bars that
  --   can contain spaces and other characters. Unlike R6RS, it does
  --   not allow escapes to be included in identifiers unless those
  --   identifiers are surrounded by vertical bars.
  parseR7RSIdent :: Parser Text
  parseR7RSIdent =
    T.pack
      <$> ( (:) <$> initial <*> many subsequent
              <|> char '|' *> many1 symbolElement <* char '|'
              <|> peculiar
          )
    where
      initial = letter <|> specInit
      specInit = oneOf "!$%&*/:<=>?^_~"
      subsequent = initial <|> digit <|> specSubsequent
      specSubsequent = expSign <|> oneOf ".@"
      expSign = oneOf "+-"
      symbolElement =
        noneOf "\\|"
          <|> hexEscape
          <|> mnemEscape
          <|> ('|' <$ string "\\|")
      hexEscape = chr . fromIntegral <$> (string "\\x" *> hexNumber <* char ';')
      mnemEscape =
        '\a' <$ string "\\a"
          <|> '\b' <$ string "\\b"
          <|> '\t' <$ string "\\t"
          <|> '\n' <$ string "\\n"
          <|> '\r' <$ string "\\r"
      peculiar =
        (: []) <$> expSign
          <|> cons2 <$> expSign <*> signSub <*> many subsequent
          <|> cons3 <$> expSign
            <*> char '.'
            <*> dotSub
            <*> many subsequent
          <|> cons2 <$> char '.' <*> dotSub <*> many subsequent
      dotSub = signSub <|> char '.'
      signSub = initial <|> expSign <|> char '@'
      cons2 a b cs = a : b : cs
      cons3 a b c ds = a : b : c : ds
  
  -- | Parse a Haskell variable identifier: a sequence of alphanumeric
  --   characters, underscores, or single quote that begins with a
  --   lower-case letter.
  parseHaskellVariable :: Parser Text
  parseHaskellVariable =
    T.pack
      <$> ( (:) <$> small
              <*> many
                ( small
                    <|> large
                    <|> digit'
                    <|> char '\''
                    <|> char '_'
                )
          )
    where
      small = satisfy isLower
      large = satisfy isUpper
      digit' = satisfy isDigit
  
  -- | Parse a Haskell constructor: a sequence of alphanumeric
  --   characters, underscores, or single quote that begins with an
  --   upper-case letter.
  parseHaskellConstructor :: Parser Text
  parseHaskellConstructor =
    T.pack
      <$> ( (:) <$> large
              <*> many
                ( small
                    <|> large
                    <|> digit'
                    <|> char '\''
                    <|> char '_'
                )
          )
    where
      small = satisfy isLower
      large = satisfy isUpper
      digit' = satisfy isDigit
  
  -- | Parse a Haskell identifer: a sequence of alphanumeric
  --   characters, underscores, or a single quote. This matches both
  --   variable and constructor names.
  parseHaskellIdent :: Parser Text
  parseHaskellIdent =
    T.pack
      <$> ( (:) <$> (large <|> small)
              <*> many
                ( small
                    <|> large
                    <|> digit'
                    <|> char '\''
                    <|> char '_'
                )
          )
    where
      small = satisfy isLower
      large = satisfy isUpper
      digit' = satisfy isDigit
  
  -- Ensure that a given character has the given Unicode category
  hasCat :: [GeneralCategory] -> Parser Char
  hasCat cats = satisfy (flip hasCategory cats)
  
  xidStart :: [GeneralCategory]
  xidStart =
    [ UppercaseLetter,
      LowercaseLetter,
      TitlecaseLetter,
      ModifierLetter,
      OtherLetter,
      LetterNumber
    ]
  
  xidContinue :: [GeneralCategory]
  xidContinue =
    xidStart
      ++ [ NonSpacingMark,
           SpacingCombiningMark,
           DecimalNumber,
           ConnectorPunctuation
         ]
  
  -- | Parse an identifier of unicode characters of the form
  --   @<XID_Start> <XID_Continue>*@, which corresponds strongly
  --   to the identifiers found in most C-like languages. Note that
  --   the @XID_Start@ category does not include the underscore,
  --   so @__foo@ is not a valid XID identifier. To parse
  --   identifiers that may include leading underscores, use
  --   'parseXIDIdentGeneral'.
  parseXIDIdentStrict :: Parser Text
  parseXIDIdentStrict =
    T.pack
      <$> ( (:) <$> hasCat xidStart
              <*> many (hasCat xidContinue)
          )
  
  -- | Parse an identifier of unicode characters of the form
  --   @(<XID_Start> | '_') <XID_Continue>*@, which corresponds
  --   strongly to the identifiers found in most C-like languages.
  --   Unlike 'parseXIDIdentStrict', this will also accept an
  --   underscore as leading character, which corresponds more
  --   closely to programming languages like C and Java, but
  --   deviates somewhat from the
  --   <http://unicode.org/reports/tr31/ Unicode Identifier and
  --   Pattern Syntax standard>.
  parseXIDIdentGeneral :: Parser Text
  parseXIDIdentGeneral =
    T.pack
      <$> ( (:) <$> (hasCat xidStart <|> char '_')
              <*> many (hasCat xidContinue)
          )
  
  -- | A helper function for defining parsers for arbitrary-base integers.
  --   The first argument will be the base, and the second will be the
  --   parser for the individual digits.
  number :: Integer -> Parser Char -> Parser Integer
  number base digits = foldl go 0 <$> many1 digits
    where
      go x d = base * x + toInteger (value d)
      value c
        | c >= 'a' && c <= 'z' = 0xa + (fromEnum c - fromEnum 'a')
        | c >= 'A' && c <= 'Z' = 0xa + (fromEnum c - fromEnum 'A')
        | c >= '0' && c <= '9' = fromEnum c - fromEnum '0'
        | c == '\x218a' = 0xa
        | c == '\x218b' = 0xb
        | otherwise = error ("Unknown letter in number: " ++ show c)
  
  digitsFor :: Int -> [Char]
  digitsFor n
    | n <= 10 = take n ['0' .. '9']
    | n <= 36 = take (n -10) ['A' .. 'Z'] ++ take (n -10) ['a' .. 'z'] ++ ['0' .. '9']
    | otherwise = error ("Invalid base for parser: " ++ show n)
  
  anyBase :: Integer -> Parser Integer
  anyBase n = number n (oneOf (digitsFor (fromIntegral n)))
  
  -- | A parser for Common Lisp's arbitrary-base number syntax, of
  --   the form @#[base]r[number]@, where the base is given in
  --   decimal. Note that this syntax begins with a @#@, which
  --   means it might conflict with defined reader macros.
  commonLispNumberAnyBase :: Parser Integer
  commonLispNumberAnyBase = do
    _ <- char '#'
    n <- decNumber
    guard (n >= 2 && n <= 36)
    _ <- char 'r'
    signed (anyBase n)
  
  -- | A parser for GNU m4's arbitrary-base number syntax, of
  --   the form @0r[base]:[number]@, where the base is given in
  --   decimal.
  gnuM4NumberAnyBase :: Parser Integer
  gnuM4NumberAnyBase = do
    _ <- string "0r"
    n <- decNumber
    guard (n >= 2 && n <= 36)
    _ <- char ':'
    signed (anyBase n)
  
  sign :: Num a => Parser (a -> a)
  sign =
    (pure id <* char '+')
      <|> (pure negate <* char '-')
      <|> pure id
  
  -- | Given a parser for some kind of numeric literal, this will attempt to
  --   parse a leading @+@ or a leading @-@ followed by the numeric literal,
  --   and if a @-@ is found, negate that literal.
  signed :: Num a => Parser a -> Parser a
  signed p = ($) <$> sign <*> p
  
  -- | Parses a number in the same way as 'prefixedNumber', with an optional
  --   leading @+@ or @-@.
  signedPrefixedNumber :: Parser Integer
  signedPrefixedNumber = signed prefixedNumber
  
  -- | Parses a number, determining which numeric base to use by examining
  --   the literal's prefix: @0x@ for a hexadecimal number, @0z@ for a
  --   dozenal number, @0o@ for an octal number, and @0b@ for a binary
  --   number (as well as the upper-case versions of the same.) If the
  --   base is omitted entirely, then it is treated as a decimal number.
  prefixedNumber :: Parser Integer
  prefixedNumber =
    (string "0x" <|> string "0X") *> hexNumber
      <|> (string "0o" <|> string "0O") *> octNumber
      <|> (string "0z" <|> string "0Z") *> dozNumber
      <|> (string "0b" <|> string "0B") *> binNumber
      <|> decNumber
  
  -- | A parser for non-signed binary numbers
  binNumber :: Parser Integer
  binNumber = number 2 (char '0' <|> char '1')
  
  -- | A parser for signed binary numbers, with an optional leading @+@ or @-@.
  signedBinNumber :: Parser Integer
  signedBinNumber = signed binNumber
  
  -- | A parser for non-signed octal numbers
  octNumber :: Parser Integer
  octNumber = number 8 (oneOf "01234567")
  
  -- | A parser for signed octal numbers, with an optional leading @+@ or @-@.
  signedOctNumber :: Parser Integer
  signedOctNumber = ($) <$> sign <*> octNumber
  
  -- | A parser for non-signed decimal numbers
  decNumber :: Parser Integer
  decNumber = number 10 digit
  
  -- | A parser for signed decimal numbers, with an optional leading @+@ or @-@.
  signedDecNumber :: Parser Integer
  signedDecNumber = ($) <$> sign <*> decNumber
  
  dozDigit :: Parser Char
  dozDigit = digit <|> oneOf "AaBb\x218a\x218b"
  
  -- | A parser for non-signed duodecimal (dozenal) numbers. This understands both
  --   the ASCII characters @'a'@ and @'b'@ and the Unicode characters @'\x218a'@ (↊)
  --   and @'\x218b'@ (↋) as digits with the decimal values @10@ and @11@
  --   respectively.
  dozNumber :: Parser Integer
  dozNumber = number 12 dozDigit
  
  -- | A parser for signed duodecimal (dozenal) numbers, with an optional leading @+@ or @-@.
  signedDozNumber :: Parser Integer
  signedDozNumber = ($) <$> sign <*> dozNumber
  
  -- | A parser for non-signed hexadecimal numbers
  hexNumber :: Parser Integer
  hexNumber = number 16 hexDigit
  
  -- | A parser for signed hexadecimal numbers, with an optional leading @+@ or @-@.
  signedHexNumber :: Parser Integer
  signedHexNumber = ($) <$> sign <*> hexNumber
  
  -- |
  data Location = Span !SourcePos !SourcePos
    deriving (Eq, Ord, Show)
  
  -- | Add support for source locations while parsing S-expressions, as described in this
  --   <https://www.reddit.com/r/haskell/comments/4x22f9/labelling_ast_nodes_with_locations/d6cmdy9/ Reddit>
  -- thread.
  data Located a = At !Location a
    deriving (Eq, Ord, Show)
  
  -- | Adds a source span to a parser.
  located :: Parser a -> Parser (Located a)
  located parser = do
    begin <- getPosition
    result <- parser
    end <- getPosition
    return $ At (Span begin end) result
  
  -- | A default location value
  dLocation :: Location
  dLocation = Span dPos dPos
    where
      dPos = newPos "" 0 0
  
  -- $intro
  --
  -- This module contains a selection of parsers for different kinds of
  -- identifiers and literals, from which more elaborate parsers can be
  -- assembled. These can afford the user a quick way of building parsers
  -- for different atom types.
  