{-# LANGUAGE Trustworthy #-}

{-# OPTIONS_HADDOCK hide #-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UnicodeSyntax #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-unused-do-bind #-}

{- |
Module      : Text.Gigaparsec.Token.Patterns
Description : Template Haskell generators to help with patterns
License     : BSD-3-Clause
Maintainer  : Jamie Willis, Gigaparsec Maintainers
Stability   : experimental

This module is currently experimental, and may have bugs depending on the version
of Haskell, or the extensions enabled. Please report any issues to the maintainers.

@since 0.2.2.0
-}
module Text.Gigaparsec.Internal.Token.Patterns.LexerCombinators (
  module Text.Gigaparsec.Internal.Token.Patterns.LexerCombinators,
) where

import safe Text.Gigaparsec.Internal.Token.Lexer (
  Lexeme (
    charLiteral,
    multiStringLiteral,
    names,
    rawMultiStringLiteral,
    rawStringLiteral,
    stringLiteral,
    symbol
  ),
  Lexer (lexeme, space),
  Space,
 )
import safe Text.Gigaparsec.Internal.Token.Names (Names)
import safe Text.Gigaparsec.Internal.Token.Symbol (Symbol)
import safe Text.Gigaparsec.Internal.Token.Text (TextParsers)

import Text.Gigaparsec.Internal.TH.DecUtils (funDsingleClause)
import Text.Gigaparsec.Internal.TH.TypeUtils (removeUnusedTVars, sanitiseBndrStars, sanitiseTypeStars)

import Text.Gigaparsec.Internal.TH.VersionAgnostic (
  Dec, DocLoc(DeclDoc), Exp, Inline (Inline), Phases (AllPhases), Q, Quasi (qRecover), 
  Quote (newName), Type (ForallT), addModFinalizer, getDoc, isInstance, 
  nameBase, putDoc, reifyType,
  RuleMatch (FunLike),
  Type (AppT, ArrowT, ForallVisT), 
  pattern MulArrowT,
  clause,
  funD,
  normalB,
  pprint,
  pragInlD,
  sigD,
  varE,
  )

import Data.Bifunctor (Bifunctor (first))
import Data.Kind (Constraint)
import Data.Maybe (fromMaybe)
import Text.Gigaparsec.Internal.TH.VersionAgnostic (Name)
import Text.Gigaparsec.Token.Lexer qualified as Lexer

{-|
Generates the specified lexer combinators using a quoted `Lexer`, for example, @[|lexer|]@.

The generated combinators will behave like their counterparts in "Text.Gigaparsec.Token.Lexer", 
except they won't require a lexer (or subcomponents thereof) to be supplied as an argument.


==== __Usage:__

> import Text.Gigaparsec.Token.Lexer qualified as Lexer
> import Text.Gigaparsec.Token.Lexer (Lexer)
> lexer :: Lexer
> $(lexerCombinators [| lexer |] ['Lexer.lexeme, 'Lexer.fully, 'Lexer.identifier, 'Lexer.stringLiteral])

This will generate the following combinators/functions:

> lexeme :: Lexeme
> fully :: ∀ a . Parsec a -> Parsec a
> identifier :: Parsec String
> stringLiteral :: TextParsers String

These will behave like their counterparts in "Text.Gigaparsec.Token.Lexer", except they will not need
a 'Lexer' (or its subcomponents) as an argument.

@since 0.4.0.0

-}
lexerCombinators
  :: Q Exp   -- ^ The quoted 'Lexer'.
  -> [Name]  -- ^ The combinators to generate.
  -> Q [Dec] -- ^ Definitions of the generated combinators.
lexerCombinators :: Q Exp -> [Name] -> Q [Dec]
lexerCombinators Q Exp
lexer [Name]
ns = Q Exp -> [(Name, String)] -> Q [Dec]
lexerCombinatorsWithNames Q Exp
lexer ([Name] -> [String] -> [(Name, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
ns ((Name -> String) -> [Name] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Name -> String
nameBase [Name]
ns))

{-|
Generates the specified lexer combinators with the given names using a quoted `Lexer`, for example, @[|lexer|]@.

The generated combinators will behave like their counterparts in "Text.Gigaparsec.Token.Lexer", 
except they won't require a lexer (or subcomponents thereof) to be supplied as an argument.


==== __Usage:__

> import Text.Gigaparsec.Token.Lexer qualified as Lexer
> import Text.Gigaparsec.Token.Lexer (Lexer)
> lexer :: Lexer
> $(lexerCombinatorsWithNames [| lexer |] [('Lexer.lexeme, "myLexeme"), ('Lexer.fully, "myFully")])

This will generate the following combinators/functions:

> myLexeme :: Lexeme
> myFully :: ∀ a . Parsec a -> Parsec a

These will behave like their counterparts in "Text.Gigaparsec.Token.Lexer", except they will not need
a 'Lexer' (or its subcomponents) as an argument.

@since 0.4.0.0

-}
lexerCombinatorsWithNames 
  :: Q Exp            -- ^ The quoted `Lexer`.
  -> [(Name, String)] -- ^ The combinators to generate with the given name.
  -> Q [Dec]          -- ^ Definitions of the generated combinators.
lexerCombinatorsWithNames :: Q Exp -> [(Name, String)] -> Q [Dec]
lexerCombinatorsWithNames Q Exp
lexer = ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> Q [Dec])
-> ([(Name, String)] -> Q [[Dec]]) -> [(Name, String)] -> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Name, String) -> Q [Dec]) -> [(Name, String)] -> Q [[Dec]]
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 ((Name -> String -> Q [Dec]) -> (Name, String) -> Q [Dec]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Q Exp -> Name -> String -> Q [Dec]
lexerCombinatorWithName Q Exp
lexer))

