-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- A quasiquoter for Swarm terms.
module Swarm.Language.Pipeline.QQ (tmQ) 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.Util (fully)
import Swarm.Language.Pipeline
import Swarm.Language.Pretty
import Swarm.Language.Syntax
import Swarm.Language.Types (Polytype)
import Swarm.Util (failT, liftText)
import Witch (from)

-- | A quasiquoter for Swarm language terms, so we can conveniently
--   write them down using concrete syntax and have them parsed into
--   abstract syntax at compile time.  The quasiquoter actually runs
--   the entire pipeline on them (parsing, typechecking, elaborating),
--   so a quasiquoted Swarm program with a parse error or a type error
--   will fail at Haskell compile time.  This is useful for creating
--   system robot programs (for example, see
--   'Swarm.Game.Step.seedProgram').
tmQ :: QuasiQuoter
tmQ :: QuasiQuoter
tmQ =
  QuasiQuoter
    { quoteExp :: String -> Q Exp
quoteExp = String -> Q Exp
quoteTermExp
    , quotePat :: String -> Q Pat
quotePat = String -> String -> Q Pat
forall a. HasCallStack => String -> a
error String
"quotePat  not implemented for terms"
    , quoteType :: String -> Q Type
quoteType = String -> String -> Q Type
forall a. HasCallStack => String -> a
error String
"quoteType not implemented for terms"
    , quoteDec :: String -> Q [Dec]
quoteDec = String -> String -> Q [Dec]
forall a. HasCallStack => String -> a
error String
"quoteDec  not implemented for terms"
    }

quoteTermExp :: String -> TH.ExpQ
quoteTermExp :: String -> Q Exp
quoteTermExp 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)
        )
  Syntax
parsed <- (String, Int, Int) -> Parser Syntax -> String -> Q Syntax
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 Syntax -> Parser Syntax
forall e s (f :: * -> *) a. MonadParsec e s f => f () -> f a -> f a
fully ReaderT ParserConfig (StateT CommentState (Parsec Void Text)) ()
sc Parser Syntax
parseTerm) String
s
  case Syntax -> Either ContextualTypeErr TSyntax
processParsedTerm Syntax
parsed of
    Left ContextualTypeErr
err -> [Text] -> Q Exp
forall (m :: * -> *) a. MonadFail m => [Text] -> m a
failT [Text -> ContextualTypeErr -> Text
prettyTypeErrText (String -> Text
forall source target. From source target => source -> target
from String
s) ContextualTypeErr
err]
    Right TSyntax
ptm -> (forall b. Data b => b -> Maybe (Q Exp)) -> TSyntax -> 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))
-> (Term' (Poly Type) -> Maybe (Q Exp)) -> b -> Maybe (Q Exp)
forall a b r.
(Typeable a, Typeable b) =>
(a -> r) -> (b -> r) -> a -> r
`extQ` Term' (Poly Type) -> Maybe (Q Exp)
antiTermExp) TSyntax
ptm

antiTermExp :: Term' Polytype -> Maybe TH.ExpQ
antiTermExp :: Term' (Poly Type) -> Maybe (Q Exp)
antiTermExp (TAntiText 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
$ Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
TH.appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
TH.conE (String -> Name
TH.mkName String
"TText")) (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)))
antiTermExp (TAntiInt 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
$ Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
TH.appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
TH.conE (String -> Name
TH.mkName String
"TInt")) (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)))
antiTermExp Term' (Poly Type)
_ = Maybe (Q Exp)
forall a. Maybe a
Nothing

-- At the moment, only antiquotation of literal text and ints are
-- supported, because that's what we need for the seedProgram.  But
-- we can easily add more in the future.