{-# 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))
            )