{-# LANGUAGE ViewPatterns, CPP #-}
{-|
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 GHC.Hs.Utils as Utils
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
#if __GLASGOW_HASKELL__ >= 906
import Language.Haskell.Syntax.Basic
#endif


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' = GenLocated SrcSpanAnnN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc LIdP GhcPs
GenLocated SrcSpanAnnN RdrName
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 = String -> HsType GhcPs -> Type
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 String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"." String -> String -> String
forall a. Semigroup a => a -> a -> a
<> OccName -> String
occNameString OccName
o)
  (Exact Name
name) -> String -> Name
TH.mkName ((OccName -> String
occNameString (OccName -> String) -> (Name -> OccName) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RdrName -> OccName
rdrNameOcc (RdrName -> OccName) -> (Name -> RdrName) -> Name -> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName) Name
name) --error "exact"
  (Orig Module
_ OccName
_) -> String -> Name
forall a. HasCallStack => String -> a
error String
"orig"

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

toPat :: Pat.Pat GhcPs -> TH.Pat
toPat :: Pat GhcPs -> Pat
toPat (Pat.VarPat XVarPat GhcPs
_ (LIdP GhcPs -> RdrName
GenLocated SrcSpanAnnN RdrName -> RdrName
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 ((GenLocated SrcSpanAnnA (Pat GhcPs) -> Pat)
-> [GenLocated SrcSpanAnnA (Pat GhcPs)] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map (Pat GhcPs -> Pat
toPat (Pat GhcPs -> Pat)
-> (GenLocated SrcSpanAnnA (Pat GhcPs) -> Pat GhcPs)
-> GenLocated SrcSpanAnnA (Pat GhcPs)
-> Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (Pat GhcPs) -> Pat GhcPs
forall l e. GenLocated l e -> e
unLoc) [LPat GhcPs]
[GenLocated SrcSpanAnnA (Pat GhcPs)]
p)
toPat (ParPat XParPat GhcPs
xP LHsToken "(" GhcPs
_ LPat GhcPs
lP LHsToken ")" GhcPs
_) = (Pat GhcPs -> Pat
toPat (Pat GhcPs -> Pat)
-> (GenLocated SrcSpanAnnA (Pat GhcPs) -> Pat GhcPs)
-> GenLocated SrcSpanAnnA (Pat GhcPs)
-> Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (Pat GhcPs) -> Pat GhcPs
forall l e. GenLocated l e -> e
unLoc) LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
lP
toPat (ConPat XConPat GhcPs
pat_con_ext ((XRec GhcPs (ConLikeP GhcPs) -> RdrName
GenLocated SrcSpanAnnN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc -> RdrName
name)) HsConPatDetails GhcPs
pat_args) = Name -> [Type] -> [Pat] -> Pat
TH.ConP (RdrName -> Name
toName RdrName
name) ((HsType GhcPs -> Type) -> [HsType GhcPs] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map HsType GhcPs -> Type
toType []) ((GenLocated SrcSpanAnnA (Pat GhcPs) -> Pat)
-> [GenLocated SrcSpanAnnA (Pat GhcPs)] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map (Pat GhcPs -> Pat
toPat (Pat GhcPs -> Pat)
-> (GenLocated SrcSpanAnnA (Pat GhcPs) -> Pat GhcPs)
-> GenLocated SrcSpanAnnA (Pat GhcPs)
-> Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (Pat GhcPs) -> Pat GhcPs
forall l e. GenLocated l e -> e
unLoc) (HsConPatDetails GhcPs -> [LPat GhcPs]
forall p. UnXRec p => HsConPatDetails p -> [LPat p]
Pat.hsConPatArgs HsConPatDetails GhcPs
pat_args))
toPat (ViewPat XViewPat GhcPs
pat_con XRec GhcPs (HsExpr GhcPs)
pat_args LPat GhcPs
pat_con_ext) = String -> Pat
forall a. HasCallStack => String -> a
error String
"TH.ViewPattern not implemented"
toPat (SumPat XSumPat GhcPs
_ LPat GhcPs
_ ConTag
_ ConTag
_) = String -> Pat
forall a. HasCallStack => String -> a
error String
"TH.SumPat not implemented"
toPat (WildPat XWildPat GhcPs
_ ) = String -> Pat
forall a. HasCallStack => String -> a
error String
"TH.WildPat not implemented"
toPat (NPat XNPat GhcPs
_ XRec GhcPs (HsOverLit GhcPs)
_ Maybe (SyntaxExpr GhcPs)
_ SyntaxExpr GhcPs
_ ) = String -> Pat
forall a. HasCallStack => String -> a
error String
"TH.NPat not implemented"
toPat Pat GhcPs
p = String -> Pat GhcPs -> Pat
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' = GenLocated SrcSpanAnnN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc LIdP GhcPs
GenLocated SrcSpanAnnN RdrName
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')

#if __GLASGOW_HASKELL__ >= 906
toExp (Expr.HsUnboundVar XUnboundVar GhcPs
_ RdrName
n)              = Name -> Exp
TH.UnboundVarE (String -> Name
TH.mkName (String -> Name) -> (OccName -> String) -> OccName -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> String
occNameString (OccName -> Name) -> OccName -> Name
forall a b. (a -> b) -> a -> b
$ RdrName -> OccName
forall name. HasOccName name => name -> OccName
occName RdrName
n)
#else
toExp (Expr.HsUnboundVar _ n)              = TH.UnboundVarE (TH.mkName . occNameString $ n)
#endif

toExp Expr.HsIPVar {}
  = String -> String -> Exp
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 :: OverLitVal
ol_val :: forall p. HsOverLit p -> 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 (HsExpr GhcPs -> Exp)
-> (XRec GhcPs (HsExpr GhcPs) -> HsExpr GhcPs)
-> XRec GhcPs (HsExpr GhcPs)
-> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XRec GhcPs (HsExpr GhcPs) -> HsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs) -> HsExpr GhcPs
forall l e. GenLocated l e -> e
unLoc (XRec GhcPs (HsExpr GhcPs) -> Exp)
-> XRec GhcPs (HsExpr GhcPs) -> Exp
forall a b. (a -> b) -> a -> b
$ XRec GhcPs (HsExpr GhcPs)
e1) (HsExpr GhcPs -> Exp
toExp (HsExpr GhcPs -> Exp)
-> (XRec GhcPs (HsExpr GhcPs) -> HsExpr GhcPs)
-> XRec GhcPs (HsExpr GhcPs)
-> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XRec GhcPs (HsExpr GhcPs) -> HsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs) -> HsExpr GhcPs
forall l e. GenLocated l e -> e
unLoc (XRec GhcPs (HsExpr GhcPs) -> Exp)
-> XRec GhcPs (HsExpr GhcPs) -> Exp
forall a b. (a -> b) -> a -> b
$ XRec GhcPs (HsExpr GhcPs)
e2)

