{-# LANGUAGE ViewPatterns #-}
{-|
Module: IHP.HSX.HsExpToTH
Copyright: (c) digitally induced GmbH, 2022
Description: Converts Haskell AST to Template Haskell AST

Based on https://github.com/guibou/PyF/blob/b3aaee12d34380e55aa3909690041eccb8fcf001/src/PyF/Internal/Meta.hs
-}
module IHP.HSX.HsExpToTH (toExp) where

import Prelude

import GHC.Hs.Expr as Expr
import GHC.Hs.Extension as Ext
import GHC.Hs.Pat as Pat
import GHC.Hs.Lit
import qualified Data.ByteString as B
import qualified Language.Haskell.TH.Syntax as TH
import GHC.Types.SrcLoc
import GHC.Types.Name
import GHC.Types.Name.Reader
import GHC.Data.FastString
import GHC.Utils.Outputable (Outputable, ppr, showSDocUnsafe)
import GHC.Types.Basic (Boxity(..))
import GHC.Types.SourceText (il_value, rationalFromFractionalLit)
import qualified GHC.Unit.Module as Module
import GHC.Stack
import qualified Data.List.NonEmpty as NonEmpty
import Language.Haskell.Syntax.Type

fl_value :: FractionalLit -> Rational
fl_value = FractionalLit -> Rational
rationalFromFractionalLit

toLit :: HsLit GhcPs -> TH.Lit
toLit :: HsLit GhcPs -> Lit
toLit (HsChar XHsChar GhcPs
_ Char
c) = Char -> Lit
TH.CharL Char
c
toLit (HsCharPrim XHsCharPrim GhcPs
_ Char
c) = Char -> Lit
TH.CharPrimL Char
c
toLit (HsString XHsString GhcPs
_ FastString
s) = String -> Lit
TH.StringL (FastString -> String
unpackFS FastString
s)
toLit (HsStringPrim XHsStringPrim GhcPs
_ ByteString
s) = [Word8] -> Lit
TH.StringPrimL (ByteString -> [Word8]
B.unpack ByteString
s)
toLit (HsInt XHsInt GhcPs
_ IntegralLit
i) = Integer -> Lit
TH.IntegerL (IntegralLit -> Integer
il_value IntegralLit
i)
toLit (HsIntPrim XHsIntPrim GhcPs
_ Integer
i) = Integer -> Lit
TH.IntPrimL Integer
i
toLit (HsWordPrim XHsWordPrim GhcPs
_ Integer
i) = Integer -> Lit
TH.WordPrimL Integer
i
toLit (HsInt64Prim XHsInt64Prim GhcPs
_ Integer
i) = Integer -> Lit
TH.IntegerL Integer
i
toLit (HsWord64Prim XHsWord64Prim GhcPs
_ Integer
i) = Integer -> Lit
TH.WordPrimL Integer
i
toLit (HsInteger XHsInteger GhcPs
_ Integer
i Type
_) = Integer -> Lit
TH.IntegerL Integer
i
toLit (HsRat XHsRat GhcPs
_ FractionalLit
f Type
_) = Rational -> Lit
TH.FloatPrimL (FractionalLit -> Rational
fl_value FractionalLit
f)
toLit (HsFloatPrim XHsFloatPrim GhcPs
_ FractionalLit
f) = Rational -> Lit
TH.FloatPrimL (FractionalLit -> Rational
fl_value FractionalLit
f)
toLit (HsDoublePrim XHsDoublePrim GhcPs
_ FractionalLit
f) = Rational -> Lit
TH.DoublePrimL (FractionalLit -> Rational
fl_value FractionalLit
f)

toLit' :: OverLitVal -> TH.Lit
toLit' :: OverLitVal -> Lit
toLit' (HsIntegral IntegralLit
i) = Integer -> Lit
TH.IntegerL (IntegralLit -> Integer
il_value IntegralLit
i)
toLit' (HsFractional FractionalLit
f) = Rational -> Lit
TH.RationalL (FractionalLit -> Rational
fl_value FractionalLit
f)
toLit' (HsIsString SourceText
_ FastString
fs) = String -> Lit
TH.StringL (FastString -> String
unpackFS FastString
fs)

toType :: HsType GhcPs -> TH.Type
toType :: HsType GhcPs -> Type
toType (HsWildCardTy XWildCardTy GhcPs
_) = Type
TH.WildCardT
toType (HsTyVar XTyVar GhcPs
_ PromotionFlag
_ LIdP GhcPs
n) =
  let n' :: RdrName