{-|
Create a single lexer combinator with a given name, defined in terms of the lexer.
-}
lexerCombinatorWithName
  :: Q Exp
  -> Name -- The name of the old combinator
  -> String -- the new name of the combinator
  -> Q [Dec]
lexerCombinatorWithName :: Q Exp -> Name -> String -> Q [Dec]
lexerCombinatorWithName Q Exp
lexer Name
old String
nm = do
  Type
newTp <- Name -> Bool -> Q Type
getLexerCombinatorType Name
old Bool
True
  Q Exp -> String -> Name -> Type -> Q [Dec]
mkLexerCombinatorDec Q Exp
lexer String
nm Name
old Type
newTp

{-| 
Constructs the combinator using the given type.
Calculates the definition of the combinator using a typeclass (if possible).
-}
mkLexerCombinatorDec
  :: Q Exp -- ^ The quoted Lexer  
  -> String -- ^ The name of the combinator to generate
  -> Name -- ^ The quoted name of the original combinator
  -> Type -- ^ The return type of the new combinator
  -> Q [Dec]
mkLexerCombinatorDec :: Q Exp -> String -> Name -> Type -> Q [Dec]
mkLexerCombinatorDec Q Exp
lexer String
nm Name
old Type
tp = do
  Name
newX <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
nm
  Maybe String
oldDocs <- DocLoc -> Q (Maybe String)
getDoc (Name -> DocLoc
DeclDoc Name
old)
  let newDocs :: String
newDocs = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" Maybe String
oldDocs
  Q () -> Q ()
