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 (prettyText)
import Swarm.Language.Syntax
import Swarm.Util (liftText)
import Witch (from)
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 TypeErr ProcessedTerm
processParsedTerm Syntax
parsed of
Left TypeErr
errMsg -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall source target. From source target => source -> target
from forall a b. (a -> b) -> a -> b
$ forall a. PrettyPrec a => a -> Text
prettyText TypeErr
errMsg
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 q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` Term -> Maybe (Q Exp)
antiTermExp) ProcessedTerm
ptm
antiTermExp :: Term -> Maybe TH.ExpQ
antiTermExp :: Term -> 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
_ = forall a. Maybe a
Nothing