n' = forall l e. GenLocated l e -> e
unLoc LIdP GhcPs
n
   in if RdrName -> Bool
isRdrTyVar RdrName
n'
        then Name -> Type
TH.VarT (RdrName -> Name
toName RdrName
n')
        else Name -> Type
TH.ConT (RdrName -> Name
toName RdrName
n')
toType HsType GhcPs
t = forall e a. Outputable e => String -> e -> a
todo String
"toType" HsType GhcPs
t

toName :: RdrName -> TH.Name
toName :: RdrName -> Name
toName RdrName
n = case RdrName
n of
  (Unqual OccName
o) -> String -> Name
TH.mkName (OccName -> String
occNameString OccName
o)
  (Qual ModuleName
m OccName
o) -> String -> Name
TH.mkName (ModuleName -> String
Module.moduleNameString ModuleName
m forall a. Semigroup a => a -> a -> a
<> String
"." forall a. Semigroup a => a -> a -> a
<> OccName -> String
occNameString OccName
o)
  (Orig Module
_ OccName
_) -> forall a. HasCallStack => String -> a
error String
"orig"
  (Exact Name
_) -> forall a. HasCallStack => String -> a
error String
"exact"

toFieldExp :: a
toFieldExp :: forall a. a
toFieldExp = forall a. HasCallStack => a
undefined

toPat :: Pat.Pat GhcPs -> TH.Pat
toPat :: Pat GhcPs -> Pat
toPat (Pat.VarPat XVarPat GhcPs
_ (forall l e. GenLocated l e -> e
unLoc -> RdrName
name)) = Name -> Pat
TH.VarP (RdrName -> Name
toName RdrName
name)
toPat (TuplePat XTuplePat GhcPs
_ [LPat GhcPs]
p Boxity
_) = [Pat] -> Pat
TH.TupP (forall a b. (a -> b) -> [a] -> [b]
map (Pat GhcPs -> Pat
toPat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [LPat GhcPs]
p)
toPat Pat GhcPs
p = forall e a. Outputable e => String -> e -> a
todo String
"toPat" Pat GhcPs
p

toExp :: Expr.HsExpr GhcPs -> TH.Exp
toExp :: HsExpr GhcPs -> Exp
toExp (Expr.HsVar XVar GhcPs
_ LIdP GhcPs
n) =
  let n' :: RdrName
n' = forall l e. GenLocated l e -> e
unLoc LIdP GhcPs
n
   in if RdrName -> Bool
isRdrDataCon RdrName
n'
        then Name -> Exp
TH.ConE (RdrName -> Name
toName RdrName
n')
        else Name -> Exp
TH.VarE (RdrName -> Name
toName RdrName
n')

toExp (Expr.HsUnboundVar XUnboundVar GhcPs
_ OccName
n)              = Name -> Exp
TH.UnboundVarE (String -> Name
TH.mkName forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> String
occNameString forall a b. (a -> b) -> a -> b
$ OccName
n)

toExp Expr.HsIPVar {}
  = forall e a. (HasCallStack, Show e) => String -> e -> a
noTH String
"toExp" String
"HsIPVar"

toExp (Expr.HsLit XLitE GhcPs
_ HsLit GhcPs
l)
  = Lit -> Exp
TH.LitE (HsLit GhcPs -> Lit
toLit HsLit GhcPs
l)

toExp (Expr.HsOverLit XOverLitE GhcPs
_ OverLit {OverLitVal
ol_val :: forall p. HsOverLit p -> OverLitVal
ol_val :: OverLitVal
ol_val})
  = Lit -> Exp
TH.LitE (OverLitVal -> Lit
toLit' OverLitVal
ol_val)

toExp (Expr.HsApp XApp GhcPs
_ XRec GhcPs (HsExpr GhcPs)
e1 XRec GhcPs (HsExpr GhcPs)
e2)
  = Exp -> Exp -> Exp
TH.AppE (HsExpr GhcPs -> Exp
toExp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc forall a b. (a -> b) -> a -> b
$ XRec GhcPs (HsExpr GhcPs)
e1) (HsExpr GhcPs -> Exp
toExp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc forall a b. (a -> b) -> a -> b
$ XRec GhcPs (HsExpr GhcPs)
e2)

toExp (Expr.HsAppType XAppTypeE GhcPs
_ XRec GhcPs (HsExpr GhcPs)
e HsWC {LHsType (NoGhcTc GhcPs)
hswc_body :: forall pass thing. HsWildCardBndrs pass thing -> thing
hswc_body :: LHsType (NoGhcTc GhcPs)
hswc_body}) = Exp -> Type -> Exp
TH.AppTypeE (HsExpr GhcPs -> Exp
toExp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc forall a b. (a -> b) -> a -> b
$ XRec GhcPs (HsExpr GhcPs)
e) (HsType GhcPs -> Type
toType forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc forall a b. (a -> b) -> a -> b
$ LHsType (NoGhcTc GhcPs)
hswc_body)
toExp (Expr.ExprWithTySig XExprWithTySig GhcPs
_ XRec GhcPs (HsExpr GhcPs)
e HsWC{hswc_body :: forall pass thing. HsWildCardBndrs pass thing -> thing
hswc_body=forall l e. GenLocated l e -> e
unLoc -> HsSig{LHsType GhcPs
sig_body :: forall pass. HsSigType pass -> LHsType pass
sig_body :: LHsType GhcPs
sig_body}}) = Exp -> Type -> Exp
TH.SigE (HsExpr GhcPs -> Exp
toExp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc forall a b. (a -> b) -> a -> b
$ XRec GhcPs (HsExpr GhcPs)
e) (HsType GhcPs -> Type
toType forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc forall a b. (a -> b) -> a -> b
$ LHsType GhcPs
sig_body)

toExp (Expr.OpApp XOpApp GhcPs
_ XRec GhcPs (HsExpr GhcPs)
e1 XRec GhcPs (HsExpr GhcPs)
o XRec GhcPs (HsExpr GhcPs)
e2)
  = Exp -> Exp -> Exp -> Exp
TH.UInfixE (HsExpr GhcPs -> Exp
toExp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc forall a b. (a -> b) -> a -> b
$ XRec GhcPs (HsExpr GhcPs)
e1) (HsExpr GhcPs -> Exp
toExp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc forall a b. (a -> b) -> a -> b
$ XRec GhcPs (HsExpr GhcPs)
o) (HsExpr GhcPs -> Exp
toExp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc forall a b. (a -> b) -> a -> b
$ XRec GhcPs (HsExpr GhcPs)
e2)

toExp (Expr.NegApp XNegApp GhcPs
_ XRec GhcPs (HsExpr GhcPs)
e SyntaxExpr GhcPs
_)
  = Exp -> Exp -> Exp
TH.AppE (Name -> Exp
TH.VarE 'negate) (HsExpr GhcPs -> Exp
toExp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc forall a b. (a -> b) -> a -> b
$ XRec GhcPs (HsExpr GhcPs)
e)

-- NOTE: for lambda, there is only one match
toExp (Expr.HsLam XLam GhcPs
_ (Expr.MG XMG GhcPs (XRec GhcPs (HsExpr GhcPs))
_ (forall l e. GenLocated l e -> e
unLoc -> (forall a b. (a -> b) -> [a] -> [b]
map forall l e. GenLocated l e -> e
unLoc -> [Expr.Match XCMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
_ HsMatchContext (NoGhcTc GhcPs)
_ (forall a b. (a -> b) -> [a] -> [b]
map forall l e. GenLocated l e -> e
unLoc -> [Pat GhcPs]
ps) (Expr.GRHSs XCGRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
_ [forall l e. GenLocated l e -> e
unLoc -> Expr.GRHS XCGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
_ [GuardLStmt GhcPs]
_ (forall l e. GenLocated l e -> e
unLoc -> HsExpr GhcPs
e)] HsLocalBinds GhcPs
_)])) Origin
_))
  = [Pat] -> Exp -> Exp
TH.LamE (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Pat GhcPs -> Pat
toPat [Pat GhcPs]
ps) (HsExpr GhcPs -> Exp
toExp HsExpr GhcPs
e)

-- toExp (Expr.Let _ bs e)                       = TH.LetE (toDecs bs) (toExp e)
--
toExp (Expr.HsIf XIf GhcPs
_ XRec GhcPs (HsExpr GhcPs)
a XRec GhcPs (HsExpr GhcPs)
b XRec GhcPs (HsExpr GhcPs)
c)                   = Exp -> Exp -> Exp -> Exp
TH.CondE (HsExpr GhcPs -> Exp
toExp (forall l e. GenLocated l e -> e
unLoc XRec GhcPs (HsExpr GhcPs)
a)) (HsExpr GhcPs -> Exp
toExp (forall l e. GenLocated l e -> e
unLoc XRec GhcPs (HsExpr GhcPs)
b)) (HsExpr GhcPs -> Exp
toExp (forall l e. GenLocated l e -> e
unLoc XRec GhcPs (HsExpr GhcPs)
c))

-- toExp (Expr.MultiIf _ ifs)                    = TH.MultiIfE (map toGuard ifs)
-- toExp (Expr.Case _ e alts)                    = TH.CaseE (toExp e) (map toMatch alts)
-- toExp (Expr.Do _ ss)                          = TH.DoE (map toStmt ss)
-- toExp e@Expr.MDo{}                            = noTH "toExp" e
--
toExp (Expr.ExplicitTuple XExplicitTuple GhcPs
_ [HsTupArg GhcPs]
args Boxity
boxity) = [Maybe Exp] -> Exp
ctor [Maybe Exp]
tupArgs
  where
    toTupArg :: HsTupArg id -> Maybe (HsExpr id)
toTupArg (Expr.Present XPresent id
_ XRec id (HsExpr id)
e) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall l e. GenLocated l e -> e
unLoc XRec id (HsExpr id)
e
    toTupArg (Expr.Missing XMissing id
_) = forall a. Maybe a
Nothing
    toTupArg HsTupArg id
_ = forall a. HasCallStack => String -> a
error String
"impossible case"

    ctor :: [Maybe Exp] -> Exp
ctor = case Boxity
boxity of
      Boxity
Boxed -> [Maybe Exp] -> Exp
TH.TupE
      Boxity
Unboxed -> [Maybe Exp] -> Exp
TH.UnboxedTupE

    tupArgs :: [Maybe Exp]
tupArgs = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HsExpr GhcPs -> Exp
toExp) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {id} {l}.
(XRec id (HsExpr id) ~ GenLocated l (HsExpr id)) =>
HsTupArg id -> Maybe (HsExpr id)
toTupArg) [HsTupArg GhcPs]
args

-- toExp (Expr.List _ xs)                        = TH.ListE (fmap toExp xs)
toExp (Expr.HsPar XPar GhcPs
_ XRec GhcPs (HsExpr GhcPs)
e)
  = Exp -> Exp
TH.ParensE (HsExpr GhcPs -> Exp
toExp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc forall a b. (a -> b) -> a -> b
$ XRec GhcPs (HsExpr GhcPs)
e)

toExp (Expr.SectionL XSectionL GhcPs
_ (forall l e. GenLocated l e -> e
unLoc -> HsExpr GhcPs
a) (forall l e. GenLocated l e -> e
unLoc -> HsExpr GhcPs
b))
  = Maybe Exp -> Exp -> Maybe Exp -> Exp
TH.InfixE (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsExpr GhcPs -> Exp
toExp forall a b. (a -> b) -> a -> b
$ HsExpr GhcPs
a) (HsExpr GhcPs -> Exp
toExp HsExpr GhcPs
b) forall a. Maybe a
Nothing

toExp (Expr.SectionR XSectionR GhcPs
_ (forall l e. GenLocated l e -> e
unLoc -> HsExpr GhcPs
a) (forall l e. GenLocated l e -> e
unLoc -> HsExpr GhcPs
b))
  = Maybe Exp -> Exp -> Maybe Exp -> Exp
TH.InfixE forall a. Maybe a
Nothing (HsExpr GhcPs -> Exp
toExp HsExpr GhcPs
a) (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsExpr GhcPs -> Exp
toExp forall a b. (a -> b) -> a -> b
$ HsExpr GhcPs
b)

toExp (Expr.RecordCon XRecordCon GhcPs
_ XRec GhcPs (ConLikeP GhcPs)
name HsRecFields {[LHsRecField GhcPs (XRec GhcPs (HsExpr GhcPs))]
rec_flds :: forall p arg. HsRecFields p arg -> [LHsRecField p arg]
rec_flds :: [LHsRecField GhcPs (XRec GhcPs (HsExpr GhcPs))]
rec_flds})
  = Name -> [FieldExp] -> Exp
TH.RecConE (RdrName -> Name
toName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc forall a b. (a -> b) -> a -> b
$ XRec GhcPs (ConLikeP GhcPs)
name) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a
toFieldExp [LHsRecField GhcPs (XRec GhcPs (HsExpr GhcPs))]
rec_flds)

toExp (Expr.RecordUpd XRecordUpd GhcPs
_ (forall l e. GenLocated l e -> e
unLoc -> HsExpr GhcPs
e) Either [LHsRecUpdField GhcPs] [LHsRecUpdProj GhcPs]
xs)                 = Exp -> [FieldExp] -> Exp
TH.RecUpdE (HsExpr GhcPs -> Exp
toExp HsExpr GhcPs
e) forall a b. (a -> b) -> a -> b
$ case Either [LHsRecUpdField GhcPs] [LHsRecUpdProj GhcPs]
xs of
    Left [LHsRecUpdField GhcPs]
fields ->
        let
            f :: GenLocated
  l
  (HsRecField'
     (AmbiguousFieldOcc pass) (GenLocated l (HsExpr GhcPs)))
-> FieldExp
f (forall l e. GenLocated l e -> e
unLoc -> HsRecField' (AmbiguousFieldOcc pass) (GenLocated l (HsExpr GhcPs))
x) = (Name
name, Exp
value)
                where
                    value :: Exp
value = HsExpr GhcPs -> Exp
toExp forall a b. (a -> b) -> a -> b
$ forall l e. GenLocated l e -> e
unLoc forall a b. (a -> b) -> a -> b
$ forall id arg. HsRecField' id arg -> arg
hsRecFieldArg HsRecField' (AmbiguousFieldOcc pass) (GenLocated l (HsExpr GhcPs))
x
                    name :: Name
name =
                        case forall l e. GenLocated l e -> e
unLoc (forall id arg. HsRecField' id arg -> Located id
hsRecFieldLbl HsRecField' (AmbiguousFieldOcc pass) (GenLocated l (HsExpr GhcPs))
x) of
                            Unambiguous XUnambiguous pass
_ (forall l e. GenLocated l e -> e
unLoc -> RdrName
name) -> RdrName -> Name
toName RdrName
name
                            Ambiguous XAmbiguous pass
_ (forall l e. GenLocated l e -> e
unLoc -> RdrName
name) -> RdrName -> Name
toName RdrName
name
        in
            forall a b. (a -> b) -> [a] -> [b]
map forall {l} {pass} {l}.
GenLocated
  l
  (HsRecField'
     (AmbiguousFieldOcc pass) (GenLocated l (HsExpr GhcPs)))
-> FieldExp
f [LHsRecUpdField GhcPs]
fields
    Right [LHsRecUpdProj GhcPs]
xs -> forall a. HasCallStack => String -> a
error String
"todo"
-- toExp (Expr.ListComp _ e ss)                  = TH.CompE $ map convert ss ++ [TH.NoBindS (toExp e)]
--  where
--   convert (Expr.QualStmt _ st)                = toStmt st
--   convert s                                   = noTH "toExp ListComp" s
-- toExp (Expr.ExpTypeSig _ e t)                 = TH.SigE (toExp e) (toType t)
--
toExp (Expr.ExplicitList XExplicitList GhcPs
_ (forall a b. (a -> b) -> [a] -> [b]
map forall l e. GenLocated l e -> e
unLoc -> [HsExpr GhcPs]
args)) = [Exp] -> Exp
TH.ListE (forall a b. (a -> b) -> [a] -> [b]
map HsExpr GhcPs -> Exp
toExp [HsExpr GhcPs]
args)

toExp (Expr.ArithSeq XArithSeq GhcPs
_ Maybe (SyntaxExpr GhcPs)
_ ArithSeqInfo GhcPs
e)
  = Range -> Exp
TH.ArithSeqE forall a b. (a -> b) -> a -> b
$ case ArithSeqInfo GhcPs
e of
    (From XRec GhcPs (HsExpr GhcPs)
a) -> Exp -> Range
TH.FromR (HsExpr GhcPs -> Exp
toExp forall a b. (a -> b) -> a -> b
$ forall l e. GenLocated l e -> e
unLoc XRec GhcPs (HsExpr GhcPs)
a)
    (FromThen XRec GhcPs (HsExpr GhcPs)
a XRec GhcPs (HsExpr GhcPs)
b) -> Exp -> Exp -> Range
TH.FromThenR (HsExpr GhcPs -> Exp
toExp forall a b. (a -> b) -> a -> b
$ forall l e. GenLocated l e -> e
unLoc XRec GhcPs (HsExpr GhcPs)
a) (HsExpr GhcPs -> Exp
toExp forall a b. (a -> b) -> a -> b
$ forall l e. GenLocated l e -> e
unLoc XRec GhcPs (HsExpr GhcPs)
b)
    (FromTo XRec GhcPs (HsExpr GhcPs)
a XRec GhcPs (HsExpr GhcPs)
b) -> Exp -> Exp -> Range
TH.FromToR (HsExpr GhcPs -> Exp
toExp forall a b. (a -> b) -> a -> b
$ forall l e. GenLocated l e -> e
unLoc XRec GhcPs (HsExpr GhcPs)
a) (HsExpr GhcPs -> Exp
toExp forall a b. (a -> b) -> a -> b
$ forall l e. GenLocated l e -> e
unLoc XRec GhcPs (HsExpr GhcPs)
b)
    (FromThenTo XRec GhcPs (HsExpr GhcPs)
a XRec GhcPs (HsExpr GhcPs)
b XRec GhcPs (HsExpr GhcPs)
c) -> Exp -> Exp -> Exp -> Range
TH.FromThenToR (HsExpr GhcPs -> Exp
toExp forall a b. (a -> b) -> a -> b
$ forall l e. GenLocated l e -> e
unLoc XRec GhcPs (HsExpr GhcPs)
a) (HsExpr GhcPs -> Exp
toExp forall a b. (a -> b) -> a -> b
$ forall l e. GenLocated l e -> e
unLoc XRec GhcPs (HsExpr GhcPs)
b) (HsExpr GhcPs -> Exp
toExp forall a b. (a -> b) -> a -> b
$ forall l e. GenLocated l e -> e
unLoc XRec GhcPs (HsExpr GhcPs)
c)


toExp (Expr.HsProjection XProjection GhcPs
_ NonEmpty (Located (HsFieldLabel GhcPs))
locatedFields) =
  let
    extractFieldLabel :: HsFieldLabel p -> Located FastString
extractFieldLabel (HsFieldLabel XCHsFieldLabel p
_ Located FastString
locatedStr) = Located FastString
locatedStr
    extractFieldLabel HsFieldLabel p
_ = forall a. HasCallStack => String -> a
error String
"Don't know how to handle XHsFieldLabel constructor..."
  in
    NonEmpty String -> Exp
TH.ProjectionE (forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NonEmpty.map (FastString -> String
unpackFS forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {p}. HsFieldLabel p -> Located FastString
extractFieldLabel forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) NonEmpty (Located (HsFieldLabel GhcPs))
locatedFields)

toExp (Expr.HsGetField XGetField GhcPs
_ XRec GhcPs (HsExpr GhcPs)
expr Located (HsFieldLabel GhcPs)
locatedField) =
  let
    extractFieldLabel :: HsFieldLabel p -> Located FastString
extractFieldLabel (HsFieldLabel XCHsFieldLabel p
_ Located FastString
locatedStr) = Located FastString
locatedStr
    extractFieldLabel HsFieldLabel p
_ = forall a. HasCallStack => String -> a
error String
"Don't know how to handle XHsFieldLabel constructor..."
  in
    Exp -> String -> Exp
TH.GetFieldE (HsExpr GhcPs -> Exp
toExp (forall l e. GenLocated l e -> e
unLoc XRec GhcPs (HsExpr GhcPs)
expr)) (FastString -> String
unpackFS forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {p}. HsFieldLabel p -> Located FastString
extractFieldLabel forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc forall a b. (a -> b) -> a -> b
$ Located (HsFieldLabel GhcPs)
locatedField)


toExp (Expr.HsOverLabel XOverLabel GhcPs
_ FastString
fastString) = String -> Exp
TH.LabelE (FastString -> String
unpackFS FastString
fastString)

toExp HsExpr GhcPs
e = forall e a. Outputable e => String -> e -> a
todo String
"toExp" HsExpr GhcPs
e


todo :: Outputable e => String -> e -> a
todo :: forall e a. Outputable e => String -> e -> a
todo String
fun e
thing = forall a. HasCallStack => String -> a
error forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ [String
moduleName, String
".", String
fun, String
": not implemented: ", (SDoc -> String
showSDocUnsafe forall a b. (a -> b) -> a -> b
$ forall a. Outputable a => a -> SDoc
ppr e
thing)]

noTH :: (HasCallStack, Show e) => String -> e -> a
noTH :: forall e a. (HasCallStack, Show e) => String -> e -> a
noTH String
fun e
thing = forall a. HasCallStack => String -> a
error forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ [String
moduleName, String
".", String
fun, String
": no TemplateHaskell for: ", forall a. Show a => a -> String
show e
thing]

moduleName :: String
moduleName :: String
moduleName = String
"IHP.HSX.HsExpToTH"