-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- A quasiquoter for Swarm polytypes + untyped terms.
module Swarm.Language.Parser.QQ (tyQ, astQ) 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.Term (parseTerm)
import Swarm.Language.Parser.Type (parsePolytype)
import Swarm.Language.Parser.Util (fully)
import Swarm.Language.Syntax
import Swarm.Util (liftText)
import Witch (from)

------------------------------------------------------------
-- 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
    , -- Using `error` is OK here since a quasiquoter will only ever run
      -- at compile time; hence it can only make compilation fail, not
      -- crash the game at runtime.
      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
  RawPolytype
parsed <- Loc -> Parser RawPolytype -> String -> Q RawPolytype
forall (m :: * -> *) a.
(Monad m, MonadFail m) =>
Loc -> Parser a -> String -> m a
runParserTH Loc
loc (ReaderT ParserConfig (StateT WSState (Parsec Void Text)) ()
-> Parser RawPolytype -> Parser RawPolytype
forall e s (f :: * -> *) a. MonadParsec e s f => f () -> f a -> f a
fully ReaderT ParserConfig (StateT WSState (Parsec Void Text)) ()
sc Parser RawPolytype
parsePolytype) String
s
  (forall b. Data b => b -> Maybe (Q Exp)) -> RawPolytype -> 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) RawPolytype
parsed

astQ :: QuasiQuoter
astQ :: QuasiQuoter
astQ =
  QuasiQuoter
    { quoteExp :: String -> Q Exp
quoteExp = String -> Q Exp
quoteASTExp
    , quotePat :: String -> Q Pat
quotePat = String -> String -> Q Pat
forall a. HasCallStack => String -> a
error String
"quotePat  not implemented for ASTs"
    , quoteType :: String -> Q Type
quoteType = String -> String -> Q Type
forall a. HasCallStack => String -> a
error String
"quoteType not implemented for ASTs"
    , quoteDec :: String -> Q [Dec]
quoteDec = String -> String -> Q [Dec]
forall a. HasCallStack => String -> a
error String
"quoteDec  not implemented for ASTs"
    }

quoteASTExp :: String -> TH.ExpQ
quoteASTExp :: String -> Q Exp
quoteASTExp String
s = do
  Loc
loc <- Q Loc
TH.location
  Syntax
parsed <- Loc -> Parser Syntax -> String -> Q Syntax
forall (m :: * -> *) a.
(Monad m, MonadFail m) =>
Loc -> Parser a -> String -> m a
runParserTH Loc
loc (ReaderT ParserConfig (StateT WSState (Parsec Void Text)) ()
-> Parser Syntax -> Parser Syntax
forall e s (f :: * -> *) a. MonadParsec e s f => f () -> f a -> f a
fully ReaderT ParserConfig (StateT WSState (Parsec Void Text)) ()
sc Parser Syntax
parseTerm) String
s
  (forall b. Data b => b -> Maybe (Q Exp)) -> Syntax -> 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) (b -> Maybe (Q Exp))
-> (Syntax -> Maybe (Q Exp)) -> b -> Maybe (Q Exp)
forall a b r.
(Typeable a, Typeable b) =>
(a -> r) -> (b -> r) -> a -> r
`extQ` Syntax -> Maybe (Q Exp)
antiASTExp) Syntax
parsed

antiASTExp :: Syntax -> Maybe TH.ExpQ
antiASTExp :: Syntax -> Maybe (Q Exp)
antiASTExp (STerm (TAntiSyn Text
v)) = Q Exp -> Maybe (Q Exp)
forall a. a -> Maybe a
Just (Q Exp -> Maybe (Q Exp)) -> Q Exp -> Maybe (Q Exp)
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE (String -> Name
TH.mkName (Text -> String
forall source target. From source target => source -> target
from Text
v))
antiASTExp Syntax
_ = Maybe (Q Exp)
forall a. Maybe a
Nothing