-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- A quasiquoter for Swarm polytypes.
module Swarm.Language.Parser.QQ (tyQ) where

import Data.Generics
import Language.Haskell.TH qualified as TH
import Language.Haskell.TH.Quote
import Swarm.Language.Parser.Core (runParserTH)
import Swarm.Language.Parser.Lex (sc)
import Swarm.Language.Parser.Type (parsePolytype)
import Swarm.Language.Parser.Util (fully)
import Swarm.Util (liftText)

------------------------------------------------------------
-- Quasiquoters
------------------------------------------------------------

-- | A quasiquoter for Swarm polytypes, so we can conveniently write them
--   down using concrete syntax and have them parsed into abstract
--   syntax at compile time.  This is used, for example, in writing down
--   the concrete types of constants (see "Swarm.Language.Typecheck").
tyQ :: QuasiQuoter
tyQ :: QuasiQuoter
tyQ =
  QuasiQuoter
    { quoteExp :: String -> Q Exp
quoteExp = String -> Q Exp
quoteTypeExp
    , quotePat :: String -> Q Pat
quotePat = String -> String -> Q Pat
forall a. HasCallStack => String -> a
error String
"quotePat  not implemented for polytypes"
    , quoteType :: String -> Q Type
quoteType = String -> String -> Q Type
forall a. HasCallStack => String -> a
error String
"quoteType not implemented for polytypes"
    , quoteDec :: String -> Q [Dec]
quoteDec = String -> String -> Q [Dec]
forall a. HasCallStack => String -> a
error String
"quoteDec  not implemented for polytypes"
    }

quoteTypeExp :: String -> TH.ExpQ
quoteTypeExp :: String -> Q Exp
quoteTypeExp String
s = do
  Loc
loc <- Q Loc
TH.location
  let pos :: (String, Int, Int)
pos =
        ( Loc -> String
TH.loc_filename Loc
loc
        , (Int, Int) -> Int
forall a b. (a, b) -> a
fst (Loc -> (Int, Int)
TH.loc_start Loc
loc)
        , (Int, Int) -> Int
forall a b. (a, b) -> b
snd (Loc -> (Int, Int)
TH.loc_start Loc
loc)
        )
  Polytype
parsed <- (String, Int, Int) -> Parser Polytype -> String -> Q Polytype
forall (m :: * -> *) a.
(Monad m, MonadFail m) =>
(String, Int, Int) -> Parser a -> String -> m a
runParserTH (String, Int, Int)
pos (ReaderT ParserConfig (StateT CommentState (Parsec Void Text)) ()
-> Parser Polytype -> Parser Polytype
forall e s (f :: * -> *) a. MonadParsec e s f => f () -> f a -> f a
fully ReaderT ParserConfig (StateT CommentState (Parsec Void Text)) ()
sc Parser Polytype
parsePolytype) String
s
  (forall b. Data b => b -> Maybe (Q Exp)) -> Polytype -> Q Exp
forall (m :: * -> *) a.
(Quote m, Data a) =>
(forall b. Data b => b -> Maybe (m Exp)) -> a -> m Exp
dataToExpQ ((Text -> Q Exp) -> Maybe Text -> Maybe (Q Exp)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Q Exp
liftText (Maybe Text -> Maybe (Q Exp))
-> (b -> Maybe Text) -> b -> Maybe (Q Exp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Maybe Text
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast) Polytype
parsed