{-# LANGUAGE Safe #-}
{-# LANGUAGE OverloadedLists #-}
{-# OPTIONS_HADDOCK hide #-}
module Text.Gigaparsec.Internal.Token.Names (
    Names, mkNames,
    identifier, identifier',
    userDefinedOperator, userDefinedOperator',
    lexeme
  ) where

import Text.Gigaparsec (Parsec, empty, (<:>), atomic)
import Text.Gigaparsec.Char (stringOfMany, satisfy)
import Text.Gigaparsec.Errors.Combinator ((<?>), unexpectedWhen)

import Data.Set qualified as Set (member, map)

import Text.Gigaparsec.Token.Descriptions (
    SymbolDesc(SymbolDesc, hardKeywords, hardOperators, caseSensitive),
    NameDesc(NameDesc, identifierStart, identifierLetter,
                       operatorStart, operatorLetter),
    CharPredicate
  )
import Data.Char (toLower)
import Text.Gigaparsec.Token.Errors (
    ErrorConfig (labelNameIdentifier, unexpectedNameIllegalIdentifier, labelNameOperator, unexpectedNameIllegalOperator, filterNameIllFormedIdentifier, filterNameIllFormedOperator)
  )
import Text.Gigaparsec.Internal.Token.Errors (filterS)

-- TODO: primes are gross, better way?
{-|
This class defines a uniform interface for defining parsers for user-defined names 
(identifiers and operators), independent of how whitespace should be handled after the name.

The parsing of names is mostly concerned with finding the longest valid name that is not a reserved name, 
such as a hard keyword or a special operator.
-}
type Names :: *
data Names = Names { 
  {-| 
  Parse an identifier based on the given 'NameDesc' predicates 'identifierStart' and 'identifierLetter'.
  The 'NameDesc' is provided by 'mkNames'.

  Capable of handling unicode characters if the configuration permits.
  If hard keywords are specified by the configuration, this parser is not permitted to parse them.
  -}
    Names -> Parsec [Char]
identifier :: !(Parsec String)
  {-| 
  Parse an identifier whose start satisfies the given predicate, and subseqeunt letters satisfy 'identifierLetter' in the given 'NameDesc'.
  The 'NameDesc' is provided by 'mkNames'.

  Behaves as 'identifier', then ensures the first character matches the given predicate.
  Thus, 'identifier'' can only /refine/ the output of 'identifier';
  if 'identifier' fails due to the first character, then so will 'identifier'', 
  even if this character passes the supplied predicate.
  
  Capable of handling unicode characters if the configuration permits.
  If hard keywords are specified by the configuration, this parser is not permitted to parse them.
  -}
  , Names -> CharPredicate -> Parsec [Char]
identifier' :: !(CharPredicate -> Parsec String)
  {-| 
  Parse a user-defined operator based on the given 'SymbolDesc' predicates 'operatorStart' and 'operatorLetter'.
  The 'SymbolDesc' is provided by 'mkNames'.

  Capable of handling unicode characters if the configuration permits. 
  If hard operators are specified by the configuration, this parser is not permitted to parse them.
  -}
  , Names -> Parsec [Char]
userDefinedOperator :: !(Parsec String)
  {-| 
  Parse a user-defined operator whose first character satisfies the given predicate,
  and subsequent characters satisfying 'operatorLetter' in the given 'SymbolDesc'.
  The 'SymbolDesc' is provided by 'mkNames'.

  Behaves as 'userDefinedOperator', then ensures the first character matches the given predicate.
  Thus, 'userDefinedOperator'' can only /refine/ the output of 'userDefinedOperator';
  if 'userDefinedOperator' fails due to the first character, then so will 'userDefinedOperator'', 
  even if this character passes the supplied predicate.

  Capable of handling unicode characters if the configuration permits. 
  If hard operators are specified by the configuration, this parser is not permitted to parse them.
  -}
  , Names -> CharPredicate -> Parsec [Char]
userDefinedOperator' :: !(CharPredicate -> Parsec String)
  }

{-|
Create a 'Names' -- an interface for parsing identifiers and operators 
-- according to the given name and symbol descriptions.
-}
mkNames :: NameDesc    -- ^ the description of identifiers.
        -> SymbolDesc  -- ^ the description of symbols.
        -> ErrorConfig -- ^ how errors should be produced on failed parses.
        -> Names       -- ^ a collection of parsers for identifiers and operators as described by the given descriptions.
mkNames :: NameDesc -> SymbolDesc -> ErrorConfig -> Names
mkNames NameDesc{CharPredicate
identifierStart :: NameDesc -> CharPredicate
identifierLetter :: NameDesc -> CharPredicate
operatorStart :: NameDesc -> CharPredicate
operatorLetter :: NameDesc -> CharPredicate
identifierStart :: CharPredicate
identifierLetter :: CharPredicate
operatorStart :: CharPredicate
operatorLetter :: CharPredicate
..} symbolDesc :: SymbolDesc
symbolDesc@SymbolDesc{Bool
Set [Char]
hardKeywords :: SymbolDesc -> Set [Char]
hardOperators :: SymbolDesc -> Set [Char]
caseSensitive :: SymbolDesc -> Bool
hardKeywords :: Set [Char]
hardOperators :: Set [Char]
caseSensitive :: Bool
..} !ErrorConfig
err = Names {Parsec [Char]
CharPredicate -> Parsec [Char]
identifier :: Parsec [Char]
identifier' :: CharPredicate -> Parsec [Char]
userDefinedOperator :: Parsec [Char]
userDefinedOperator' :: CharPredicate -> Parsec [Char]
identifier :: Parsec [Char]
identifier' :: CharPredicate -> Parsec [Char]
userDefinedOperator :: Parsec [Char]
userDefinedOperator' :: CharPredicate -> Parsec [Char]
..}
  where
    !isReserved :: [Char] -> Bool
isReserved = SymbolDesc -> [Char] -> Bool
isReservedName SymbolDesc
symbolDesc
    !identifier :: Parsec [Char]
identifier =
      CharPredicate
-> CharPredicate
-> ([Char] -> Bool)
-> [Char]
-> ([Char] -> [Char])
-> Parsec [Char]
keyOrOp CharPredicate
identifierStart CharPredicate
identifierLetter [Char] -> Bool
isReserved (ErrorConfig -> [Char]
labelNameIdentifier ErrorConfig
err) (ErrorConfig -> [Char] -> [Char]
unexpectedNameIllegalIdentifier ErrorConfig
err)
    identifier' :: CharPredicate -> Parsec [Char]
identifier' CharPredicate
start = FilterConfig [Char]
-> ([Char] -> Bool) -> Parsec [Char] -> Parsec [Char]
forall a. FilterConfig a -> (a -> Bool) -> Parsec a -> Parsec a
forall (config :: * -> *) a.
Filter config =>
config a -> (a -> Bool) -> Parsec a -> Parsec a
filterS (ErrorConfig -> FilterConfig [Char]
filterNameIllFormedIdentifier ErrorConfig
err) (CharPredicate -> [Char] -> Bool
startsWith CharPredicate
start) Parsec [Char]
identifier
    !userDefinedOperator :: Parsec [Char]
userDefinedOperator =
      CharPredicate
-> CharPredicate
-> ([Char] -> Bool)
-> [Char]
-> ([Char] -> [Char])
-> Parsec [Char]
keyOrOp CharPredicate
operatorStart CharPredicate
operatorLetter (([Char] -> Set [Char] -> Bool) -> Set [Char] -> [Char] -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip [Char] -> Set [Char] -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Set [Char]
hardOperators) (ErrorConfig -> [Char]
labelNameOperator ErrorConfig
err) (ErrorConfig -> [Char] -> [Char]
unexpectedNameIllegalOperator ErrorConfig
err)
    userDefinedOperator' :: CharPredicate -> Parsec [Char]
userDefinedOperator' CharPredicate
start = FilterConfig [Char]
-> ([Char] -> Bool) -> Parsec [Char] -> Parsec [Char]
forall a. FilterConfig a -> (a -> Bool) -> Parsec a -> Parsec a
forall (config :: * -> *) a.
Filter config =>
config a -> (a -> Bool) -> Parsec a -> Parsec a
filterS (ErrorConfig -> FilterConfig [Char]
filterNameIllFormedOperator ErrorConfig
err) (CharPredicate -> [Char] -> Bool
startsWith CharPredicate
start) Parsec [Char]
userDefinedOperator

    keyOrOp :: CharPredicate -> CharPredicate -> (String -> Bool) -> String -> (String -> String) -> Parsec String
    keyOrOp :: CharPredicate
-> CharPredicate
-> ([Char] -> Bool)
-> [Char]
-> ([Char] -> [Char])
-> Parsec [Char]
keyOrOp CharPredicate
start CharPredicate
letter [Char] -> Bool
illegal [Char]
name [Char] -> [Char]
unexpectedIllegal =
      Parsec [Char] -> Parsec [Char]
forall a. Parsec a -> Parsec a
atomic (([Char] -> Maybe [Char]) -> Parsec [Char] -> Parsec [Char]
forall a. (a -> Maybe [Char]) -> Parsec a -> Parsec a
unexpectedWhen [Char] -> Maybe [Char]
cond (CharPredicate -> CharPredicate -> Parsec [Char]
complete CharPredicate
start CharPredicate
letter)) Parsec [Char] -> Set [Char] -> Parsec [Char]
forall a. Parsec a -> Set [Char] -> Parsec a
<?> [[Char]
Item (Set [Char])
name]
      where cond :: [Char] -> Maybe [Char]
cond [Char]
x
              | [Char] -> Bool
illegal [Char]
x = [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> [Char]
unexpectedIllegal [Char]
x)
              | Bool
otherwise = Maybe [Char]
forall a. Maybe a
Nothing

    trailer :: CharPredicate -> Parsec String
    trailer :: CharPredicate -> Parsec [Char]
trailer = Parsec [Char]
-> ((Char -> Bool) -> Parsec [Char])
-> CharPredicate
-> Parsec [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> Parsec [Char]
forall a. a -> Parsec a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"") (Char -> Bool) -> Parsec [Char]
stringOfMany

    complete :: CharPredicate -> CharPredicate -> Parsec String
    complete :: CharPredicate -> CharPredicate -> Parsec [Char]
complete (Just Char -> Bool
start) CharPredicate
letter = (Char -> Bool) -> Parsec Char
satisfy Char -> Bool
start Parsec Char -> Parsec [Char] -> Parsec [Char]
forall a. Parsec a -> Parsec [a] -> Parsec [a]
<:> CharPredicate -> Parsec [Char]
trailer CharPredicate
letter
    complete CharPredicate
Nothing CharPredicate
_ = Parsec [Char]
forall a. Parsec a
forall (f :: * -> *) a. Alternative f => f a
empty

    startsWith :: CharPredicate -> String -> Bool
    startsWith :: CharPredicate -> [Char] -> Bool
startsWith CharPredicate
Nothing [Char]
_ = Bool
True
    startsWith (Just Char -> Bool
_) [] = Bool
False
    startsWith (Just Char -> Bool
p) (Char
c:[Char]
_) = Char -> Bool
p Char
c

lexeme :: (forall a. Parsec a -> Parsec a) -> Names -> Names
lexeme :: (forall a. Parsec a -> Parsec a) -> Names -> Names
lexeme forall a. Parsec a -> Parsec a
lexe Names{Parsec [Char]
CharPredicate -> Parsec [Char]
identifier :: Names -> Parsec [Char]
identifier' :: Names -> CharPredicate -> Parsec [Char]
userDefinedOperator :: Names -> Parsec [Char]
userDefinedOperator' :: Names -> CharPredicate -> Parsec [Char]
identifier :: Parsec [Char]
identifier' :: CharPredicate -> Parsec [Char]
userDefinedOperator :: Parsec [Char]
userDefinedOperator' :: CharPredicate -> Parsec [Char]
..} = Names { identifier :: Parsec [Char]
identifier = Parsec [Char] -> Parsec [Char]
forall a. Parsec a -> Parsec a
lexe Parsec [Char]
identifier
                              , identifier' :: CharPredicate -> Parsec [Char]
identifier' = Parsec [Char] -> Parsec [Char]
forall a. Parsec a -> Parsec a
lexe (Parsec [Char] -> Parsec [Char])
-> (CharPredicate -> Parsec [Char])
-> CharPredicate
-> Parsec [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CharPredicate -> Parsec [Char]
identifier'
                              , userDefinedOperator :: Parsec [Char]
userDefinedOperator = Parsec [Char] -> Parsec [Char]
forall a. Parsec a -> Parsec a
lexe Parsec [Char]
userDefinedOperator
                              , userDefinedOperator' :: CharPredicate -> Parsec [Char]
userDefinedOperator' = Parsec [Char] -> Parsec [Char]
forall a. Parsec a -> Parsec a
lexe (Parsec [Char] -> Parsec [Char])
-> (CharPredicate -> Parsec [Char])
-> CharPredicate
-> Parsec [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CharPredicate -> Parsec [Char]
userDefinedOperator'
                              }

isReservedName :: SymbolDesc -> String -> Bool
isReservedName :: SymbolDesc -> [Char] -> Bool
isReservedName SymbolDesc{Bool
Set [Char]
hardKeywords :: SymbolDesc -> Set [Char]
hardOperators :: SymbolDesc -> Set [Char]
caseSensitive :: SymbolDesc -> Bool
hardKeywords :: Set [Char]
hardOperators :: Set [Char]
caseSensitive :: Bool
..}
  | Bool
caseSensitive = ([Char] -> Set [Char] -> Bool) -> Set [Char] -> [Char] -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip [Char] -> Set [Char] -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Set [Char]
hardKeywords
  | Bool
otherwise     = ([Char] -> Set [Char] -> Bool) -> Set [Char] -> [Char] -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip [Char] -> Set [Char] -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Set [Char]
lowerHardKeywords ([Char] -> Bool) -> ([Char] -> [Char]) -> [Char] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
allLower
  where allLower :: [Char] -> [Char]
allLower = (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower
        lowerHardKeywords :: Set [Char]
lowerHardKeywords = ([Char] -> [Char]) -> Set [Char] -> Set [Char]
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map [Char] -> [Char]
allLower Set [Char]
hardKeywords