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.Language.Types (Polytype)
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' 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