{-# 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?
type Names :: *
data Names = Names { Names -> Parsec String
identifier :: !(Parsec String)
                   , Names -> CharPredicate -> Parsec String
identifier' :: !(CharPredicate -> Parsec String)
                   , Names -> Parsec String
userDefinedOperator :: !(Parsec String)
                   , Names -> CharPredicate -> Parsec String
userDefinedOperator' :: !(CharPredicate -> Parsec String)
                   }

mkNames :: NameDesc -> SymbolDesc -> ErrorConfig -> Names
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
forall (f :: * -> *) a. Alternative f => f 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