addModFinalizer (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ DocLoc -> String -> Q ()
putDoc (Name -> DocLoc
DeclDoc Name
newX) String
newDocs
  [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence
    [ Name -> Inline -> RuleMatch -> Phases -> Q Dec
forall (m :: * -> *).
Quote m =>
Name -> Inline -> RuleMatch -> Phases -> m Dec
pragInlD Name
newX Inline
Inline RuleMatch
FunLike Phases
AllPhases
    , Name -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
newX (Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
tp)
    , Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
newX [[Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [] (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [|project $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
old) $Q Exp
lexer|]) []]
    ]

{-| 
Constructs the combinator using the given type.
Calculates the definition of the combinator using the `LexerField` typeclass (if possible).
-}
mkLexerCombinatorDecWithProj 
  :: Q Exp -- ^ The quoted Lexer
  -> String -- ^ The name of the combinator to generate
  -> Name -- ^ @old@, The quoted name of the original combinator
  -> Q Type -- ^ The return type of the new combinator
  -> Q Exp -- ^ projection to precompose the @old@ combinator with
  -> Q (Name, [Dec]) -- ^ The name of the new combinator and its declaration
mkLexerCombinatorDecWithProj :: Q Exp -> String -> Name -> Q Type -> Q Exp -> Q (Name, [Dec])
mkLexerCombinatorDecWithProj Q Exp
lexer String
nm Name
old Q Type
tp Q Exp
proj = do
  Name
newX <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
nm
  Maybe String
oldDocs <- DocLoc -> Q (Maybe String)
getDoc (Name -> DocLoc
DeclDoc Name
old)
  let newDocs :: String
newDocs = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" Maybe String
oldDocs
  Q () -> Q ()
addModFinalizer (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ DocLoc -> String -> Q ()
putDoc (Name -> DocLoc
DeclDoc Name
newX) String
newDocs
  (Name
newX,)
    ([Dec] -> (Name, [Dec])) -> Q [Dec] -> Q (Name, [Dec])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence
      [ Name -> Inline -> RuleMatch -> Phases -> Q Dec
forall (m :: * -> *).
Quote m =>
Name -> Inline -> RuleMatch -> Phases -> m Dec
pragInlD Name
newX Inline
Inline RuleMatch
FunLike Phases
AllPhases
      , Name -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
newX Q Type
tp
      , Name -> Q Exp -> Q Dec
funDsingleClause Name
newX [|project ($(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
old) . $Q Exp
proj) $Q Exp
lexer|]
      ]

{-| 
Figures out the type of the combinator minus the domain; this will be one of a 'Lexer' component, or any other subcomponents (e.g. 'Symbol' or 'Space').
Calculates the domain type, and the return type of the new combinator.
The boolean flag set to True means one should ensure the domain type gives a specific combinator,
and doesn't lead to an ambiguous return type.
-}
getLexerCombinatorType :: Name -> Bool -> Q Type
getLexerCombinatorType :: Name -> Bool -> Q Type
getLexerCombinatorType Name
old Bool
checkType = do
  Type
tp <- Name -> Q Type
reifyType Name
old
  (Type -> Type
prefix, Type
dom, ArrowTp
_, Type
cod) <-
    String -> Q (Type -> Type, Type, ArrowTp, Type)
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (Name -> Type -> String
notFunctionTypeMsg Name
old Type
tp) Q (Type -> Type, Type, ArrowTp, Type)
-> Q (Type -> Type, Type, ArrowTp, Type)
-> Q (Type -> Type, Type, ArrowTp, Type)
forall a. Q a -> Q a -> Q a
forall (m :: * -> *) a. Quasi m => m a -> m a -> m a
`qRecover` Type -> Q (Type -> Type, Type, ArrowTp, Type)
fnTpDomain Type
tp
  let newTp :: Type
newTp = Type -> Type
prefix Type
cod
  Bool
b <- Name -> [Type] -> Q Bool
isInstance ''LexerField [Type
dom]
  if Bool
checkType Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
b
    then Type -> Type -> Q Type
forall a. Type -> Type -> Q a
catchErrors Type
dom Type
newTp
    else Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Type -> Type
prefix Type
cod
 where
  -- If the quoted name is not at least a function type, then there's no real way to define the combinator :p
  notFunctionTypeMsg :: Name -> Type -> String
  notFunctionTypeMsg :: Name -> Type -> String
notFunctionTypeMsg Name
x Type
tp = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"Constant `", Name -> String
nameBase Name
x, String
"` does not have a function type: ", Type -> String
forall a. Show a => a -> String
show Type
tp]

  -- Preventative Errors: catch the cases someone tries to define one of the String or Integer parsers
  -- they should do these manually or with the bespoke generators!
  catchErrors :: Type -> Type -> Q a
  catchErrors :: forall a. Type -> Type -> Q a
catchErrors Type
dom Type
newTp
    | Name
old Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== 'Lexer.ascii = Name -> Q a
forall a. Name -> Q a
failStringParser Name
old
    | Name
old Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== 'Lexer.unicode = Name -> Q a
forall a. Name -> Q a
failStringParser Name
old
    | Name
old Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== 'Lexer.latin1 = Name -> Q a
forall a. Name -> Q a
failStringParser Name
old
    | Bool
otherwise = String -> Q a
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (Name -> Type -> String
notLexerFieldMsg Name
old Type
dom)

  -- Message to give to the user when they give a TextParser field, as there is no way to disambiguate
  -- exactly *which* TextParser they want.
  -- And there is no point in implementing a way for the user to ask for this;
  -- at that point, it would be no more work on the user's end than were they to write a manual definition.
  failStringParser :: Name -> Q a
  failStringParser :: forall a. Name -> Q a
failStringParser Name
nm =
    String -> Q a
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q a) -> String -> Q a
forall a b. (a -> b) -> a -> b
$
      [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"Cannot derive a lexer combinator for `"
        , Name -> String
nameBase Name
nm
        , String
"`, as there are many possible "
        , Name -> String
forall a. Ppr a => a -> String
pprint ''TextParsers
        , String
" to define it in terms of, including:"
        , Name -> String
forall a. Ppr a => a -> String
pprint 'stringLiteral
        , String
", "
        , Name -> String
forall a. Ppr a => a -> String
pprint 'rawStringLiteral
        , String
", "
        , Name -> String
forall a. Ppr a => a -> String
pprint 'multiStringLiteral
        , String
", and "
        , Name -> String
forall a. Ppr a => a -> String
pprint 'rawMultiStringLiteral
        , String
"."
        , String
"\n You will need to manually define this combinator, as you are then able to pick which TextParser it should use."
        ]

  -- If the quoted name is not a recognised lexer field, then we should tell the user as much.
  -- The error may be due to being able to disambiguate the field, rather than the field not existing.
  notLexerFieldMsg :: Name -> Type -> String
  notLexerFieldMsg :: Name -> Type -> String
notLexerFieldMsg Name
x Type
tp =
    [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ String
"Cannot produce a lexer combinator for function: "
      , Name -> String
nameBase Name
x
      , String
"."
      , String
"\n This is because the type: `"
      , Type -> String
forall a. Ppr a => a -> String
pprint Type
tp
      , String
"` cannot be used to give a precise combinator, either because it does not refer to "
      , String
"any fields of a `Lexer`, or because it ambiguously refers to many fields of a `Lexer`."
      , String
"\n Some fields of the `Lexer` share the same type, so there are multiple possible candidate combinators for a particular field."
      , String
" For example: "
      , String
"\n   - `decimal`, `hexadecimal`,... all have type `IntegerParsers canHold -> Parsec Integer`."
      , String
"\n   - `ascii`, `unicode`, ... all have type `TextParsers t -> Parsec t`."
      ]

---------------------------------------------------------------------------------------------------
-- Util functions

{-|
Denote the type of an arrow; it is either normal or linear.
-}
type ArrowTp :: *
data ArrowTp = StdArrow | LinearArrow

{-|
Get the domain of a function type.
Keep any prefixed constraints and type variable quantifiers as a prefixing function.
-}
fnTpDomain
  :: Type
  -> Q (Type -> Type, Type, ArrowTp, Type)
-- The head of the type, includes any preceding constraints
-- and foralls. this is a function which prefixes the given type with the constraints/foralls
-- The domain and codomain of the type
fnTpDomain :: Type -> Q (Type -> Type, Type, ArrowTp, Type)
fnTpDomain Type
x = do
  (Type -> Type
a, (Type
b, ArrowTp
c, Type
d)) <- Type -> Q (Type -> Type, (Type, ArrowTp, Type))
fnTpDomain' (Type -> Q (Type -> Type, (Type, ArrowTp, Type)))
-> Q Type -> Q (Type -> Type, (Type, ArrowTp, Type))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Type -> Q Type
sanitiseTypeStars Type
x
  (Type -> Type, Type, ArrowTp, Type)
-> Q (Type -> Type, Type, ArrowTp, Type)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Type
removeUnusedTVars (Type -> Type) -> (Type -> Type) -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type
a, Type
b, ArrowTp
c, Type
d)
 where
  fnTpDomain' :: Type -> Q (Type -> Type, (Type, ArrowTp, Type))
