-- |
-- 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.Parse
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 = forall a. HasCallStack => String -> a
error String
"quotePat  not implemented for terms"
    , quoteType :: String -> Q Type
quoteType = forall a. HasCallStack => String -> a
error String
"quoteType not implemented for terms"
    , quoteDec :: String -> Q [Dec]
quoteDec = 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
        , forall a b. (a, b) -> a
fst (Loc -> CharPos
TH.loc_start Loc
loc)
        , forall a b. (a, b) -> b
snd (Loc -> CharPos
TH.loc_start Loc
loc)
        )
  Syntax
parsed <- forall (m :: * -> *) a.
(Monad m, MonadFail m) =>
(String, Int, Int) -> Parser a -> String -> m a
runParserTH (String, Int, Int)
pos Parser Syntax
parseTerm String
s
  case Syntax -> Either ContextualTypeErr ProcessedTerm
processParsedTerm Syntax
parsed of
    Left ContextualTypeErr
err -> forall (m :: * -> *) a. MonadFail m => [Text] -> m a
failT [Text -> ContextualTypeErr -> Text
prettyTypeErrText (forall source target. From source target => source -> target
from String
s) ContextualTypeErr
err]
    Right ProcessedTerm
ptm -> forall (m :: * -> *) a.
(Quote m, Data a) =>
(forall b. Data b => b -> Maybe (m Exp)) -> a -> m Exp
dataToExpQ ((forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Q Exp
liftText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast) forall a b r.
(Typeable a, Typeable b) =>
(a -> r) -> (b -> r) -> a -> r
`extQ` Term' Polytype -> Maybe (Q Exp)
antiTermExp) ProcessedTerm
ptm

antiTermExp :: Term' Polytype -> Maybe TH.ExpQ
antiTermExp :: Term' Polytype -> Maybe (Q Exp)
antiTermExp (TAntiText Text
v) =
  forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
TH.appE (forall (m :: * -> *). Quote m => Name -> m Exp
TH.conE (String -> Name
TH.mkName String
"TText")) (forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE (String -> Name
TH.mkName (forall source target. From source target => source -> target
from Text
v)))
antiTermExp (TAntiInt Text
v) =
  forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
TH.appE (forall (m :: * -> *). Quote m => Name -> m Exp
TH.conE (String -> Name
TH.mkName String
"TInt")) (forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE (String -> Name
TH.mkName (forall source target. From source target => source -> target
from Text
v)))
antiTermExp Term' Polytype
_ = 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.