{-# 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."
    }