#if __GLASGOW_HASKELL__ >= 906
toExp (Expr.HsAppType XAppTypeE GhcPs
_ XRec GhcPs (HsExpr GhcPs)
e LHsToken "@" GhcPs
_ HsWC {LHsType (NoGhcTc GhcPs)
hswc_body :: LHsType (NoGhcTc GhcPs)
hswc_body :: forall pass thing. HsWildCardBndrs pass thing -> thing
hswc_body}) = Exp -> Type -> Exp
TH.AppTypeE (HsExpr GhcPs -> Exp
toExp (HsExpr GhcPs -> Exp)
-> (XRec GhcPs (HsExpr GhcPs) -> HsExpr GhcPs)
-> XRec GhcPs (HsExpr GhcPs)
-> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XRec GhcPs (HsExpr GhcPs) -> HsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs) -> HsExpr GhcPs
forall l e. GenLocated l e -> e
unLoc (XRec GhcPs (HsExpr GhcPs) -> Exp)
-> XRec GhcPs (HsExpr GhcPs) -> Exp
forall a b. (a -> b) -> a -> b
$ XRec GhcPs (HsExpr GhcPs)
e) (HsType GhcPs -> Type
toType (HsType GhcPs -> Type)
-> (LHsType (NoGhcTc GhcPs) -> HsType GhcPs)
-> LHsType (NoGhcTc GhcPs)
-> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsType (NoGhcTc GhcPs) -> HsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs) -> HsType GhcPs
forall l e. GenLocated l e -> e
unLoc (LHsType (NoGhcTc GhcPs) -> Type)
-> LHsType (NoGhcTc GhcPs) -> Type
forall a b. (a -> b) -> a -> b
$ LHsType (NoGhcTc GhcPs)
hswc_body)
#else
toExp (Expr.HsAppType _ e HsWC {hswc_body}) = TH.AppTypeE (toExp . unLoc $ e) (toType . unLoc $ hswc_body)
#endif
toExp (Expr.ExprWithTySig XExprWithTySig GhcPs
_ XRec GhcPs (HsExpr GhcPs)
e HsWC{hswc_body :: forall pass thing. HsWildCardBndrs pass thing -> thing
hswc_body=LHsSigType (NoGhcTc GhcPs) -> HsSigType GhcPs
GenLocated SrcSpanAnnA (HsSigType GhcPs) -> HsSigType GhcPs
forall l e. GenLocated l e -> e
unLoc -> HsSig{LHsType GhcPs
sig_body :: LHsType GhcPs
sig_body :: forall pass. HsSigType pass -> LHsType pass
sig_body}}) = Exp -> Type -> Exp
TH.SigE (HsExpr GhcPs -> Exp
toExp (HsExpr GhcPs -> Exp)
-> (XRec GhcPs (HsExpr GhcPs) -> HsExpr GhcPs)
-> XRec GhcPs (HsExpr GhcPs)
-> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XRec GhcPs (HsExpr GhcPs) -> HsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs) -> HsExpr GhcPs
forall l e. GenLocated l e -> e
unLoc (XRec GhcPs (HsExpr GhcPs) -> Exp)
-> XRec GhcPs (HsExpr GhcPs) -> Exp
forall a b. (a -> b) -> a -> b
$ XRec GhcPs (HsExpr GhcPs)
e) (HsType GhcPs -> Type
toType (HsType GhcPs -> Type)
-> (LHsType GhcPs -> HsType GhcPs) -> LHsType GhcPs -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsType GhcPs -> HsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs) -> HsType GhcPs
forall l e. GenLocated l e -> e
unLoc (LHsType GhcPs -> Type) -> LHsType GhcPs -> Type
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 (HsExpr GhcPs -> Exp)
-> (XRec GhcPs (HsExpr GhcPs) -> HsExpr GhcPs)
-> XRec GhcPs (HsExpr GhcPs)
-> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XRec GhcPs (HsExpr GhcPs) -> HsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs) -> HsExpr GhcPs
forall l e. GenLocated l e -> e
unLoc (XRec GhcPs (HsExpr GhcPs) -> Exp)
-> XRec GhcPs (HsExpr GhcPs) -> Exp
forall a b. (a -> b) -> a -> b
$ XRec GhcPs (HsExpr GhcPs)
e1) (HsExpr GhcPs -> Exp
toExp (HsExpr GhcPs -> Exp)
-> (XRec GhcPs (HsExpr GhcPs) -> HsExpr GhcPs)
-> XRec GhcPs (HsExpr GhcPs)
-> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XRec GhcPs (HsExpr GhcPs) -> HsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs) -> HsExpr GhcPs
forall l e. GenLocated l e -> e
unLoc (XRec GhcPs (HsExpr GhcPs) -> Exp)
-> XRec GhcPs (HsExpr GhcPs) -> Exp
forall a b. (a -> b) -> a -> b
$ XRec GhcPs (HsExpr GhcPs)
o) (HsExpr GhcPs -> Exp
toExp (HsExpr GhcPs -> Exp)
-> (XRec GhcPs (HsExpr GhcPs) -> HsExpr GhcPs)
-> XRec GhcPs (HsExpr GhcPs)
-> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XRec GhcPs (HsExpr GhcPs) -> HsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs) -> HsExpr GhcPs
forall l e. GenLocated l e -> e
unLoc (XRec GhcPs (HsExpr GhcPs) -> Exp)
-> XRec GhcPs (HsExpr GhcPs) -> Exp
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 (HsExpr GhcPs -> Exp)
-> (XRec GhcPs (HsExpr GhcPs) -> HsExpr GhcPs)
-> XRec GhcPs (HsExpr GhcPs)
-> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XRec GhcPs (HsExpr GhcPs) -> HsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs) -> HsExpr GhcPs
forall l e. GenLocated l e -> e
unLoc (XRec GhcPs (HsExpr GhcPs) -> Exp)
-> XRec GhcPs (HsExpr GhcPs) -> Exp
forall a b. (a -> b) -> a -> b
$ XRec GhcPs (HsExpr GhcPs)
e)

