-- |
-- Module      :  Swarm.Language.Parse.QQ
-- Copyright   :  Brent Yorgey
-- Maintainer  :  byorgey@gmail.com
--
-- SPDX-License-Identifier: BSD-3-Clause
--
-- A quasiquoter for Swarm polytypes.
module Swarm.Language.Parse.QQ (tyQ) where

import Data.Generics
import Language.Haskell.TH qualified as TH
import Language.Haskell.TH.Quote
import Swarm.Language.Parse
import Swarm.Util (liftText)

------------------------------------------------------------
-- 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
    , quotePat :: String -> Q Pat
quotePat = forall a. HasCallStack => String -> a
error String
"quotePat  not implemented for polytypes"
    , quoteType :: String -> Q Type
quoteType = forall a. HasCallStack => String -> a
error String
"quoteType not implemented for polytypes"
    , quoteDec :: String -> Q [Dec]
quoteDec = 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
  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)
        )
  Polytype
parsed <- forall (m :: * -> *) a.
(Monad m, MonadFail m) =>
(String, Int, Int) -> Parser a -> String -> m a
runParserTH (String, Int, Int)
pos Parser Polytype
parsePolytype String
s
  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) Polytype
parsed