fnTpDomain' (ForallT [TyVarBndr Specificity]
bnds [Type]
ctx Type
tp) = do
    [TyVarBndr Specificity]
bnds' <- [TyVarBndr Specificity] -> Q [TyVarBndr Specificity]
forall flag. [TyVarBndr flag] -> Q [TyVarBndr flag]
sanitiseBndrStars [TyVarBndr Specificity]
bnds
    ((Type -> Type) -> Type -> Type)
-> (Type -> Type, (Type, ArrowTp, Type))
-> (Type -> Type, (Type, ArrowTp, Type))
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ([TyVarBndr Specificity] -> [Type] -> Type -> Type
ForallT [TyVarBndr Specificity]
bnds' [Type]
ctx (Type -> Type) -> (Type -> Type) -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((Type -> Type, (Type, ArrowTp, Type))
 -> (Type -> Type, (Type, ArrowTp, Type)))
-> Q (Type -> Type, (Type, ArrowTp, Type))
-> Q (Type -> Type, (Type, ArrowTp, Type))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Q (Type -> Type, (Type, ArrowTp, Type))
fnTpDomain' Type
tp
  fnTpDomain' (ForallVisT [TyVarBndr ()]
bnds Type
tp) = do
    [TyVarBndr ()]
bnds' <- [TyVarBndr ()] -> Q [TyVarBndr ()]
forall flag. [TyVarBndr flag] -> Q [TyVarBndr flag]
sanitiseBndrStars [TyVarBndr ()]
bnds
    ((Type -> Type) -> Type -> Type)
-> (Type -> Type, (Type, ArrowTp, Type))
-> (Type -> Type, (Type, ArrowTp, Type))
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ([TyVarBndr ()] -> Type -> Type
ForallVisT [TyVarBndr ()]
bnds' (Type -> Type) -> (Type -> Type) -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((Type -> Type, (Type, ArrowTp, Type))
 -> (Type -> Type, (Type, ArrowTp, Type)))