-- NOTE: for lambda, there is only one match
#if __GLASGOW_HASKELL__ >= 906
toExp (Expr.HsLam XLam GhcPs
_ (Expr.MG XMG GhcPs (XRec GhcPs (HsExpr GhcPs))
_ (XRec GhcPs [LMatch GhcPs (XRec GhcPs (HsExpr GhcPs))]
-> [GenLocated
      SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
GenLocated
  SrcSpanAnnL
  [GenLocated
     SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> [GenLocated
      SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall l e. GenLocated l e -> e
unLoc -> ((GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
 -> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> [GenLocated
      SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> [Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated
  SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall l e. GenLocated l e -> e
unLoc -> [Expr.Match XCMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
_ HsMatchContext GhcPs
_ ((GenLocated SrcSpanAnnA (Pat GhcPs) -> Pat GhcPs)
-> [GenLocated SrcSpanAnnA (Pat GhcPs)] -> [Pat GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnA (Pat GhcPs) -> Pat GhcPs
forall l e. GenLocated l e -> e
unLoc -> [Pat GhcPs]
ps) (Expr.GRHSs XCGRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
_ [LGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
GenLocated
  (SrcAnn NoEpAnns)
  (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall l e. GenLocated l e -> e
unLoc -> Expr.GRHS XCGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
_ [GuardLStmt GhcPs]
_ (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> HsExpr GhcPs
forall l e. GenLocated l e -> e
unLoc -> HsExpr GhcPs
e)] HsLocalBinds GhcPs
_)]))))
#else
toExp (Expr.HsLam _ (Expr.MG _ (unLoc -> (map unLoc -> [Expr.Match _ _ (map unLoc -> ps) (Expr.GRHSs _ [unLoc -> Expr.GRHS _ _ (unLoc -> e)] _)])) _))
#endif
  = [Pat] -> Exp -> Exp
TH.LamE ((Pat GhcPs -> Pat) -> [Pat GhcPs] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
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 (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> HsExpr GhcPs
forall l e. GenLocated l e -> e
unLoc XRec GhcPs (HsExpr GhcPs)
GenLocated SrcSpanAnnA (HsExpr GhcPs)
a)) (HsExpr GhcPs -> Exp
toExp (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> HsExpr GhcPs
forall l e. GenLocated l e -> e
unLoc XRec GhcPs (HsExpr GhcPs)
GenLocated SrcSpanAnnA (HsExpr GhcPs)
b)) (HsExpr GhcPs -> Exp
toExp (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> HsExpr GhcPs
forall l e. GenLocated l e -> e
unLoc XRec GhcPs (HsExpr GhcPs)
GenLocated SrcSpanAnnA (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) = HsExpr id -> Maybe (HsExpr id)
forall a. a -> Maybe a
Just (HsExpr id -> Maybe (HsExpr id)) -> HsExpr id -> Maybe (HsExpr id)
forall a b. (a -> b) -> a -> b
$ GenLocated l (HsExpr id) -> HsExpr id
forall l e. GenLocated l e -> e
unLoc XRec id (HsExpr id)
GenLocated l (HsExpr id)
e
    toTupArg (Expr.Missing XMissing id
_) = Maybe (HsExpr id)
forall a. Maybe a
Nothing
    toTupArg HsTupArg id
_ = String -> Maybe (HsExpr 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 = (HsTupArg GhcPs -> Maybe Exp) -> [HsTupArg GhcPs] -> [Maybe Exp]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((HsExpr GhcPs -> Exp) -> Maybe (HsExpr GhcPs) -> Maybe Exp
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HsExpr GhcPs -> Exp
toExp) (Maybe (HsExpr GhcPs) -> Maybe Exp)
-> (HsTupArg GhcPs -> Maybe (HsExpr GhcPs))
-> HsTupArg GhcPs
-> Maybe Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsTupArg GhcPs -> Maybe (HsExpr GhcPs)
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
_ LHsToken "(" GhcPs
_ XRec GhcPs (HsExpr GhcPs)
e LHsToken ")" GhcPs
_)
  = Exp -> Exp
TH.ParensE (HsExpr GhcPs -> Exp
toExp (HsExpr GhcPs -> Exp)
-> (XRec GhcPs (HsExpr GhcPs) -> HsExpr GhcPs)
-> XRec GhcPs (HsExpr GhcPs)
-> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XRec GhcPs (HsExpr GhcPs) -> HsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs) -> HsExpr GhcPs
forall l e. GenLocated l e -> e
unLoc (XRec GhcPs (HsExpr GhcPs) -> Exp)
-> XRec GhcPs (HsExpr GhcPs) -> Exp
forall a b. (a -> b) -> a -> b
$ XRec GhcPs (HsExpr GhcPs)
e)

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

toExp (Expr.SectionR XSectionR GhcPs
_ (XRec GhcPs (HsExpr GhcPs) -> HsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs) -> HsExpr GhcPs
forall l e. GenLocated l e -> e
unLoc -> HsExpr GhcPs
a) (XRec GhcPs (HsExpr GhcPs) -> HsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs) -> HsExpr GhcPs
forall l e. GenLocated l e -> e
unLoc -> HsExpr GhcPs
b))
  = Maybe Exp -> Exp -> Maybe Exp -> Exp
TH.InfixE Maybe Exp
forall a. Maybe a
Nothing (HsExpr GhcPs -> Exp
toExp HsExpr GhcPs
a) (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp)
-> (HsExpr GhcPs -> Exp) -> HsExpr GhcPs -> Maybe Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsExpr GhcPs -> Exp
toExp (HsExpr GhcPs -> Maybe Exp) -> HsExpr GhcPs -> Maybe Exp
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 :: [LHsRecField GhcPs (XRec GhcPs (HsExpr GhcPs))]
rec_flds :: forall p arg. HsRecFields p arg -> [LHsRecField p arg]
rec_flds})
  = Name -> [FieldExp] -> Exp
TH.RecConE (RdrName -> Name
toName (RdrName -> Name)
-> (XRec GhcPs (ConLikeP GhcPs) -> RdrName)
-> XRec GhcPs (ConLikeP GhcPs)
-> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XRec GhcPs (ConLikeP GhcPs) -> RdrName
GenLocated SrcSpanAnnN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc (XRec GhcPs (ConLikeP GhcPs) -> Name)
-> XRec GhcPs (ConLikeP GhcPs) -> Name
forall a b. (a -> b) -> a -> b
$ XRec GhcPs (ConLikeP GhcPs)
name) ((GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs))
      (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
 -> FieldExp)
-> [GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs))
         (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> [FieldExp]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenLocated
  SrcSpanAnnA
  (HsFieldBind
     (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs))
     (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> FieldExp
forall a. a
toFieldExp [LHsRecField GhcPs (XRec GhcPs (HsExpr GhcPs))]
[GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs))
      (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
rec_flds)

toExp (Expr.RecordUpd XRecordUpd GhcPs
_ (XRec GhcPs (HsExpr GhcPs) -> HsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs) -> HsExpr 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) ([FieldExp] -> Exp) -> [FieldExp] -> Exp
forall a b. (a -> b) -> a -> b
$ case Either [LHsRecUpdField GhcPs] [LHsRecUpdProj GhcPs]
xs of
#if __GLASGOW_HASKELL__ >= 908
    RegularRecUpdFields { recUpdFields = fields } ->
#else
    Left [LHsRecUpdField GhcPs]
fields ->
#endif
        let
            f :: GenLocated
  l
  (HsFieldBind
     (GenLocated l (AmbiguousFieldOcc pass))
     (GenLocated l (HsExpr GhcPs)))
-> FieldExp
f (GenLocated
  l
  (HsFieldBind
     (GenLocated l (AmbiguousFieldOcc pass))
     (GenLocated l (HsExpr GhcPs)))
-> HsFieldBind
     (GenLocated l (AmbiguousFieldOcc pass))
     (GenLocated l (HsExpr GhcPs))
forall l e. GenLocated l e -> e
unLoc -> HsFieldBind
  (GenLocated l (AmbiguousFieldOcc pass))
  (GenLocated l (HsExpr GhcPs))
x) = (Name
name, Exp
value)
                where
                    value :: Exp
value = HsExpr GhcPs -> Exp
toExp (HsExpr GhcPs -> Exp) -> HsExpr GhcPs -> Exp
forall a b. (a -> b) -> a -> b
$ GenLocated l (HsExpr GhcPs) -> HsExpr GhcPs
forall l e. GenLocated l e -> e
unLoc (GenLocated l (HsExpr GhcPs) -> HsExpr GhcPs)
-> GenLocated l (HsExpr GhcPs) -> HsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ HsFieldBind
  (GenLocated l (AmbiguousFieldOcc pass))
  (GenLocated l (HsExpr GhcPs))
-> GenLocated l (HsExpr GhcPs)
forall lhs rhs. HsFieldBind lhs rhs -> rhs
hfbRHS HsFieldBind
  (GenLocated l (AmbiguousFieldOcc pass))
  (GenLocated l (HsExpr GhcPs))
x
                    name :: Name
name =
                        case GenLocated l (AmbiguousFieldOcc pass) -> AmbiguousFieldOcc pass
forall l e. GenLocated l e -> e
unLoc (HsFieldBind
  (GenLocated l (AmbiguousFieldOcc pass))
  (GenLocated l (HsExpr GhcPs))
-> GenLocated l (AmbiguousFieldOcc pass)
forall lhs rhs. HsFieldBind lhs rhs -> lhs
hfbLHS HsFieldBind
  (GenLocated l (AmbiguousFieldOcc pass))
  (GenLocated l (HsExpr GhcPs))
x) of
                            Unambiguous XUnambiguous pass
_ (XRec pass RdrName -> RdrName
GenLocated l RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc -> RdrName
name) -> RdrName -> Name
toName RdrName
name
                            Ambiguous XAmbiguous pass
_ (XRec pass RdrName -> RdrName
GenLocated l RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc -> RdrName
name) -> RdrName -> Name
toName RdrName
name
        in
            (GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcPs))
      (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
 -> FieldExp)
-> [GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcPs))
         (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> [FieldExp]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated
  SrcSpanAnnA
  (HsFieldBind
     (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcPs))
     (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> FieldExp
forall {pass} {l} {l} {l} {l}.
(XRec pass RdrName ~ GenLocated l RdrName) =>
GenLocated
  l
  (HsFieldBind
     (GenLocated l (AmbiguousFieldOcc pass))
     (GenLocated l (HsExpr GhcPs)))
-> FieldExp
f [LHsRecUpdField GhcPs]
[GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcPs))
      (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
fields
    Either [LHsRecUpdField GhcPs] [LHsRecUpdProj GhcPs]
otherwise -> String -> [FieldExp]
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
_ ((GenLocated SrcSpanAnnA (HsExpr GhcPs) -> HsExpr GhcPs)
-> [GenLocated SrcSpanAnnA (HsExpr GhcPs)] -> [HsExpr GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnA (HsExpr GhcPs) -> HsExpr GhcPs
forall l e. GenLocated l e -> e
unLoc -> [HsExpr GhcPs]
args)) = [Exp] -> Exp
TH.ListE ((HsExpr GhcPs -> Exp) -> [HsExpr GhcPs] -> [Exp]
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 (Range -> Exp) -> Range -> Exp
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 (HsExpr GhcPs -> Exp) -> HsExpr GhcPs -> Exp
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnA (HsExpr GhcPs) -> HsExpr GhcPs
forall l e. GenLocated l e -> e
unLoc XRec GhcPs (HsExpr GhcPs)
GenLocated SrcSpanAnnA (HsExpr GhcPs)
a)
    (FromThen XRec GhcPs (HsExpr GhcPs)
a XRec GhcPs (HsExpr GhcPs)
b) -> Exp -> Exp -> Range
TH.FromThenR (HsExpr GhcPs -> Exp
toExp (HsExpr GhcPs -> Exp) -> HsExpr GhcPs -> Exp
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnA (HsExpr GhcPs) -> HsExpr GhcPs
forall l e. GenLocated l e -> e
unLoc XRec GhcPs (HsExpr GhcPs)
GenLocated SrcSpanAnnA (HsExpr GhcPs)
a) (HsExpr GhcPs -> Exp
toExp (HsExpr GhcPs -> Exp) -> HsExpr GhcPs -> Exp
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnA (HsExpr GhcPs) -> HsExpr GhcPs
forall l e. GenLocated l e -> e
unLoc XRec GhcPs (HsExpr GhcPs)
GenLocated SrcSpanAnnA (HsExpr GhcPs)
b)
    (FromTo XRec GhcPs (HsExpr GhcPs)
a XRec GhcPs (HsExpr GhcPs)
b) -> Exp -> Exp -> Range
TH.FromToR (HsExpr GhcPs -> Exp
toExp (HsExpr GhcPs -> Exp) -> HsExpr GhcPs -> Exp
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnA (HsExpr GhcPs) -> HsExpr GhcPs
forall l e. GenLocated l e -> e
unLoc XRec GhcPs (HsExpr GhcPs)
GenLocated SrcSpanAnnA (HsExpr GhcPs)
a) (HsExpr GhcPs -> Exp
toExp (HsExpr GhcPs -> Exp) -> HsExpr GhcPs -> Exp
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnA (HsExpr GhcPs) -> HsExpr GhcPs
forall l e. GenLocated l e -> e
unLoc XRec GhcPs (HsExpr GhcPs)
GenLocated SrcSpanAnnA (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 (HsExpr GhcPs -> Exp) -> HsExpr GhcPs -> Exp
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnA (HsExpr GhcPs) -> HsExpr GhcPs
forall l e. GenLocated l e -> e
unLoc XRec GhcPs (HsExpr GhcPs)
GenLocated SrcSpanAnnA (HsExpr GhcPs)
a) (HsExpr GhcPs -> Exp
toExp (HsExpr GhcPs -> Exp) -> HsExpr GhcPs -> Exp
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnA (HsExpr GhcPs) -> HsExpr GhcPs
forall l e. GenLocated l e -> e
unLoc XRec GhcPs (HsExpr GhcPs)
GenLocated SrcSpanAnnA (HsExpr GhcPs)
b) (HsExpr GhcPs -> Exp
toExp (HsExpr GhcPs -> Exp) -> HsExpr GhcPs -> Exp
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnA (HsExpr GhcPs) -> HsExpr GhcPs
forall l e. GenLocated l e -> e
unLoc XRec GhcPs (HsExpr GhcPs)
GenLocated SrcSpanAnnA (HsExpr GhcPs)
c)


toExp (Expr.HsProjection XProjection GhcPs
_ NonEmpty (XRec GhcPs (DotFieldOcc GhcPs))
locatedFields) =
  let
    extractFieldLabel :: DotFieldOcc p -> XRec p FieldLabelString
extractFieldLabel (DotFieldOcc XCDotFieldOcc p
_ XRec p FieldLabelString
locatedStr) = XRec p FieldLabelString
locatedStr
    extractFieldLabel DotFieldOcc p
_ = String -> XRec p FieldLabelString
forall a. HasCallStack => String -> a
error String
"Don't know how to handle XDotFieldOcc constructor..."
  in
#if __GLASGOW_HASKELL__ >= 906
    NonEmpty String -> Exp
TH.ProjectionE ((GenLocated (SrcAnn NoEpAnns) (DotFieldOcc GhcPs) -> String)
-> NonEmpty (GenLocated (SrcAnn NoEpAnns) (DotFieldOcc GhcPs))
-> NonEmpty String
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NonEmpty.map (FastString -> String
unpackFS (FastString -> String)
-> (GenLocated (SrcAnn NoEpAnns) (DotFieldOcc GhcPs) -> FastString)
-> GenLocated (SrcAnn NoEpAnns) (DotFieldOcc GhcPs)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.field_label) (FieldLabelString -> FastString)
-> (GenLocated (SrcAnn NoEpAnns) (DotFieldOcc GhcPs)
    -> FieldLabelString)
-> GenLocated (SrcAnn NoEpAnns) (DotFieldOcc GhcPs)
-> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnN FieldLabelString -> FieldLabelString
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpanAnnN FieldLabelString -> FieldLabelString)
-> (GenLocated (SrcAnn NoEpAnns) (DotFieldOcc GhcPs)
    -> GenLocated SrcSpanAnnN FieldLabelString)
-> GenLocated (SrcAnn NoEpAnns) (DotFieldOcc GhcPs)
-> FieldLabelString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DotFieldOcc GhcPs -> XRec GhcPs FieldLabelString
DotFieldOcc GhcPs -> GenLocated SrcSpanAnnN FieldLabelString
forall {p}. DotFieldOcc p -> XRec p FieldLabelString
extractFieldLabel (DotFieldOcc GhcPs -> GenLocated SrcSpanAnnN FieldLabelString)
-> (GenLocated (SrcAnn NoEpAnns) (DotFieldOcc GhcPs)
    -> DotFieldOcc GhcPs)
-> GenLocated (SrcAnn NoEpAnns) (DotFieldOcc GhcPs)
-> GenLocated SrcSpanAnnN FieldLabelString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated (SrcAnn NoEpAnns) (DotFieldOcc GhcPs)
-> DotFieldOcc GhcPs
forall l e. GenLocated l e -> e
unLoc) NonEmpty (XRec GhcPs (DotFieldOcc GhcPs))
NonEmpty (GenLocated (SrcAnn NoEpAnns) (DotFieldOcc GhcPs))
locatedFields)
#else
    TH.ProjectionE (NonEmpty.map (unpackFS . unLoc . extractFieldLabel . unLoc) locatedFields)
#endif

toExp (Expr.HsGetField XGetField GhcPs
_ XRec GhcPs (HsExpr GhcPs)
expr XRec GhcPs (DotFieldOcc GhcPs)
locatedField) =
  let
    extractFieldLabel :: DotFieldOcc p -> XRec p FieldLabelString
extractFieldLabel (DotFieldOcc XCDotFieldOcc p
_ XRec p FieldLabelString
locatedStr) = XRec p FieldLabelString
locatedStr
    extractFieldLabel DotFieldOcc p
_ = String -> XRec p FieldLabelString
forall a. HasCallStack => String -> a
error String
"Don't know how to handle XDotFieldOcc constructor..."
  in
#if __GLASGOW_HASKELL__ >= 906
    Exp -> String -> Exp
TH.GetFieldE (HsExpr GhcPs -> Exp
toExp (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> HsExpr GhcPs
forall l e. GenLocated l e -> e
unLoc XRec GhcPs (HsExpr GhcPs)
GenLocated SrcSpanAnnA (HsExpr GhcPs)
expr)) (FastString -> String
unpackFS (FastString -> String)
-> (XRec GhcPs (DotFieldOcc GhcPs) -> FastString)
-> XRec GhcPs (DotFieldOcc GhcPs)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.field_label) (FieldLabelString -> FastString)
-> (GenLocated (SrcAnn NoEpAnns) (DotFieldOcc GhcPs)
    -> FieldLabelString)
-> GenLocated (SrcAnn NoEpAnns) (DotFieldOcc GhcPs)
-> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnN FieldLabelString -> FieldLabelString
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpanAnnN FieldLabelString -> FieldLabelString)
-> (GenLocated (SrcAnn NoEpAnns) (DotFieldOcc GhcPs)
    -> GenLocated SrcSpanAnnN FieldLabelString)
-> GenLocated (SrcAnn NoEpAnns) (DotFieldOcc GhcPs)
-> FieldLabelString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DotFieldOcc GhcPs -> XRec GhcPs FieldLabelString
DotFieldOcc GhcPs -> GenLocated SrcSpanAnnN FieldLabelString
forall {p}. DotFieldOcc p -> XRec p FieldLabelString
extractFieldLabel (DotFieldOcc GhcPs -> GenLocated SrcSpanAnnN FieldLabelString)
-> (GenLocated (SrcAnn NoEpAnns) (DotFieldOcc GhcPs)
    -> DotFieldOcc GhcPs)
-> GenLocated (SrcAnn NoEpAnns) (DotFieldOcc GhcPs)
-> GenLocated SrcSpanAnnN FieldLabelString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated (SrcAnn NoEpAnns) (DotFieldOcc GhcPs)
-> DotFieldOcc GhcPs
forall l e. GenLocated l e -> e
unLoc (XRec GhcPs (DotFieldOcc GhcPs) -> String)
-> XRec GhcPs (DotFieldOcc GhcPs) -> String
forall a b. (a -> b) -> a -> b
$ XRec GhcPs (DotFieldOcc GhcPs)
locatedField)
#else
    TH.GetFieldE (toExp (unLoc expr)) (unpackFS . unLoc . extractFieldLabel . unLoc $ locatedField)
#endif

#if __GLASGOW_HASKELL__ >= 906
toExp (Expr.HsOverLabel XOverLabel GhcPs
_ SourceText
_ FastString
fastString) = String -> Exp
TH.LabelE (FastString -> String
unpackFS FastString
fastString)
#else
toExp (Expr.HsOverLabel _ fastString) = TH.LabelE (unpackFS fastString)
#endif

toExp HsExpr GhcPs
e = String -> HsExpr GhcPs -> Exp
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 = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> ([String] -> String) -> [String] -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> a) -> [String] -> a
forall a b. (a -> b) -> a -> b
$ [String
moduleName, String
".", String
fun, String
": not implemented: ", (SDoc -> String
showSDocUnsafe (SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$ e -> SDoc
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 = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> ([String] -> String) -> [String] -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> a) -> [String] -> a
forall a b. (a -> b) -> a -> b
$ [String
moduleName, String
".", String
fun, String
": no TemplateHaskell for: ", e -> String
forall a. Show a => a -> String
show e
thing]

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