module LambdaCube.SystemFw_.TH
  ( lc
  ) where

import           Data.Data                   (Data)
import           Data.Generics               (extQ)
import           Data.Text                   (Text)
import qualified Data.Text                   as Text
import           LambdaCube.SystemFw_.Ast
import           LambdaCube.SystemFw_.Parser
import           Language.Haskell.TH.Lib     (ExpQ, varE)
import           Language.Haskell.TH.Quote   (QuasiQuoter (..))
import           Language.Haskell.TH.Syntax  (Loc (loc_start), dataToExpQ, lift,
                                              location, mkName)
import qualified Text.Megaparsec             as P
import qualified Text.Megaparsec.Error       as PE

lc :: QuasiQuoter
lc :: QuasiQuoter
lc =
  QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter
    { quoteExp :: String -> Q Exp
quoteExp = String -> Q Exp
expLc
    , quotePat :: String -> Q Pat
quotePat = String -> Q Pat
forall a. HasCallStack => a
undefined
    , quoteType :: String -> Q Type
quoteType = String -> Q Type
forall a. HasCallStack => a
undefined
    , quoteDec :: String -> Q [Dec]
quoteDec = String -> Q [Dec]
forall a. HasCallStack => a
undefined
    }

expLc :: String -> ExpQ
expLc :: String -> Q Exp
expLc String
str = do
  Loc
l <- Q Loc
location
  case Parsec Void Text ExtLCTerm
-> String -> Text -> Either (ParseErrorBundle Text Void) ExtLCTerm
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
P.parse Parsec Void Text ExtLCTerm
pTopLC (String
"<quote at " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> CharPos -> String
forall a. Show a => a -> String
show (Loc -> CharPos
loc_start Loc
l) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
">") (String -> Text
Text.pack String
str) of
    Right ExtLCTerm
e  -> (forall b. Data b => b -> Maybe (Q Exp)) -> ExtLCTerm -> Q Exp
forall a.
Data a =>
(forall b. Data b => b -> Maybe (Q Exp)) -> a -> Q Exp
dataToExpQ forall b. Data b => b -> Maybe (Q Exp)
converter ExtLCTerm
e
    Left ParseErrorBundle Text Void
err -> String -> Q Exp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ ParseErrorBundle Text Void -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
PE.errorBundlePretty ParseErrorBundle Text Void
err
  where
    converter :: Data b => b -> Maybe ExpQ
    converter :: b -> Maybe (Q Exp)
converter =
      Maybe (Q Exp) -> b -> Maybe (Q Exp)
forall a b. a -> b -> a
const Maybe (Q Exp)
forall a. Maybe a
Nothing
      (b -> Maybe (Q Exp))
-> (ExtLCTerm -> Maybe (Q Exp)) -> b -> Maybe (Q Exp)
forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` ExtLCTerm -> Maybe (Q Exp)
quotedMVar
      (b -> Maybe (Q Exp))
-> (ExtLCType -> Maybe (Q Exp)) -> b -> Maybe (Q Exp)
forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` ExtLCType -> Maybe (Q Exp)
quotedMTVar
      (b -> Maybe (Q Exp))
-> (ExtLCKind -> Maybe (Q Exp)) -> b -> Maybe (Q Exp)
forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` ExtLCKind -> Maybe (Q Exp)
quotedMKVar
      (b -> Maybe (Q Exp))
-> (Text -> Maybe (Q Exp)) -> b -> Maybe (Q Exp)
forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` (Q Exp -> Maybe (Q Exp)
forall a. a -> Maybe a
Just (Q Exp -> Maybe (Q Exp))
-> (Text -> Q Exp) -> Text -> Maybe (Q Exp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Q Exp
forall t. Lift t => t -> Q Exp
lift :: Text -> Maybe ExpQ)

    quotedMVar :: ExtLCTerm -> Maybe (Q Exp)
quotedMVar (ExtLCMVar String
x) = Q Exp -> Maybe (Q Exp)
forall a. a -> Maybe a
Just (Q Exp -> Maybe (Q Exp))
-> (Name -> Q Exp) -> Name -> Maybe (Q Exp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Q Exp
varE (Name -> Maybe (Q Exp)) -> Name -> Maybe (Q Exp)
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
x
    quotedMVar ExtLCTerm
_             = Maybe (Q Exp)
forall a. Maybe a
Nothing

    quotedMTVar :: ExtLCType -> Maybe (Q Exp)
quotedMTVar (ExtLCMTVar String
x) = Q Exp -> Maybe (Q Exp)
forall a. a -> Maybe a
Just (Q Exp -> Maybe (Q Exp))
-> (Name -> Q Exp) -> Name -> Maybe (Q Exp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Q Exp
varE (Name -> Maybe (Q Exp)) -> Name -> Maybe (Q Exp)
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
x
    quotedMTVar ExtLCType
_              = Maybe (Q Exp)
forall a. Maybe a
Nothing

    quotedMKVar :: ExtLCKind -> Maybe (Q Exp)
quotedMKVar (ExtLCMKVar String
x) = Q Exp -> Maybe (Q Exp)
forall a. a -> Maybe a
Just (Q Exp -> Maybe (Q Exp))
-> (Name -> Q Exp) -> Name -> Maybe (Q Exp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Q Exp
varE (Name -> Maybe (Q Exp)) -> Name -> Maybe (Q Exp)
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
x
    quotedMKVar ExtLCKind
_              = Maybe (Q Exp)
forall a. Maybe a
Nothing