{-# LANGUAGE TemplateHaskell #-} module Inferno.Utils.QQ.Module where import Control.Monad.Reader (ReaderT (..)) import Control.Monad.Writer (WriterT (..)) import Data.Data (Proxy (..), cast) import Data.Generics.Aliases (extQ) import Data.List (intercalate) import qualified Data.List.NonEmpty as NEList import Data.Text (pack) import Inferno.Infer (closeOverType) import Inferno.Module (buildPinnedQQModules) import Inferno.Parse ( QQDefinition (..), modulesParser, topLevel, ) import qualified Inferno.Types.Type as Type import Inferno.Utils.QQ.Common ( liftText, location', mkParseErrorStr, ) import qualified Language.Haskell.TH.Lib as TH import Language.Haskell.TH.Quote (QuasiQuoter (..), dataToExpQ) import Language.Haskell.TH.Syntax (mkName) import Text.Megaparsec ( ParseErrorBundle (ParseErrorBundle), PosState (PosState), State (State), attachSourcePos, defaultTabWidth, errorOffset, runParser', ) mkProxy :: a -> Proxy a mkProxy :: forall a. a -> Proxy a mkProxy a _ = forall {k} (t :: k). Proxy t Proxy metaToValue :: (Maybe Type.TCScheme, QQDefinition) -> Maybe TH.ExpQ metaToValue :: (Maybe TCScheme, QQDefinition) -> Maybe ExpQ metaToValue = \case (Just TCScheme sch, QQToValueDef [Char] x) -> forall a. a -> Maybe a Just [|Left ($(dataToExpQ (\a -> liftText <$> cast a) sch), toValue $(TH.varE (mkName x)))|] (Maybe TCScheme Nothing, QQToValueDef [Char] x) -> forall a. a -> Maybe a Just [|Left (closeOverType (toType (mkProxy $(TH.varE (mkName x)))), toValue $(TH.varE (mkName x)))|] (Just TCScheme sch, QQRawDef [Char] x) -> forall a. a -> Maybe a Just [|Left ($(dataToExpQ (\a -> liftText <$> cast a) sch), pure $(TH.varE (mkName x)))|] (Maybe TCScheme Nothing, QQRawDef [Char] _) -> forall a. HasCallStack => [Char] -> a error [Char] "QQRawDef must have an explicit type" (Maybe TCScheme sch, InlineDef Expr () SourcePos e) -> forall a. a -> Maybe a Just [|Right ($(dataToExpQ (\a -> liftText <$> cast a) sch), $(dataToExpQ (\a -> liftText <$> cast a) e))|] infernoModules :: QuasiQuoter infernoModules :: QuasiQuoter infernoModules = QuasiQuoter { quoteExp :: [Char] -> ExpQ quoteExp = \[Char] str -> do SourcePos l <- Q SourcePos location' let (State Text InfernoParsingError _, Either (ParseErrorBundle Text InfernoParsingError) ([(ModuleName, OpsTable, [TopLevelDefn (Maybe TCScheme, QQDefinition)])], Comments) res) = forall e s a. Parsec e s a -> State s e -> (State s e, Either (ParseErrorBundle s e) a) runParser' (forall w (m :: * -> *) a. WriterT w m a -> m (a, w) runWriterT forall a b. (a -> b) -> a -> b $ forall a b c. (a -> b -> c) -> b -> a -> c flip forall r (m :: * -> *) a. ReaderT r m a -> r -> m a runReaderT (forall a. Monoid a => a mempty, forall a. Monoid a => a mempty) forall a b. (a -> b) -> a -> b $ forall r a. SomeParser r a -> SomeParser r a topLevel forall a b. (a -> b) -> a -> b $ SomeParser (OpsTable, Map ModuleName OpsTable) [(ModuleName, OpsTable, [TopLevelDefn (Maybe TCScheme, QQDefinition)])] modulesParser) forall a b. (a -> b) -> a -> b $ forall s e. s -> Int -> PosState s -> [ParseError s e] -> State s e State ([Char] -> Text pack [Char] str) Int 0 (forall s. s -> Int -> SourcePos -> Pos -> [Char] -> PosState s PosState ([Char] -> Text pack [Char] str) Int 0 SourcePos l Pos defaultTabWidth [Char] "") [] case Either (ParseErrorBundle Text InfernoParsingError) ([(ModuleName, OpsTable, [TopLevelDefn (Maybe TCScheme, QQDefinition)])], Comments) res of Left (ParseErrorBundle NonEmpty (ParseError Text InfernoParsingError) errs PosState Text pos) -> let errs' :: [[Char]] errs' = forall a b. (a -> b) -> [a] -> [b] map forall e. ShowErrorComponent e => (ParseError Text e, SourcePos) -> [Char] mkParseErrorStr forall a b. (a -> b) -> a -> b $ forall a. NonEmpty a -> [a] NEList.toList forall a b. (a -> b) -> a -> b $ forall a b. (a, b) -> a fst forall a b. (a -> b) -> a -> b $ forall (t :: * -> *) s a. (Traversable t, TraversableStream s) => (a -> Int) -> t a -> PosState s -> (t (a, SourcePos), PosState s) attachSourcePos forall s e. ParseError s e -> Int errorOffset NonEmpty (ParseError Text InfernoParsingError) errs PosState Text pos in forall (m :: * -> *) a. MonadFail m => [Char] -> m a fail forall a b. (a -> b) -> a -> b $ forall a. [a] -> [[a]] -> [a] intercalate [Char] "\n\n" [[Char]] errs' Right ([(ModuleName, OpsTable, [TopLevelDefn (Maybe TCScheme, QQDefinition)])] modules, Comments _comments) -> [|buildPinnedQQModules $(dataToExpQ ((\a -> liftText <$> cast a) `extQ` metaToValue) modules)|], quotePat :: [Char] -> Q Pat quotePat = forall a. HasCallStack => [Char] -> a error [Char] "infernoModule: Invalid use of this quasi-quoter in pattern context.", quoteType :: [Char] -> Q Type quoteType = forall a. HasCallStack => [Char] -> a error [Char] "infernoModule: Invalid use of this quasi-quoter in type context.", quoteDec :: [Char] -> Q [Dec] quoteDec = forall a. HasCallStack => [Char] -> a error [Char] "infernoModule: Invalid use of this quasi-quoter in top-level declaration context." }