{-# LANGUAGE Safe #-}
{-# LANGUAGE RecordWildCards, OverloadedLists #-}
{-# OPTIONS_HADDOCK hide #-}
module Text.Gigaparsec.Internal.Token.Symbol (
    Symbol, softKeyword, softOperator, mkSymbol, mkSym, lexeme
  ) where

import Text.Gigaparsec (Parsec, void, notFollowedBy, atomic, (<|>), empty)
import Text.Gigaparsec.Char (string, satisfy, char, strings)
import Text.Gigaparsec.Token.Descriptions ( SymbolDesc(SymbolDesc, hardKeywords, hardOperators, caseSensitive)
                                          , NameDesc(NameDesc, identifierLetter, operatorLetter)
                                          , CharPredicate
                                          )

import Data.Set qualified as Set (member, toList, fromList, null)
import Data.Char (toUpper, toLower, isLetter)
import Text.Gigaparsec.Errors.Combinator (amend, emptyWide, (<?>))
import Data.Set (Set)
import Data.Maybe (mapMaybe)
import Text.Gigaparsec.Internal.Require (require)

type Symbol :: *
data Symbol = Symbol { Symbol -> String -> Parsec ()
softKeyword :: !(String -> Parsec ())
                     , Symbol -> String -> Parsec ()
softOperator :: !(String -> Parsec ())
                     }

mkSymbol :: SymbolDesc -> NameDesc -> Symbol
mkSymbol :: SymbolDesc -> NameDesc -> Symbol
mkSymbol SymbolDesc{Bool
Set String
hardKeywords :: SymbolDesc -> Set String
hardOperators :: SymbolDesc -> Set String
caseSensitive :: SymbolDesc -> Bool
hardKeywords :: Set String
hardOperators :: Set String
caseSensitive :: Bool
..} NameDesc{CharPredicate
identifierLetter :: NameDesc -> CharPredicate
operatorLetter :: NameDesc -> CharPredicate
identifierLetter :: CharPredicate
operatorLetter :: CharPredicate
..} = Symbol {String -> Parsec ()
softKeyword :: String -> Parsec ()
softOperator :: String -> Parsec ()
softKeyword :: String -> Parsec ()
softOperator :: String -> Parsec ()
..}
  where softKeyword :: String -> Parsec ()
softKeyword String
name = Bool -> String -> String -> Parsec () -> Parsec ()
forall a. Bool -> String -> String -> a -> a
require (Bool -> Bool
not (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
name)) String
"softKeyword" String
"keywords may not be empty"
          (Bool -> CharPredicate -> String -> Parsec ()
_softKeyword Bool
caseSensitive CharPredicate
identifierLetter String
name Parsec () -> Set String -> Parsec ()
forall a. Parsec a -> Set String -> Parsec a
<?> [String
Item (Set String)
name])
        softOperator :: String -> Parsec ()
softOperator String
name = Bool -> String -> String -> Parsec () -> Parsec ()
forall a. Bool -> String -> String -> a -> a
require (Bool -> Bool
not (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
name)) String
"softOperator" String
"operators may not be empty"
          (Set String -> CharPredicate -> String -> Parsec ()
_softOperator Set String
hardOperators CharPredicate
operatorLetter String
name Parsec () -> Set String -> Parsec ()
forall a. Parsec a -> Set String -> Parsec a
<?> [String
Item (Set String)
name])

mkSym :: SymbolDesc -> Symbol -> (String -> Parsec ())
mkSym :: SymbolDesc -> Symbol -> String -> Parsec ()
mkSym SymbolDesc{Bool
Set String
hardKeywords :: SymbolDesc -> Set String
hardOperators :: SymbolDesc -> Set String
caseSensitive :: SymbolDesc -> Bool
hardKeywords :: Set String
hardOperators :: Set String
caseSensitive :: Bool
..} Symbol{String -> Parsec ()
softKeyword :: Symbol -> String -> Parsec ()
softOperator :: Symbol -> String -> Parsec ()
softKeyword :: String -> Parsec ()
softOperator :: String -> Parsec ()
..} String
str
  | String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member String
str Set String
hardKeywords  = String -> Parsec ()
softKeyword String
str
  | String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member String
str Set String
hardOperators = String -> Parsec ()
softOperator String
str
  | Bool
otherwise                    = Parsec String -> Parsec ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parsec String -> Parsec String
forall a. Parsec a -> Parsec a
atomic (String -> Parsec String
string String
str))

lexeme :: (forall a. Parsec a -> Parsec a) -> Symbol -> Symbol
lexeme :: (forall a. Parsec a -> Parsec a) -> Symbol -> Symbol
lexeme forall a. Parsec a -> Parsec a
lexe Symbol{String -> Parsec ()
softKeyword :: Symbol -> String -> Parsec ()
softOperator :: Symbol -> String -> Parsec ()
softKeyword :: String -> Parsec ()
softOperator :: String -> Parsec ()
..} = Symbol { softKeyword :: String -> Parsec ()
softKeyword = Parsec () -> Parsec ()
forall a. Parsec a -> Parsec a
lexe (Parsec () -> Parsec ())
-> (String -> Parsec ()) -> String -> Parsec ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Parsec ()
softKeyword
                                , softOperator :: String -> Parsec ()
softOperator = Parsec () -> Parsec ()
forall a. Parsec a -> Parsec a
lexe (Parsec () -> Parsec ())
-> (String -> Parsec ()) -> String -> Parsec ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Parsec ()
softOperator
                                }

_softKeyword :: Bool -> CharPredicate -> String -> Parsec ()
_softKeyword :: Bool -> CharPredicate -> String -> Parsec ()
_softKeyword Bool
caseSensitive CharPredicate
letter String
kw
  | Bool -> Bool
not Bool
caseSensitive = Parsec () -> Parsec ()
forall a. Parsec a -> Parsec a
atomic (CharPredicate -> Parsec String -> Parsec ()
forall {a}. CharPredicate -> Parsec a -> Parsec ()
nfb CharPredicate
letter Parsec String
caseString)
  | Bool
otherwise         = Parsec () -> Parsec ()
forall a. Parsec a -> Parsec a
atomic (CharPredicate -> Parsec String -> Parsec ()
forall {a}. CharPredicate -> Parsec a -> Parsec ()
nfb CharPredicate
letter (String -> Parsec String
string String
kw))
  where nfb :: CharPredicate -> Parsec a -> Parsec ()
nfb CharPredicate
Nothing Parsec a
p = Parsec a -> Parsec ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Parsec a
p
        nfb (Just Char -> Bool
c) Parsec a
p = Parsec a
p Parsec a -> Parsec () -> Parsec ()
forall a b. Parsec a -> Parsec b -> Parsec b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Parsec Char -> Parsec ()
forall a. Parsec a -> Parsec ()
notFollowedBy ((Char -> Bool) -> Parsec Char
satisfy Char -> Bool
c) Parsec () -> Set String -> Parsec ()
forall a. Parsec a -> Set String -> Parsec a
<?> [String
"end of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
kw])
        n :: Int
n = String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
kw
        caseChar :: Char -> Parsec Char
caseChar Char
c
          | Char -> Bool
isLetter Char
c = Char -> Parsec Char
char (Char -> Char
toUpper Char
c) Parsec Char -> Parsec Char -> Parsec Char
forall a. Parsec a -> Parsec a -> Parsec a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> Parsec Char
char (Char -> Char
toLower Char
c)
          | Bool
otherwise  = Char -> Parsec Char
char Char
c
        caseString :: Parsec String
caseString = Parsec String -> Parsec String
forall a. Parsec a -> Parsec a
atomic (Parsec String -> Parsec String
forall a. Parsec a -> Parsec a
amend ((Char -> Parsec Char) -> String -> Parsec String
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Char -> Parsec Char
caseChar String
kw))
                 Parsec String -> Parsec String -> Parsec String
forall a. Parsec a -> Parsec a -> Parsec a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Word -> Parsec String
forall a. Word -> Parsec a
emptyWide (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)

-- TODO: trie-based implementation
_softOperator :: Set String -> CharPredicate -> String -> Parsec ()
_softOperator :: Set String -> CharPredicate -> String -> Parsec ()
_softOperator Set String
hardOperators CharPredicate
letter String
op =
  if Set String -> Bool
forall a. Set a -> Bool
Set.null Set String
ends then Parsec () -> Parsec ()
forall a. Parsec a -> Parsec a
atomic (String -> Parsec String
string String
op Parsec String -> Parsec () -> Parsec ()
forall a b. Parsec a -> Parsec b -> Parsec b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parsec Char -> Parsec ()
forall a. Parsec a -> Parsec ()
notFollowedBy Parsec Char
letter')
  else Parsec () -> Parsec ()
forall a. Parsec a -> Parsec a
atomic (String -> Parsec String
string String
op Parsec String -> Parsec () -> Parsec ()
forall a b. Parsec a -> Parsec b -> Parsec b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Parsec () -> Parsec ()
forall a. Parsec a -> Parsec ()
notFollowedBy (Parsec Char -> Parsec ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Parsec Char
letter' Parsec () -> Parsec () -> Parsec ()
forall a. Parsec a -> Parsec a -> Parsec a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parsec String -> Parsec ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Set String -> Parsec String
strings Set String
ends)) Parsec () -> Set String -> Parsec ()
forall a. Parsec a -> Set String -> Parsec a
<?> [String
"end of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
op]))
  where ends :: Set String
