module LambdaCube.Common.TH
  ( qExpBase

  , converterBase
  ) where

import           Data.Data                  (Data)
import           Data.Generics              (extQ)
import           Data.Text                  (Text)
import qualified Data.Text                  as Text
import           LambdaCube.Common.Parser
import           Language.Haskell.TH.Lib    (ExpQ)
import           Language.Haskell.TH.Syntax (dataToExpQ, lift, loc_start,
                                             location)
import qualified Text.Megaparsec            as P

qExpBase :: Data a => Parser a -> (forall b. Data b => b -> Maybe ExpQ) -> String -> ExpQ
qExpBase :: Parser a -> (forall b. Data b => b -> Maybe ExpQ) -> String -> ExpQ
qExpBase Parser a
p forall b. Data b => b -> Maybe ExpQ
conv String
str = do
  Loc
l <- Q Loc
location
  case Parser a -> String -> Text -> Either (ParseErrorBundle Text Void) a
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
P.parse Parser a
p (String
"<quote at " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> CharPos -> String
forall a. Show a => a -> String
show (Loc -> CharPos
loc_start Loc
l) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
">") (String -> Text
Text.pack String
str) of
    Right a
e  -> (forall b. Data b => b -> Maybe ExpQ) -> a -> ExpQ
forall a.
Data a =>
(forall b. Data b => b -> Maybe ExpQ) -> a -> ExpQ
dataToExpQ forall b. Data b => b -> Maybe ExpQ
conv a
e
    Left ParseErrorBundle Text Void
err -> String -> ExpQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ExpQ) -> String -> ExpQ
forall a b. (a -> b) -> a -> b
$ ParseErrorBundle Text Void -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
P.errorBundlePretty ParseErrorBundle Text Void
err

converterBase :: Data b => b -> Maybe ExpQ
converterBase :: b -> Maybe ExpQ
converterBase = Maybe ExpQ -> b -> Maybe ExpQ
forall a b. a -> b -> a
const Maybe ExpQ
forall a. Maybe a
Nothing (b -> Maybe ExpQ) -> (Text -> Maybe ExpQ) -> b -> Maybe ExpQ
forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` (ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
Just (ExpQ -> Maybe ExpQ) -> (Text -> ExpQ) -> Text -> Maybe ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ExpQ
forall t. Lift t => t -> ExpQ
lift :: Text -> Maybe ExpQ)