{-# 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 String
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 String
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 String
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 String
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 String
hardKeywords :: SymbolDesc -> Set String
hardOperators :: SymbolDesc -> Set String
caseSensitive :: SymbolDesc -> Bool
hardKeywords :: Set String
hardOperators :: Set String
caseSensitive :: Bool
..} !ErrorConfig
err = Names {Parsec String
CharPredicate -> Parsec String
identifier :: Parsec String
identifier' :: CharPredicate -> Parsec String
userDefinedOperator :: Parsec String
userDefinedOperator' :: CharPredicate -> Parsec String
identifier :: Parsec String
identifier' :: CharPredicate -> Parsec String
userDefinedOperator :: Parsec String
userDefinedOperator' :: CharPredicate -> Parsec String
..}
  where
    !isReserved :: String -> Bool
isReserved = SymbolDesc -> String -> Bool
isReservedName SymbolDesc
symbolDesc
    !identifier :: Parsec String
identifier =
      CharPredicate
-> CharPredicate
-> (String -> Bool)
-> String
-> (String -> String)
-> Parsec String
keyOrOp CharPredicate
identifierStart CharPredicate
identifierLetter String -> Bool
isReserved (ErrorConfig -> String
labelNameIdentifier ErrorConfig
err) (ErrorConfig -> String -> String
unexpectedNameIllegalIdentifier ErrorConfig
err)
    identifier' :: CharPredicate -> Parsec String
identifier' CharPredicate
start = FilterConfig String
-> (String -> Bool) -> Parsec String -> Parsec String
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 String
filterNameIllFormedIdentifier ErrorConfig
err) (CharPredicate -> String -> Bool
startsWith CharPredicate
start) Parsec String
identifier
    !userDefinedOperator :: Parsec String
userDefinedOperator =
      CharPredicate
-> CharPredicate
-> (String -> Bool)
-> String
-> (String -> String)
-> Parsec String
keyOrOp CharPredicate
operatorStart CharPredicate
operatorLetter ((String -> Set String -> Bool) -> Set String -> String -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Set String
hardOperators) (ErrorConfig -> String
labelNameOperator ErrorConfig
err) (ErrorConfig -> String -> String
unexpectedNameIllegalOperator ErrorConfig
err)
    userDefinedOperator' :: CharPredicate -> Parsec String
userDefinedOperator' CharPredicate
start = FilterConfig String
-> (String -> Bool) -> Parsec String -> Parsec String
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 String
filterNameIllFormedOperator ErrorConfig
err) (CharPredicate -> String -> Bool
startsWith CharPredicate
start) Parsec String
userDefinedOperator

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

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

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

    startsWith :: CharPredicate -> String -> Bool
    startsWith :: CharPredicate -> String -> Bool
startsWith CharPredicate
Nothing String
_ = Bool
True
    startsWith (Just Char -> Bool
_) [] = Bool
False
    startsWith (Just Char -> Bool
p) (Char
c:String
_) = 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 String
CharPredicate -> Parsec String
identifier :: Names -> Parsec String
identifier' :: Names -> CharPredicate -> Parsec String
userDefinedOperator :: Names -> Parsec String
userDefinedOperator' :: Names -> CharPredicate -> Parsec String
identifier :: Parsec String
identifier' :: CharPredicate -> Parsec String
userDefinedOperator :: Parsec String
userDefinedOperator' :: CharPredicate -> Parsec String
..} = Names { identifier :: Parsec String
identifier = Parsec String -> Parsec String
forall a. Parsec a -> Parsec a
lexe Parsec String
identifier
                              , identifier' :: CharPredicate -> Parsec String
identifier' = Parsec String -> Parsec String
forall a. Parsec a -> Parsec a
lexe (Parsec String -> Parsec String)
-> (CharPredicate -> Parsec String)
-> CharPredicate
-> Parsec String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CharPredicate -> Parsec String
identifier'
                              , userDefinedOperator :: Parsec String
userDefinedOperator = Parsec String -> Parsec String
forall a. Parsec a -> Parsec a
lexe Parsec String
userDefinedOperator
                              , userDefinedOperator' :: CharPredicate -> Parsec String
userDefinedOperator' = Parsec String -> Parsec String
forall a. Parsec a -> Parsec a
lexe (Parsec String -> Parsec String)
-> (CharPredicate -> Parsec String)
-> CharPredicate
-> Parsec String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CharPredicate -> Parsec String
userDefinedOperator'
                              }

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