{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE TemplateHaskell, CPP #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Use fewer imports" #-}
{-# OPTIONS_GHC -Wno-monomorphism-restriction #-}
{-|
Module      : Text.Gigaparsec.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.Patterns (deriveLiftedConstructors, deriveDeferredConstructors) where

import Prelude (
    Bool(True, False), String, Int, Maybe(Just, Nothing), Eq((==), (/=)),
    fmap, map, concat, (.), traverse, sequence, foldr1, length, (-), return, (++),
    fail, ($), unwords, maybe, otherwise, id, reverse, show, flip, takeWhile, (+),
    -- use Prelude's pure instead of that from Gigaparsec so the latter can have type-specialised haddock documentation.
    pure 
  )

import Text.Gigaparsec (Parsec, (<**>), (<*>))
import Text.Gigaparsec.Position (Pos, pos)
import Control.Monad (replicateM)
import Data.List (foldl')
import Data.Maybe (isJust, isNothing)
import Language.Haskell.TH (
    Q, Exp, Name, Dec,
    Type (ForallT, AppT, ArrowT, StarT, ConT),
    Info (DataConI, PatSynI), TyVarBndr (KindedTV, PlainTV),
    sigD, funD, clause, varP, normalB, varE, reify, mkName, newName,
    isExtEnabled, Extension (KindSignatures),
    forallT, conE, lamE
  )
#if __GLASGOW_HASKELL__ >= 902
import Language.Haskell.TH (Type(MulArrowT))
#endif

{-|
This function is used to automatically generate /Lifted Constructors/, which are
one of the patterns in /"Design Patterns for Parser Combinators/". It is provided
with a prefix, which is used to denote an application of the constructor, and
then a list of "ticked" constructors to generate lifted constructors for. This
means adding a single @'@ in front of the constructor name. For example:

> {-# LANGUAGE TemplateHaskell #-}
> data Foo a = Foo a | Bar Int String
> $(deriveLiftedConstructors "mk" ['Foo, 'Bar])

Will generate two lifted constructors of the shape:

> mkFoo :: Parsec a -> Parsec (Foo a)
> mkBar :: Parsec Int -> Parsec String -> Parsec (Foo a)

Furthermore, if one of the arguments to the constructor has type `Text.Gigaparsec.Position.Pos`,
the @pos@ combinator will be applied automatically, and this will not be apparent in the signature
of the generated constructor.

@since 0.2.2.0

Pattern synonyms can be used to set type parameters to `Text.Gigaparsec.Position.Pos`:

> {-# LANGUAGE PatternSynonyms #-}
> pattern PosFoo :: Pos -> Foo Pos
> pattern PosFoo p = Foo p
> $(deriveLiftedConstructors "mk" ['PosFoo])

This will generate a lifted constructor of the shape:

> mkPosFoo :: Parsec (Foo Pos)

The @pos@ combinator will be applied automatically.

@since 0.2.6.0
-}
deriveLiftedConstructors :: String -- ^ The prefix to be added to generated names
                         -> [Name] -- ^ The list of "ticked" constructors to generate for
                         -> Q [Dec]
deriveLiftedConstructors :: String -> [Name] -> Q [Dec]
deriveLiftedConstructors String
prefix = ([[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] -> Q [[Dec]]) -> [Name] -> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Q [Dec]) -> [Name] -> 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 -> Q [Dec]
deriveCon
  where
    deriveCon :: Name -> Q [Dec]
    deriveCon :: Name -> Q [Dec]
deriveCon Name
con = do
      (con', ty, func, posFound, n) <- Bool
-> String
-> ([Q Type] -> Q Type)
-> Name
-> Q (Name, Q Type, Q Exp, Bool, Int)
extractMeta Bool
True String
prefix ([Q Type] -> Q Type
funcType ([Q Type] -> Q Type)
-> ([Q Type] -> [Q Type]) -> [Q Type] -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Q Type -> Q Type) -> [Q Type] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map Q Type -> Q Type
parserOf) Name
con
      args <- replicateM n (newName "x")
      sequence [ sigD con' ty
               , funD con' [clause (map varP args)
                   (normalB (posAp posFound (applyArgs [e|pure $func|] args))) []]
               ]

    applyArgs :: Q Exp -> [Name] -> Q Exp
    applyArgs :: Q Exp -> [Name] -> Q Exp
applyArgs = (Q Exp -> Name -> Q Exp) -> Q Exp -> [Name] -> Q Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Q Exp
rest Name
arg -> [e|$Q Exp
rest <*> $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
arg)|])


{-|
This function is used to automatically generate /Deferred Constructors/, which are
one of the patterns in /"Design Patterns for Parser Combinators/". It is provided
with a prefix, which is used to denote an application of the constructor, and
then a list of "ticked" constructors for which to generate deferred constructors. This
means adding a single @'@ in front of the constructor name. For example:

> {-# LANGUAGE TemplateHaskell #-}
> data Foo a = Foo a | Bar Int String
> $(deriveDeferredConstructors "mk" ['Foo, 'Bar])

Will generate two deferred constructors of the shape:

> mkFoo :: Parsec (a -> Foo a)
> mkBar :: Parsec (Int -> String -> Foo a)

Furthermore, if one of the arguments to the constructor has type `Text.Gigaparsec.Position.Pos`,
the @pos@ combinator will be applied automatically, and this will not be apparent in the signature
of the generated constructor.

@since 0.2.2.0

Pattern synonyms can be used to set type parameters to `Text.Gigaparsec.Position.Pos`:

> {-# LANGUAGE PatternSynonyms #-}
> pattern PosFoo :: Pos -> Foo Pos
> pattern PosFoo p = Foo p
> $(deriveLiftedConstructors "mk" ['PosFoo])

This will generate a lifted constructor of the shape:

> mkPosFoo :: Parsec (Foo Pos)

The @pos@ combinator will be applied automatically.

@since 0.2.6.0
-}
deriveDeferredConstructors :: String -- ^ The prefix to be added to generated names
                           -> [Name] -- ^ The list of "ticked" constructors to generate for
                           -> Q [Dec]
deriveDeferredConstructors :: String -> [Name] -> Q [Dec]
deriveDeferredConstructors String
prefix = ([[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] -> Q [[Dec]]) -> [Name] -> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Q [Dec]) -> [Name] -> 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 -> Q [Dec]
deriveCon
  where
    deriveCon :: Name -> Q [Dec]
    deriveCon :: Name -> Q [Dec]
deriveCon Name
con = do
      (con', ty, func, posFound, _) <- Bool
-> String
-> ([Q Type] -> Q Type)
-> Name
-> Q (Name, Q Type, Q Exp, Bool, Int)
extractMeta Bool
False String
prefix (Q Type -> Q Type
parserOf (Q Type -> Q Type) -> ([Q Type] -> Q Type) -> [Q Type] -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Q Type] -> Q Type
funcType) Name
con
      sequence [ sigD con' ty
               , funD con' [clause [] (normalB (posAp posFound [e|pure $func|])) []]
               ]

posAp :: Bool -> Q Exp -> Q Exp
posAp :: Bool -> Q Exp -> Q Exp
posAp Bool
True  Q Exp
p = [e| pos <**> $Q Exp
p |]
posAp Bool
False Q Exp
p = Q Exp
p

funcType :: [Q Type] -> Q Type
funcType :: [Q Type] -> Q Type
funcType = (Q Type -> Q Type -> Q Type) -> [Q Type] -> Q Type
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\Q Type
ty Q Type
rest -> [t| $Q Type
ty -> $Q Type
rest |])

parserOf :: Q Type -> Q Type
parserOf :: Q Type -> Q Type
parserOf Q Type
ty = [t| Parsec $Q Type
ty |]

extractConType :: Info -> Maybe Type
extractConType :: Info -> Maybe Type
extractConType (DataConI Name
_ Type
ty Name
_) = Type -> Maybe Type
forall a. a -> Maybe a
Just Type
ty
extractConType (PatSynI Name
_ Type
ty) = Type -> Maybe Type
forall a. a -> Maybe a
Just Type
ty
extractConType Info
_ = Maybe Type
forall a. Maybe a
Nothing

extractMeta :: Bool -> String -> ([Q Type] -> Q Type) -> Name
          -> Q (Name, Q Type, Q Exp, Bool, Int)
extractMeta :: Bool
-> String
-> ([Q Type] -> Q Type)
-> Name
-> Q (Name, Q Type, Q Exp, Bool, Int)
extractMeta Bool
posLast String
prefix [Q Type] -> Q Type
buildType Name
con = do
  Just ty <- (Info -> Maybe Type) -> Q Info -> Q (Maybe Type)
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Info -> Maybe Type
extractConType (Q Info -> Q (Maybe Type)) -> Q Info -> Q (Maybe Type)
forall a b. (a -> b) -> a -> b
$ Name -> Q Info
reify Name
con
  (forAll, tys) <- splitFun ty
  posIdx <- findPosIdx con tys
  let tys' = (Int -> [Type] -> [Type]) -> Maybe Int -> [Type] -> [Type]
forall a b. (a -> b -> b) -> Maybe a -> b -> b
maybeApply Int -> [Type] -> [Type]
forall a. Int -> [a] -> [a]
deleteAt Maybe Int
posIdx [Type]
tys
  let nargs = [Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
tys' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
  let con' = String -> Name
mkName (String
prefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
pretty Name
con)
  let func = Bool -> Name -> Int -> Maybe Int -> Q Exp
buildLiftedLambda Bool
posLast Name
con Int
nargs Maybe Int
posIdx
  return (con', forAll (buildType (map return tys')), func, isJust posIdx, nargs)

splitFun :: Type -> Q (Q Type -> Q Type, [Type])
splitFun :: Type -> Q (Q Type -> Q Type, [Type])
splitFun (ForallT [TyVarBndr Specificity]
bndrs [Type]
ctx Type
ty) = do
  kindSigs <- Extension -> Q Bool
isExtEnabled Extension
KindSignatures
  let bndrs' = if Bool
kindSigs then [TyVarBndr Specificity]
bndrs else (TyVarBndr Specificity -> TyVarBndr Specificity)
-> [TyVarBndr Specificity] -> [TyVarBndr Specificity]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr Specificity -> TyVarBndr Specificity
forall flag. TyVarBndr flag -> TyVarBndr flag
sanitiseStarT [TyVarBndr Specificity]
bndrs
  (forallT', ty') <- splitFun ty
  return (forallT bndrs' (pure ctx) . forallT', ty')
splitFun Type
ty                     = (Q Type -> Q Type, [Type]) -> Q (Q Type -> Q Type, [Type])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Q Type -> Q Type
forall a. a -> a
id, Type -> [Type]
splitFun' Type
ty)

splitFun' :: Type -> [Type]
splitFun' :: Type -> [Type]
splitFun' (AppT (AppT Type
ArrowT Type
a) Type
b)             = Type
a Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: Type -> [Type]
splitFun' Type
b -- regular function type
#if __GLASGOW_HASKELL__ >= 902
splitFun' (AppT (AppT (AppT Type
MulArrowT Type
_) Type
a) Type
b) = Type
a Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: Type -> [Type]
splitFun' Type
b -- linear function type
#endif
splitFun' Type
ty                                   = [Type
ty]

-- When KindSignatures is off, the default (a :: *) that TH generates is broken!
#if __GLASGOW_HASKELL__ >= 900
sanitiseStarT :: TyVarBndr flag -> TyVarBndr flag
sanitiseStarT :: forall flag. TyVarBndr flag -> TyVarBndr flag
sanitiseStarT (KindedTV Name
ty flag
flag Type
StarT) = Name -> flag -> TyVarBndr flag
forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
ty flag
flag
sanitiseStarT TyVarBndr flag
ty = TyVarBndr flag
ty
#else
sanitiseStarT :: TyVarBndr -> TyVarBndr
sanitiseStarT (KindedTV ty StarT) = PlainTV ty
sanitiseStarT ty = ty
#endif

findPosIdx :: Name -> [Type] -> Q (Maybe Int)
findPosIdx :: Name -> [Type] -> Q (Maybe Int)
findPosIdx Name
con [Type]
tys = case Type -> [Type] -> [Int]
forall a. Eq a => a -> [a] -> [Int]
elemIndices (Name -> Type
ConT ''Pos) [Type]
tys of
     []    -> Maybe Int -> Q (Maybe Int)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Int
forall a. Maybe a
Nothing
     [Int
idx] -> Maybe Int -> Q (Maybe Int)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
idx)
     [Int]
_     -> String -> Q (Maybe Int)
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (Maybe Int)) -> String -> Q (Maybe Int)
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords -- more than 1 index, which is ambiguous
        [String
"constructor", Name -> String
pretty Name
con, String
"has multiple occurrences of Text.Gigaparsec.Position.Pos"]

