{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} module Inferno.Utils.QQ.Script where import Control.Monad.Reader (ReaderT (..)) import Control.Monad.Writer (WriterT (..), appEndo) import qualified Crypto.Hash as Crypto import Data.ByteArray (convert) import Data.ByteString (ByteString, unpack) import Data.Data (cast) import Data.Generics.Aliases (extQ) import Data.List (intercalate) import qualified Data.List.NonEmpty as NEList import qualified Data.Maybe as Maybe import Data.Text (pack) import Inferno.Eval.Error (EvalError) import Inferno.Infer (inferExpr) import Inferno.Infer.Pinned (pinExpr) import Inferno.Module.Prelude (baseOpsTable, builtinModules, builtinModulesOpsTable, builtinModulesPinMap) import Inferno.Parse (expr, topLevel) import Inferno.Parse.Commented (insertCommentsIntoExpr) 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 (Exp (AppE, VarE), Lift (lift)) import Prettyprinter (Pretty) import Text.Megaparsec ( ParseErrorBundle (ParseErrorBundle), PosState (PosState), State (State), attachSourcePos, defaultTabWidth, errorOffset, runParser', ) inferno :: forall c. (Pretty c, Eq c) => QuasiQuoter inferno :: forall c. (Pretty c, Eq c) => QuasiQuoter inferno = QuasiQuoter { quoteExp :: [Char] -> Q Exp quoteExp = \[Char] str -> do SourcePos l <- Q SourcePos location' let (State Text InfernoParsingError _, Either (ParseErrorBundle Text InfernoParsingError) (Expr () SourcePos, 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 (m :: * -> *) c. (MonadError EvalError m, Pretty c, Eq c) => ModuleMap m c -> OpsTable baseOpsTable @_ @c ModuleMap (Either EvalError) c builtins, forall (m :: * -> *) c. (MonadError EvalError m, Pretty c, Eq c) => ModuleMap m c -> Map ModuleName OpsTable builtinModulesOpsTable @_ @c ModuleMap (Either EvalError) c builtins) 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) (Expr () SourcePos) expr) 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) (Expr () SourcePos, 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 (Expr () SourcePos ast, Comments comments) -> case forall (m :: * -> *) a h. (MonadError [TypeError SourcePos] m, Eq a) => Map (Scoped ModuleName) (Map Namespace (Pinned a)) -> Expr h SourcePos -> m (Expr (Pinned a) SourcePos) pinExpr (forall (m :: * -> *) c. (MonadError EvalError m, Pretty c, Eq c) => ModuleMap m c -> Map (Scoped ModuleName) (Map Namespace (Pinned VCObjectHash)) builtinModulesPinMap @_ @c ModuleMap (Either EvalError) c builtins) Expr () SourcePos ast of Left [TypeError SourcePos] err -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a fail forall a b. (a -> b) -> a -> b $ [Char] "Pinning expression failed:\n" forall a. Semigroup a => a -> a -> a <> forall a. Show a => a -> [Char] show [TypeError SourcePos] err Right Expr (Pinned VCObjectHash) SourcePos pinnedAST -> case forall m. Map ModuleName (PinnedModule m) -> Expr (Pinned VCObjectHash) SourcePos -> Either [TypeError SourcePos] (Expr (Pinned VCObjectHash) SourcePos, TCScheme, Map (Location SourcePos) (TypeMetadata TCScheme)) inferExpr ModuleMap (Either EvalError) c builtins Expr (Pinned VCObjectHash) SourcePos pinnedAST of Left [TypeError SourcePos] err -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a fail forall a b. (a -> b) -> a -> b $ [Char] "Inference failed:\n" forall a. Semigroup a => a -> a -> a <> forall a. Show a => a -> [Char] show [TypeError SourcePos] err Right (Expr (Pinned VCObjectHash) SourcePos pinnedAST', TCScheme t, Map (Location SourcePos) (TypeMetadata TCScheme) _tyMap) -> do let final :: Expr (Pinned VCObjectHash) SourcePos final = forall hash. [Comment SourcePos] -> Expr hash SourcePos -> Expr hash SourcePos insertCommentsIntoExpr (forall a. Endo a -> a -> a appEndo Comments comments []) Expr (Pinned VCObjectHash) SourcePos pinnedAST' forall (m :: * -> *) a. (Quote m, Data a) => (forall b. Data b => b -> Maybe (m Exp)) -> a -> m Exp dataToExpQ ((\b a -> Text -> Q Exp liftText forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall a b. (Typeable a, Typeable b) => a -> Maybe b cast b a) forall a b q. (Typeable a, Typeable b) => (a -> q) -> (b -> q) -> a -> q `extQ` Digest SHA256 -> Maybe (Q Exp) vcObjectHashToValue) (Expr (Pinned VCObjectHash) SourcePos final, TCScheme t), quotePat :: [Char] -> Q Pat quotePat = forall a. HasCallStack => [Char] -> a error [Char] "inferno: Invalid use of this quasi-quoter in pattern context.", quoteType :: [Char] -> Q Type quoteType = forall a. HasCallStack => [Char] -> a error [Char] "inferno: Invalid use of this quasi-quoter in type context.", quoteDec :: [Char] -> Q [Dec] quoteDec = forall a. HasCallStack => [Char] -> a error [Char] "inferno: Invalid use of this quasi-quoter in top-level declaration context." } where builtins :: ModuleMap (Either EvalError) c builtins = forall (m :: * -> *) c. (MonadError EvalError m, Pretty c, Eq c) => ModuleMap m c builtinModules @(Either EvalError) @c vcObjectHashToValue :: Crypto.Digest Crypto.SHA256 -> Maybe TH.ExpQ vcObjectHashToValue :: Digest SHA256 -> Maybe (Q Exp) vcObjectHashToValue Digest SHA256 h = let str :: ByteString str = (forall bin bout. (ByteArrayAccess bin, ByteArray bout) => bin -> bout convert Digest SHA256 h) :: ByteString in forall a. a -> Maybe a Just forall a b. (a -> b) -> a -> b $ ( Exp -> Exp -> Exp AppE (Name -> Exp VarE 'Maybe.fromJust) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> (Exp -> Exp -> Exp AppE (Name -> Exp VarE 'Crypto.digestFromByteString) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp lift (ByteString -> [Word8] unpack ByteString str)) )