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)