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