ends = [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList ((String -> Maybe String) -> [String] -> [String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((String -> String -> Maybe String)
-> String -> String -> Maybe String
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> String -> Maybe String
forall {a}. Eq a => [a] -> [a] -> Maybe [a]
strip String
op) (Set String -> [String]
forall a. Set a -> [a]
Set.toList Set String
hardOperators))
        letter' :: Parsec Char
letter' = Parsec Char
-> ((Char -> Bool) -> Parsec Char) -> CharPredicate -> Parsec Char
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Parsec Char
forall a. Parsec a
forall (f :: * -> *) a. Alternative f => f a
empty (Char -> Bool) -> Parsec Char
satisfy CharPredicate
letter
        strip :: [a] -> [a] -> Maybe [a]
strip []      str :: [a]
str@(:){}          = [a] -> Maybe [a]
forall a. a -> Maybe a
Just [a]
str
        strip (a
c:[a]
pre) (a
c':[a]
str) | a
c a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
c' = [a] -> [a] -> Maybe [a]
strip [a]
pre [a]
str
        strip [a]
_       [a]
_                  = Maybe [a]
forall a. Maybe a
Nothing

-- TODO: HasField instances for the dot/comma/etc?
-- FIXME: to make these work, well need to move sym into Symbol?
{-dot :: Symbol -> Parsec ()
dot =
-}