buildLiftedLambda :: Bool -> Name -> Int -> Maybe Int -> Q Exp
buildLiftedLambda :: Bool -> Name -> Int -> Maybe Int -> Q Exp
buildLiftedLambda Bool
posLast Name
con Int
nargs Maybe Int
posIdx = do
  args <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
nargs (String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x")
  posArg <- newName "pos"
  let pargs = if | Maybe Int -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Int
posIdx -> (Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
args
                 | Bool
posLast          -> (Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
args [Q Pat] -> [Q Pat] -> [Q Pat]
forall a. [a] -> [a] -> [a]
++ [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
posArg]
                 | Bool
otherwise        -> Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
posArg Q Pat -> [Q Pat] -> [Q Pat]
forall a. a -> [a] -> [a]
: (Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
args
  let eargs = (Int -> [Q Exp] -> [Q Exp]) -> Maybe Int -> [Q Exp] -> [Q Exp]
forall a b. (a -> b -> b) -> Maybe a -> b -> b
maybeApply ((Int -> Q Exp -> [Q Exp] -> [Q Exp])
-> Q Exp -> Int -> [Q Exp] -> [Q Exp]
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> Q Exp -> [Q Exp] -> [Q Exp]
forall a. Int -> a -> [a] -> [a]
insertAt (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
posArg)) Maybe Int
posIdx ((Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE [Name]
args)
  lamE pargs (foldl' (\Q Exp
acc Q Exp
arg -> [e|$Q Exp
acc $Q Exp
arg|]) (conE con) eargs)

insertAt :: Int -> a -> [a] -> [a]
insertAt :: forall a. Int -> a -> [a] -> [a]
insertAt Int
0 a
x [a]
xs = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
xs
insertAt Int
n a
x (a
x' : [a]
xs) = a
x' a -> [a] -> [a]
forall a. a -> [a] -> [a]
: Int -> a -> [a] -> [a]
forall a. Int -> a -> [a] -> [a]
insertAt (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) a
x [a]
xs
insertAt Int
_ a
_ [] = []

maybeApply :: (a -> b -> b) -> Maybe a -> b -> b
maybeApply :: forall a b. (a -> b -> b) -> Maybe a -> b -> b
maybeApply = (b -> b) -> (a -> b -> b) -> Maybe a -> b -> b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe b -> b
forall a. a -> a
id

deleteAt :: Int -> [a] -> [a]
deleteAt :: forall a. Int -> [a] -> [a]
deleteAt Int
0 (a
_:[a]
xs)  = [a]
xs
deleteAt Int
n (a
x:[a]
xs)  = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
deleteAt (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) [a]
xs
deleteAt Int
_ []      = []

elemIndices :: forall a. Eq a => a -> [a] -> [Int]
elemIndices :: forall a. Eq a => a -> [a] -> [Int]
elemIndices = Int -> a -> [a] -> [Int]
go Int
0
  where go :: Int -> a -> [a] -> [Int]
        go :: Int -> a -> [a] -> [Int]
go Int
_ a
_ [] = []
        go Int
i a
y (a
x:[a]
xs)
          | a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y     = Int
i Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: Int -> a -> [a] -> [Int]
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) a
y [a]
xs
          | Bool
otherwise  = Int -> a -> [a] -> [Int]
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) a
y [a]
xs

pretty :: Name -> String
pretty :: Name -> String
pretty = String -> String
forall a. [a] -> [a]
reverse (String -> String) -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'.') (String -> String) -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. [a] -> [a]
reverse (String -> String) -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
forall a. Show a => a -> String
show