-> Q (Type -> Type, (Type, ArrowTp, Type))
-> Q (Type -> Type, (Type, ArrowTp, Type))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Q (Type -> Type, (Type, ArrowTp, Type))
fnTpDomain' Type
tp
  fnTpDomain' (AppT (AppT Type
ArrowT Type
a) Type
b) =
    (Type -> Type, (Type, ArrowTp, Type))
-> Q (Type -> Type, (Type, ArrowTp, Type))
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Type
forall a. a -> a
id, (Type
a, ArrowTp
StdArrow, Type
b))
  fnTpDomain' (AppT (AppT Type
MulArrowT Type
a) Type
b) =
    (Type -> Type, (Type, ArrowTp, Type))
-> Q (Type -> Type, (Type, ArrowTp, Type))
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Type
forall a. a -> a
id, (Type
a, ArrowTp
LinearArrow, Type
b))
  fnTpDomain' Type
tp =
    String -> Q (Type -> Type, (Type, ArrowTp, Type))
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
      (String
"Type of given function is not a function type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
tp)

---------------------------------------------------------------------------------------------------
-- Lexer Field

{- |
@a@ is a `LexerField` when it is the type of a component or subcomponent of the `Lexer` type.
This includes things like `Lexeme` and `Symbol`.

Avoid writing instances for:
- IntegerParsers
- TextParsers String

As this leads to ambiguous projections if users try to generate combinators for, e.g., 'Lexer.decimal.
There are two possible instances here, one for `integer`, the other for `natural`, and there is no way to disambiguate here.
By avoiding writing these instances, we can give the user a more informative error message should they try this.
-}
type LexerField :: * -> Constraint
class LexerField a where
  project :: (a -> b) -> (Lexer -> b)

type LexerProj :: * -> * -> *
type LexerProj a b = (a -> b) -> (Lexer -> b)

instance LexerField Lexer where
  {-# INLINE project #-}
  project :: (Lexer -> b) -> (Lexer -> b)
  project :: forall b. (Lexer -> b) -> Lexer -> b
project = (Lexer -> b) -> Lexer -> b
forall a. a -> a
id

---------------------------------------------------------------------------------------------------
-- Lexemes

instance LexerField Lexeme where
  {-# INLINE project #-}
  project :: (Lexeme -> b) -> (Lexer -> b)
  project :: forall b. (Lexeme -> b) -> Lexer -> b
project Lexeme -> b
f = Lexeme -> b
f (Lexeme -> b) -> (Lexer -> Lexeme) -> Lexer -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lexer -> Lexeme
lexeme

instance LexerField Symbol where
  {-# INLINE project #-}
  project :: (Symbol -> b) -> (Lexer -> b)
  project :: forall b. (Symbol -> b) -> Lexer -> b
project Symbol -> b
f = Symbol -> b
f (Symbol -> b) -> (Lexer -> Symbol) -> Lexer -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lexeme -> Symbol
symbol (Lexeme -> Symbol) -> (Lexer -> Lexeme) -> Lexer -> Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lexer -> Lexeme
lexeme

instance LexerField Names where
  {-# INLINE project #-}
  project :: (Names -> b) -> (Lexer -> b)
  project :: forall b. (Names -> b) -> Lexer -> b
project Names -> b
f = Names -> b
f (Names -> b) -> (Lexer -> Names) -> Lexer -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lexeme -> Names
names (Lexeme -> Names) -> (Lexer -> Lexeme) -> Lexer -> Names
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lexer -> Lexeme
lexeme

instance LexerField (TextParsers Char) where
  {-# INLINE project #-}
  project :: (TextParsers Char -> b) -> (Lexer -> b)
  project :: forall b. (TextParsers Char -> b) -> Lexer -> b
project TextParsers Char -> b
f = TextParsers Char -> b
f (TextParsers Char -> b)
-> (Lexer -> TextParsers Char) -> Lexer -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lexeme -> TextParsers Char
charLiteral (Lexeme -> TextParsers Char)
-> (Lexer -> Lexeme) -> Lexer -> TextParsers Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lexer -> Lexeme
lexeme

---------------------------------------------------------------------------------------------------
-- Space

instance LexerField Space where
  {-# INLINE project #-}
  project :: (Space -> b) -> (Lexer -> b)
  project :: forall b. (Space -> b) -> Lexer -> b
project Space -> b
f = Space -> b
f (Space -> b) -> (Lexer -> Space) -> Lexer -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lexer -> Space
space