{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ConstrainedClassMethods #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}

{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}

{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998


This module converts Template Haskell syntax into Hs syntax
-}

module GHC.ThToHs
   ( convertToHsExpr
   , convertToPat
   , convertToHsDecls
   , convertToHsType
   , thRdrNameGuesses
   )
where

import GHC.Prelude hiding (head, init, last, tail)

import GHC.Hs as Hs
import GHC.Builtin.Names
import GHC.Tc.Errors.Types
import GHC.Types.Name.Reader
import qualified GHC.Types.Name as Name
import GHC.Unit.Module
import GHC.Parser.PostProcess
import GHC.Types.Name.Occurrence as OccName
import GHC.Types.SrcLoc
import GHC.Core.Type as Hs
import qualified GHC.Core.Coercion as Coercion ( Role(..) )
import GHC.Builtin.Types
import GHC.Builtin.Types.Prim( fUNTyCon )
import GHC.Types.Basic as Hs
import GHC.Types.Fixity as Hs
import GHC.Types.ForeignCall
import GHC.Types.Unique
import GHC.Types.SourceText
import GHC.Data.Bag
import GHC.Utils.Lexeme
import GHC.Utils.Misc
import GHC.Data.FastString
import GHC.Utils.Panic

import Language.Haskell.Syntax.Basic (FieldLabelString(..))

import qualified Data.ByteString as BS
import Control.Monad( unless, ap )
import Control.Applicative( (<|>) )
import Data.Bifunctor (first)
import Data.Foldable (for_)
import Data.List.NonEmpty( NonEmpty (..), nonEmpty )
import qualified Data.List.NonEmpty as NE
import Data.Maybe( catMaybes, isNothing )
import Language.Haskell.TH as TH hiding (sigP)
import Language.Haskell.TH.Syntax as TH
import Foreign.ForeignPtr
import Foreign.Ptr
import System.IO.Unsafe

-------------------------------------------------------------------
--              The external interface

convertToHsDecls :: Origin -> SrcSpan -> [TH.Dec] -> Either RunSpliceFailReason [LHsDecl GhcPs]
convertToHsDecls :: Origin
-> SrcSpan -> [Dec] -> Either RunSpliceFailReason [LHsDecl GhcPs]
convertToHsDecls Origin
origin SrcSpan
loc [Dec]
ds =
  forall err a. Origin -> SrcSpan -> CvtM' err a -> Either err a
initCvt Origin
origin SrcSpan
loc forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [Maybe a] -> [a]
catMaybes (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Dec
-> CvtM'
     RunSpliceFailReason (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
cvt_dec [Dec]
ds)
  where
    cvt_dec :: Dec -> CvtM' RunSpliceFailReason (Maybe (LHsDecl GhcPs))
cvt_dec Dec
d =
      forall a.
ThingBeingConverted
-> CvtM' ConversionFailReason a -> CvtM' RunSpliceFailReason a
wrapMsg (Dec -> ThingBeingConverted
ConvDec Dec
d) forall a b. (a -> b) -> a -> b
$ Dec -> CvtM (Maybe (LHsDecl GhcPs))
cvtDec Dec
d

convertToHsExpr :: Origin -> SrcSpan -> TH.Exp -> Either RunSpliceFailReason (LHsExpr GhcPs)
convertToHsExpr :: Origin
-> SrcSpan -> Exp -> Either RunSpliceFailReason (LHsExpr GhcPs)
convertToHsExpr Origin
origin SrcSpan
loc Exp
e
  = forall err a. Origin -> SrcSpan -> CvtM' err a -> Either err a
initCvt Origin
origin SrcSpan
loc forall a b. (a -> b) -> a -> b
$ forall a.
ThingBeingConverted
-> CvtM' ConversionFailReason a -> CvtM' RunSpliceFailReason a
wrapMsg (Exp -> ThingBeingConverted
ConvExp Exp
e) forall a b. (a -> b) -> a -> b
$ Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
e

convertToPat :: Origin -> SrcSpan -> TH.Pat -> Either RunSpliceFailReason (LPat GhcPs)
convertToPat :: Origin -> SrcSpan -> Pat -> Either RunSpliceFailReason (LPat GhcPs)
convertToPat Origin
origin SrcSpan
loc Pat
p
  = forall err a. Origin -> SrcSpan -> CvtM' err a -> Either err a
initCvt Origin
origin SrcSpan
loc forall a b. (a -> b) -> a -> b
$ forall a.
ThingBeingConverted
-> CvtM' ConversionFailReason a -> CvtM' RunSpliceFailReason a
wrapMsg (Pat -> ThingBeingConverted
ConvPat Pat
p) forall a b. (a -> b) -> a -> b
$ Pat -> CvtM (LPat GhcPs)
cvtPat Pat
p

convertToHsType :: Origin -> SrcSpan -> TH.Type -> Either RunSpliceFailReason (LHsType GhcPs)
convertToHsType :: Origin
-> SrcSpan -> Type -> Either RunSpliceFailReason (LHsType GhcPs)
convertToHsType Origin
origin SrcSpan
loc Type
t
  = forall err a. Origin -> SrcSpan -> CvtM' err a -> Either err a
initCvt Origin
origin SrcSpan
loc forall a b. (a -> b) -> a -> b
$ forall a.
ThingBeingConverted
-> CvtM' ConversionFailReason a -> CvtM' RunSpliceFailReason a
wrapMsg (Type -> ThingBeingConverted
ConvType Type
t) forall a b. (a -> b) -> a -> b
$ Type -> CvtM (LHsType GhcPs)
cvtType Type
t

-------------------------------------------------------------------
newtype CvtM' err a = CvtM { forall err a.
CvtM' err a -> Origin -> SrcSpan -> Either err (SrcSpan, a)
unCvtM :: Origin -> SrcSpan -> Either err (SrcSpan, a) }
    deriving (forall a b. a -> CvtM' err b -> CvtM' err a
forall a b. (a -> b) -> CvtM' err a -> CvtM' err b
forall err a b. a -> CvtM' err b -> CvtM' err a
forall err a b. (a -> b) -> CvtM' err a -> CvtM' err b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> CvtM' err b -> CvtM' err a
$c<$ :: forall err a b. a -> CvtM' err b -> CvtM' err a
fmap :: forall a b. (a -> b) -> CvtM' err a -> CvtM' err b
$cfmap :: forall err a b. (a -> b) -> CvtM' err a -> CvtM' err b
Functor)
        -- Push down the Origin (that is configurable by
        -- -fenable-th-splice-warnings) and source location;
        -- Can fail, with a single error message

type CvtM = CvtM' ConversionFailReason

-- NB: If the conversion succeeds with (Right x), there should
--     be no exception values hiding in x
-- Reason: so a (head []) in TH code doesn't subsequently
--         make GHC crash when it tries to walk the generated tree

-- Use the SrcSpan everywhere, for lack of anything better.
-- See Note [Source locations within TH splices].

instance Applicative (CvtM' err) where
    pure :: forall a. a -> CvtM' err a
pure a
x = forall err a.
(Origin -> SrcSpan -> Either err (SrcSpan, a)) -> CvtM' err a
CvtM forall a b. (a -> b) -> a -> b
$ \Origin
_ SrcSpan
loc -> forall a b. b -> Either a b
Right (SrcSpan
loc,a
x)
    <*> :: forall a b. CvtM' err (a -> b) -> CvtM' err a -> CvtM' err b
(<*>) = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad (CvtM' err) where
  (CvtM Origin -> SrcSpan -> Either err (SrcSpan, a)
m) >>= :: forall a b. CvtM' err a -> (a -> CvtM' err b) -> CvtM' err b
>>= a -> CvtM' err b
k = forall err a.
(Origin -> SrcSpan -> Either err (SrcSpan, a)) -> CvtM' err a
CvtM forall a b. (a -> b) -> a -> b
$ \Origin
origin SrcSpan
loc -> case Origin -> SrcSpan -> Either err (SrcSpan, a)
m Origin
origin SrcSpan
loc of
    Left err
err -> forall a b. a -> Either a b
Left err
err
    Right (SrcSpan
loc',a
v) -> forall err a.
CvtM' err a -> Origin -> SrcSpan -> Either err (SrcSpan, a)
unCvtM (a -> CvtM' err b
k a
v) Origin
origin SrcSpan
loc'

mapCvtMError :: (err1 -> err2) -> CvtM' err1 a -> CvtM' err2 a
mapCvtMError :: forall err1 err2 a. (err1 -> err2) -> CvtM' err1 a -> CvtM' err2 a
mapCvtMError err1 -> err2
f (CvtM Origin -> SrcSpan -> Either err1 (SrcSpan, a)
m) = forall err a.
(Origin -> SrcSpan -> Either err (SrcSpan, a)) -> CvtM' err a
CvtM forall a b. (a -> b) -> a -> b
$ \Origin
origin SrcSpan
loc -> forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first err1 -> err2
f forall a b. (a -> b) -> a -> b
$ Origin -> SrcSpan -> Either err1 (SrcSpan, a)
m Origin
origin SrcSpan
loc

initCvt :: Origin -> SrcSpan -> CvtM' err a -> Either err a
initCvt :: forall err a. Origin -> SrcSpan -> CvtM' err a -> Either err a
initCvt Origin
origin SrcSpan
loc (CvtM Origin -> SrcSpan -> Either err (SrcSpan, a)
m) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd (Origin -> SrcSpan -> Either err (SrcSpan, a)
m Origin
origin SrcSpan
loc)

force :: a -> CvtM ()
force :: forall a. a -> CvtM ()
force a
a = a
a seq :: forall a b. a -> b -> b
`seq` forall (m :: * -> *) a. Monad m => a -> m a
return ()

failWith :: ConversionFailReason -> CvtM a
failWith :: forall a. ConversionFailReason -> CvtM a
failWith ConversionFailReason
m = forall err a.
(Origin -> SrcSpan -> Either err (SrcSpan, a)) -> CvtM' err a
CvtM (\Origin
_ SrcSpan
_ -> forall a b. a -> Either a b
Left ConversionFailReason
m)

getOrigin :: CvtM Origin
getOrigin :: CvtM Origin
getOrigin = forall err a.
(Origin -> SrcSpan -> Either err (SrcSpan, a)) -> CvtM' err a
CvtM (\Origin
origin SrcSpan
loc -> forall a b. b -> Either a b
Right (SrcSpan
loc,Origin
origin))

getL :: CvtM SrcSpan
getL :: CvtM SrcSpan
getL = forall err a.
(Origin -> SrcSpan -> Either err (SrcSpan, a)) -> CvtM' err a
CvtM (\Origin
_ SrcSpan
loc -> forall a b. b -> Either a b
Right (SrcSpan
loc,SrcSpan
loc))

-- NB: This is only used in conjunction with LineP pragmas.
-- See Note [Source locations within TH splices].
setL :: SrcSpan -> CvtM ()
setL :: SrcSpan -> CvtM ()
setL SrcSpan
loc = forall err a.
(Origin -> SrcSpan -> Either err (SrcSpan, a)) -> CvtM' err a
CvtM (\Origin
_ SrcSpan
_ -> forall a b. b -> Either a b
Right (SrcSpan
loc, ()))

returnLA :: e -> CvtM (LocatedAn ann e)
returnLA :: forall e ann. e -> CvtM (LocatedAn ann e)
returnLA e
x = forall err a.
(Origin -> SrcSpan -> Either err (SrcSpan, a)) -> CvtM' err a
CvtM (\Origin
_ SrcSpan
loc -> forall a b. b -> Either a b
Right (SrcSpan
loc, forall l e. l -> e -> GenLocated l e
L (forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) e
x))

returnJustLA :: a -> CvtM (Maybe (LocatedA a))
returnJustLA :: forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e ann. e -> CvtM (LocatedAn ann e)
returnLA

wrapParLA :: (LocatedAn ann a -> b) -> a -> CvtM b
wrapParLA :: forall ann a b. (LocatedAn ann a -> b) -> a -> CvtM b
wrapParLA LocatedAn ann a -> b
add_par a
x = forall err a.
(Origin -> SrcSpan -> Either err (SrcSpan, a)) -> CvtM' err a
CvtM (\Origin
_ SrcSpan
loc -> forall a b. b -> Either a b
Right (SrcSpan
loc, LocatedAn ann a -> b
add_par (forall l e. l -> e -> GenLocated l e
L (forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) a
x)))

wrapMsg :: ThingBeingConverted -> CvtM' ConversionFailReason a -> CvtM' RunSpliceFailReason a
wrapMsg :: forall a.
ThingBeingConverted
-> CvtM' ConversionFailReason a -> CvtM' RunSpliceFailReason a
wrapMsg ThingBeingConverted
what = forall err1 err2 a. (err1 -> err2) -> CvtM' err1 a -> CvtM' err2 a
mapCvtMError (ThingBeingConverted -> ConversionFailReason -> RunSpliceFailReason
ConversionFail ThingBeingConverted
what)

wrapL :: CvtM a -> CvtM (Located a)
wrapL :: forall a. CvtM a -> CvtM (Located a)
wrapL (CvtM Origin -> SrcSpan -> Either ConversionFailReason (SrcSpan, a)
m) = forall err a.
(Origin -> SrcSpan -> Either err (SrcSpan, a)) -> CvtM' err a
CvtM forall a b. (a -> b) -> a -> b
$ \Origin
origin SrcSpan
loc -> case Origin -> SrcSpan -> Either ConversionFailReason (SrcSpan, a)
m Origin
origin SrcSpan
loc of
  Left ConversionFailReason
err -> forall a b. a -> Either a b
Left ConversionFailReason
err
  Right (SrcSpan
loc', a
v) -> forall a b. b -> Either a b
Right (SrcSpan
loc', forall l e. l -> e -> GenLocated l e
L SrcSpan
loc a
v)

wrapLN :: CvtM a -> CvtM (LocatedN a)
wrapLN :: forall a. CvtM a -> CvtM (LocatedN a)
wrapLN (CvtM Origin -> SrcSpan -> Either ConversionFailReason (SrcSpan, a)
m) = forall err a.
(Origin -> SrcSpan -> Either err (SrcSpan, a)) -> CvtM' err a
CvtM forall a b. (a -> b) -> a -> b
$ \Origin
origin SrcSpan
loc -> case Origin -> SrcSpan -> Either ConversionFailReason (SrcSpan, a)
m Origin
origin SrcSpan
loc of
  Left ConversionFailReason
err -> forall a b. a -> Either a b
Left ConversionFailReason
err
  Right (SrcSpan
loc', a
v) -> forall a b. b -> Either a b
Right (SrcSpan
loc', forall l e. l -> e -> GenLocated l e
L (forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) a
v)

wrapLA :: CvtM a -> CvtM (LocatedA a)
wrapLA :: forall a. CvtM a -> CvtM (LocatedA a)
wrapLA (CvtM Origin -> SrcSpan -> Either ConversionFailReason (SrcSpan, a)
m) = forall err a.
(Origin -> SrcSpan -> Either err (SrcSpan, a)) -> CvtM' err a
CvtM forall a b. (a -> b) -> a -> b
$ \Origin
origin SrcSpan
loc -> case Origin -> SrcSpan -> Either ConversionFailReason (SrcSpan, a)
m Origin
origin SrcSpan
loc of
  Left ConversionFailReason
err -> forall a b. a -> Either a b
Left ConversionFailReason
err
  Right (SrcSpan
loc', a
v) -> forall a b. b -> Either a b
Right (SrcSpan
loc', forall l e. l -> e -> GenLocated l e
L (forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) a
v)

{-
Note [Source locations within TH splices]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider a TH splice such as $(x), where `x` evaluates to `id True`. What
source locations should we use for subexpressions within the splice, such as
`id` and `True`? We basically have two options:

1. Don't give anything within the splice a SrcSpan. That is, use the `noLoc`
   everywhere.
2. Give everything within the splice the same `SrcSpan` as where the splice
   occurs (i.e., where $(x) occurs).

We implement option (2) for the following reasons:

* We want SrcSpans on binding locations so that variables bound in the
  spliced-in declarations get a location that at least relates to the splice
  point.

* Generally speaking, having *some* SrcSpan for each sub-expression in the AST
  in better than having no SrcSpan at all. This extra information can be useful
  for programs that walk over the AST directly.

Because of our choice of option (2), we are very careful not to use the noLoc
function anywhere in GHC.ThToHs. Instead, we thread around a SrcSpan in CvtM
and allow retrieving the SrcSpan through combinators such as getL, returnLA,
wrapParLA, etc.

Note that CvtM is actually a *state* monad vis-à-vis SrcSpan, not just a
reader monad. This is because LineP pragmas can change the source location
within a splice—see testsuite/tests/th/TH_linePragma.hs for an example. This
is a bit unusual, since it changes the source location from that of the splice
point to that of the code being spliced in. Nevertheless, LineP is *the* reason
why CvtM is a state monad.
-}

-------------------------------------------------------------------
cvtDecs :: [TH.Dec] -> CvtM [LHsDecl GhcPs]
cvtDecs :: [Dec] -> CvtM [LHsDecl GhcPs]
cvtDecs = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [Maybe a] -> [a]
catMaybes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Dec -> CvtM (Maybe (LHsDecl GhcPs))
cvtDec

cvtDec :: TH.Dec -> CvtM (Maybe (LHsDecl GhcPs))
cvtDec :: Dec -> CvtM (Maybe (LHsDecl GhcPs))
cvtDec (TH.ValD Pat
pat Body
body [Dec]
ds)
  | TH.VarP Name
s <- Pat
pat
  = do  { LocatedN RdrName
s' <- Name -> CvtM (LocatedN RdrName)
vNameN Name
s
        ; GenLocated
  SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
cl' <- HsMatchContext GhcPs
-> Clause -> CvtM (LMatch GhcPs (LHsExpr GhcPs))
cvtClause (forall p. LIdP (NoGhcTc p) -> HsMatchContext p
mkPrefixFunRhs LocatedN RdrName
s') ([Pat] -> Body -> [Dec] -> Clause
Clause [] Body
body [Dec]
ds)
        ; Origin
th_origin <- CvtM Origin
getOrigin
        ; forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA forall a b. (a -> b) -> a -> b
$ forall p. XValD p -> HsBind p -> HsDecl p
Hs.ValD NoExtField
noExtField forall a b. (a -> b) -> a -> b
$ Origin
-> LocatedN RdrName
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> HsBind GhcPs
mkFunBind Origin
th_origin LocatedN RdrName
s' [GenLocated
  SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
cl'] }

  | Bool
otherwise
  = do  { GenLocated SrcSpanAnnA (Pat GhcPs)
pat' <- Pat -> CvtM (LPat GhcPs)
cvtPat Pat
pat
        ; [GenLocated
   (SrcAnn NoEpAnns)
   (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
body' <- Body -> CvtM [LGRHS GhcPs (LHsExpr GhcPs)]
cvtGuard Body
body
        ; HsLocalBinds GhcPs
ds' <- THDeclDescriptor -> [Dec] -> CvtM (HsLocalBinds GhcPs)
cvtLocalDecs THDeclDescriptor
WhereClause [Dec]
ds
        ; forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA forall a b. (a -> b) -> a -> b
$ forall p. XValD p -> HsBind p -> HsDecl p
Hs.ValD NoExtField
noExtField forall a b. (a -> b) -> a -> b
$
          PatBind { pat_lhs :: LPat GhcPs
pat_lhs = GenLocated SrcSpanAnnA (Pat GhcPs)
pat'
                  , pat_rhs :: GRHSs GhcPs (LHsExpr GhcPs)
pat_rhs = forall p body.
XCGRHSs p body -> [LGRHS p body] -> HsLocalBinds p -> GRHSs p body
GRHSs EpAnnComments
emptyComments [GenLocated
   (SrcAnn NoEpAnns)
   (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
body' HsLocalBinds GhcPs
ds'
                  , pat_ext :: XPatBind GhcPs GhcPs
pat_ext = forall a. EpAnn a
noAnn
                  } }

cvtDec (TH.FunD Name
nm [Clause]
cls)
  | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Clause]
cls
  = forall a. ConversionFailReason -> CvtM a
failWith forall a b. (a -> b) -> a -> b
$ Name -> ConversionFailReason
FunBindLacksEquations Name
nm
  | Bool
otherwise
  = do  { LocatedN RdrName
nm' <- Name -> CvtM (LocatedN RdrName)
vNameN Name
nm
        ; [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
cls' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (HsMatchContext GhcPs
-> Clause -> CvtM (LMatch GhcPs (LHsExpr GhcPs))
cvtClause (forall p. LIdP (NoGhcTc p) -> HsMatchContext p
mkPrefixFunRhs LocatedN RdrName
nm')) [Clause]
cls
        ; Origin
th_origin <- CvtM Origin
getOrigin
        ; forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA forall a b. (a -> b) -> a -> b
$ forall p. XValD p -> HsBind p -> HsDecl p
Hs.ValD NoExtField
noExtField forall a b. (a -> b) -> a -> b
$ Origin
-> LocatedN RdrName
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> HsBind GhcPs
mkFunBind Origin
th_origin LocatedN RdrName
nm' [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
cls' }

cvtDec (TH.SigD Name
nm Type
typ)
  = do  { LocatedN RdrName
nm' <- Name -> CvtM (LocatedN RdrName)
vNameN Name
nm
        ; GenLocated SrcSpanAnnA (HsSigType GhcPs)
ty' <- Type -> CvtM (LHsSigType GhcPs)
cvtSigType Type
typ
        ; forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA forall a b. (a -> b) -> a -> b
$ forall p. XSigD p -> Sig p -> HsDecl p
Hs.SigD NoExtField
noExtField
                                    (forall pass.
XTypeSig pass -> [LIdP pass] -> LHsSigWcType pass -> Sig pass
TypeSig forall a. EpAnn a
noAnn [LocatedN RdrName
nm'] (forall thing. thing -> HsWildCardBndrs GhcPs thing
mkHsWildCardBndrs GenLocated SrcSpanAnnA (HsSigType GhcPs)
ty')) }

cvtDec (TH.KiSigD Name
nm Type
ki)
  = do  { LocatedN RdrName
nm' <- Name -> CvtM (LocatedN RdrName)
tconNameN Name
nm
        ; GenLocated SrcSpanAnnA (HsSigType GhcPs)
ki' <- Type -> CvtM (LHsSigType GhcPs)
cvtSigKind Type
ki
        ; let sig' :: StandaloneKindSig GhcPs
sig' = forall pass.
XStandaloneKindSig pass
-> LIdP pass -> LHsSigType pass -> StandaloneKindSig pass
StandaloneKindSig forall a. EpAnn a
noAnn LocatedN RdrName
nm' GenLocated SrcSpanAnnA (HsSigType GhcPs)
ki'
        ; forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA forall a b. (a -> b) -> a -> b
$ forall p. XKindSigD p -> StandaloneKindSig p -> HsDecl p
Hs.KindSigD NoExtField
noExtField StandaloneKindSig GhcPs
sig' }

cvtDec (TH.InfixD Fixity
fx Name
nm)
  -- Fixity signatures are allowed for variables, constructors, and types
  -- the renamer automatically looks for types during renaming, even when
  -- the RdrName says it's a variable or a constructor. So, just assume
  -- it's a variable or constructor and proceed.
  = do { LocatedN RdrName
nm' <- Name -> CvtM (LocatedN RdrName)
vcNameN Name
nm
       ; forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA (forall p. XSigD p -> Sig p -> HsDecl p
Hs.SigD NoExtField
noExtField (forall pass. XFixSig pass -> FixitySig pass -> Sig pass
FixSig forall a. EpAnn a
noAnn
                                      (forall pass.
XFixitySig pass -> [LIdP pass] -> Fixity -> FixitySig pass
FixitySig NoExtField
noExtField [LocatedN RdrName
nm'] (Fixity -> Fixity
cvtFixity Fixity
fx)))) }

cvtDec (TH.DefaultD [Type]
tys)
  = do  { [GenLocated SrcSpanAnnA (HsType GhcPs)]
tys' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Type -> CvtM (LHsType GhcPs)
cvtType [Type]
tys
        ; forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA (forall p. XDefD p -> DefaultDecl p -> HsDecl p
Hs.DefD NoExtField
noExtField forall a b. (a -> b) -> a -> b
$ forall pass.
XCDefaultDecl pass -> [LHsType pass] -> DefaultDecl pass
DefaultDecl forall a. EpAnn a
noAnn [GenLocated SrcSpanAnnA (HsType GhcPs)]
tys') }

cvtDec (PragmaD Pragma
prag)
  = Pragma -> CvtM (Maybe (LHsDecl GhcPs))
cvtPragmaD Pragma
prag

cvtDec (TySynD Name
tc [TyVarBndr ()]
tvs Type
rhs)
  = do  { (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
_, LocatedN RdrName
tc', LHsQTyVars GhcPs
tvs') <- [Type]
-> Name
-> [TyVarBndr ()]
-> CvtM (LHsContext GhcPs, LocatedN RdrName, LHsQTyVars GhcPs)
cvt_tycl_hdr [] Name
tc [TyVarBndr ()]
tvs
        ; GenLocated SrcSpanAnnA (HsType GhcPs)
rhs' <- Type -> CvtM (LHsType GhcPs)
cvtType Type
rhs
        ; forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA forall a b. (a -> b) -> a -> b
$ forall p. XTyClD p -> TyClDecl p -> HsDecl p
TyClD NoExtField
noExtField forall a b. (a -> b) -> a -> b
$
          SynDecl { tcdSExt :: XSynDecl GhcPs
tcdSExt = forall a. EpAnn a
noAnn, tcdLName :: XRec GhcPs (IdP GhcPs)
tcdLName = LocatedN RdrName
tc', tcdTyVars :: LHsQTyVars GhcPs
tcdTyVars = LHsQTyVars GhcPs
tvs'
                  , tcdFixity :: LexicalFixity
tcdFixity = LexicalFixity
Prefix
                  , tcdRhs :: LHsType GhcPs
tcdRhs = GenLocated SrcSpanAnnA (HsType GhcPs)
rhs' } }

cvtDec (DataD [Type]
ctxt Name
tc [TyVarBndr ()]
tvs Maybe Type
ksig [Con]
constrs [DerivClause]
derivs)
  = [Type]
-> Name
-> [TyVarBndr ()]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> CvtM (Maybe (LHsDecl GhcPs))
cvtDataDec [Type]
ctxt Name
tc [TyVarBndr ()]
tvs Maybe Type
ksig [Con]
constrs [DerivClause]
derivs

cvtDec (NewtypeD [Type]
ctxt Name
tc [TyVarBndr ()]
tvs Maybe Type
ksig Con
constr [DerivClause]
derivs)
  = do  { (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
ctxt', LocatedN RdrName
tc', LHsQTyVars GhcPs
tvs') <- [Type]
-> Name
-> [TyVarBndr ()]
-> CvtM (LHsContext GhcPs, LocatedN RdrName, LHsQTyVars GhcPs)
cvt_tycl_hdr [Type]
ctxt Name
tc [TyVarBndr ()]
tvs
        ; Maybe (GenLocated SrcSpanAnnA (HsType GhcPs))
ksig' <- Type -> CvtM (LHsType GhcPs)
cvtKind forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
`traverse` Maybe Type
ksig
        ; GenLocated SrcSpanAnnA (ConDecl GhcPs)
con' <- (Name -> CvtM (LocatedN RdrName)) -> Con -> CvtM (LConDecl GhcPs)
cvtConstr Name -> CvtM (LocatedN RdrName)
cNameN Con
constr
        ; [GenLocated (SrcAnn NoEpAnns) (HsDerivingClause GhcPs)]
derivs' <- [DerivClause] -> CvtM (HsDeriving GhcPs)
cvtDerivs [DerivClause]
derivs
        ; let defn :: HsDataDefn GhcPs
defn = HsDataDefn { dd_ext :: XCHsDataDefn GhcPs
dd_ext = NoExtField
noExtField
                                , dd_cType :: Maybe (XRec GhcPs CType)
dd_cType = forall a. Maybe a
Nothing
                                , dd_ctxt :: Maybe (LHsContext GhcPs)
dd_ctxt = LHsContext GhcPs -> Maybe (LHsContext GhcPs)
mkHsContextMaybe GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
ctxt'
                                , dd_kindSig :: Maybe (LHsType GhcPs)
dd_kindSig = Maybe (GenLocated SrcSpanAnnA (HsType GhcPs))
ksig'
                                , dd_cons :: DataDefnCons (LConDecl GhcPs)
dd_cons = forall a. a -> DataDefnCons a
NewTypeCon GenLocated SrcSpanAnnA (ConDecl GhcPs)
con'
                                , dd_derivs :: HsDeriving GhcPs
dd_derivs = [GenLocated (SrcAnn NoEpAnns) (HsDerivingClause GhcPs)]
derivs' }
        ; forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA forall a b. (a -> b) -> a -> b
$ forall p. XTyClD p -> TyClDecl p -> HsDecl p
TyClD NoExtField
noExtField forall a b. (a -> b) -> a -> b
$
          DataDecl { tcdDExt :: XDataDecl GhcPs
tcdDExt = forall a. EpAnn a
noAnn
                   , tcdLName :: XRec GhcPs (IdP GhcPs)
tcdLName = LocatedN RdrName
tc', tcdTyVars :: LHsQTyVars GhcPs
tcdTyVars = LHsQTyVars GhcPs
tvs'
                   , tcdFixity :: LexicalFixity
tcdFixity = LexicalFixity
Prefix
                   , tcdDataDefn :: HsDataDefn GhcPs
tcdDataDefn = HsDataDefn GhcPs
defn } }

cvtDec (TypeDataD Name
tc [TyVarBndr ()]
tvs Maybe Type
ksig [Con]
constrs)
  = Name
-> [TyVarBndr ()]
-> Maybe Type
-> [Con]
-> CvtM (Maybe (LHsDecl GhcPs))
cvtTypeDataDec Name
tc [TyVarBndr ()]
tvs Maybe Type
ksig [Con]
constrs

cvtDec (ClassD [Type]
ctxt Name
cl [TyVarBndr ()]
tvs [FunDep]
fds [Dec]
decs)
  = do  { (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
cxt', LocatedN RdrName
tc', LHsQTyVars GhcPs
tvs') <- [Type]
-> Name
-> [TyVarBndr ()]
-> CvtM (LHsContext GhcPs, LocatedN RdrName, LHsQTyVars GhcPs)
cvt_tycl_hdr [Type]
ctxt Name
cl [TyVarBndr ()]
tvs
        ; [GenLocated SrcSpanAnnA (FunDep GhcPs)]
fds'  <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FunDep -> CvtM (LHsFunDep GhcPs)
cvt_fundep [FunDep]
fds
        ; (Bag (GenLocated SrcSpanAnnA (HsBind GhcPs))
binds', [GenLocated SrcSpanAnnA (Sig GhcPs)]
sigs', [GenLocated SrcSpanAnnA (FamilyDecl GhcPs)]
fams', [GenLocated SrcSpanAnnA (TyFamInstDecl GhcPs)]
at_defs', [GenLocated SrcSpanAnnA (DataFamInstDecl GhcPs)]
adts') <- THDeclDescriptor
-> [Dec]
-> CvtM
     (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],
      [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs])
cvt_ci_decs THDeclDescriptor
ClssDecl [Dec]
decs
        ; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated SrcSpanAnnA (DataFamInstDecl GhcPs)]
adts')
            (forall a. ConversionFailReason -> CvtM a
failWith forall a b. (a -> b) -> a -> b
$ [LDataFamInstDecl GhcPs] -> ConversionFailReason
DefaultDataInstDecl [GenLocated SrcSpanAnnA (DataFamInstDecl GhcPs)]
adts')
        ; forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA forall a b. (a -> b) -> a -> b
$ forall p. XTyClD p -> TyClDecl p -> HsDecl p
TyClD NoExtField
noExtField forall a b. (a -> b) -> a -> b
$
          ClassDecl { tcdCExt :: XClassDecl GhcPs
tcdCExt = (forall a. EpAnn a
noAnn, AnnSortKey
NoAnnSortKey), tcdLayout :: LayoutInfo GhcPs
tcdLayout = forall pass. LayoutInfo pass
NoLayoutInfo
                    , tcdCtxt :: Maybe (LHsContext GhcPs)
tcdCtxt = LHsContext GhcPs -> Maybe (LHsContext GhcPs)
mkHsContextMaybe GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
cxt', tcdLName :: XRec GhcPs (IdP GhcPs)
tcdLName = LocatedN RdrName
tc', tcdTyVars :: LHsQTyVars GhcPs
tcdTyVars = LHsQTyVars GhcPs
tvs'
                    , tcdFixity :: LexicalFixity
tcdFixity = LexicalFixity
Prefix
                    , tcdFDs :: [LHsFunDep GhcPs]
tcdFDs = [GenLocated SrcSpanAnnA (FunDep GhcPs)]
fds', tcdSigs :: [LSig GhcPs]
tcdSigs = [LSig GhcPs] -> [LSig GhcPs]
Hs.mkClassOpSigs [GenLocated SrcSpanAnnA (Sig GhcPs)]
sigs'
                    , tcdMeths :: LHsBinds GhcPs
tcdMeths = Bag (GenLocated SrcSpanAnnA (HsBind GhcPs))
binds'
                    , tcdATs :: [LFamilyDecl GhcPs]
tcdATs = [GenLocated SrcSpanAnnA (FamilyDecl GhcPs)]
fams', tcdATDefs :: [LTyFamInstDecl GhcPs]
tcdATDefs = [GenLocated SrcSpanAnnA (TyFamInstDecl GhcPs)]
at_defs', tcdDocs :: [LDocDecl GhcPs]
tcdDocs = [] }
                              -- no docs in TH ^^
        }

cvtDec (InstanceD Maybe Overlap
o [Type]
ctxt Type
ty [Dec]
decs)
  = do  { (Bag (GenLocated SrcSpanAnnA (HsBind GhcPs))
binds', [GenLocated SrcSpanAnnA (Sig GhcPs)]
sigs', [GenLocated SrcSpanAnnA (FamilyDecl GhcPs)]
fams', [GenLocated SrcSpanAnnA (TyFamInstDecl GhcPs)]
ats', [GenLocated SrcSpanAnnA (DataFamInstDecl GhcPs)]
adts') <- THDeclDescriptor
-> [Dec]
-> CvtM
     (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],
      [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs])
cvt_ci_decs THDeclDescriptor
InstanceDecl [Dec]
decs
        ; forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [GenLocated SrcSpanAnnA (FamilyDecl GhcPs)]
fams') forall a b. (a -> b) -> a -> b
$ \ NonEmpty (GenLocated SrcSpanAnnA (FamilyDecl GhcPs))
bad_fams ->
            forall a. ConversionFailReason -> CvtM a
failWith (THDeclDescriptor -> IllegalDecls -> ConversionFailReason
IllegalDeclaration THDeclDescriptor
InstanceDecl forall a b. (a -> b) -> a -> b
$ NonEmpty (LFamilyDecl GhcPs) -> IllegalDecls
IllegalFamDecls NonEmpty (GenLocated SrcSpanAnnA (FamilyDecl GhcPs))
bad_fams)
        ; GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
ctxt' <- PprPrec -> [Type] -> CvtM (LHsContext GhcPs)
cvtContext PprPrec
funPrec [Type]
ctxt
        ; (L SrcSpanAnnA
loc HsType GhcPs
ty') <- Type -> CvtM (LHsType GhcPs)
cvtType Type
ty
        ; let inst_ty' :: GenLocated SrcSpanAnnA (HsSigType GhcPs)
inst_ty' = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc forall a b. (a -> b) -> a -> b
$ LHsType GhcPs -> HsSigType GhcPs
mkHsImplicitSigType forall a b. (a -> b) -> a -> b
$
                         [Type]
-> SrcSpanAnnA
-> LHsContext GhcPs
-> LHsType GhcPs
-> LHsType GhcPs
mkHsQualTy [Type]
ctxt SrcSpanAnnA
loc GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
ctxt' forall a b. (a -> b) -> a -> b
$ forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc HsType GhcPs
ty'
        ; forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA forall a b. (a -> b) -> a -> b
$ forall p. XInstD p -> InstDecl p -> HsDecl p
InstD NoExtField
noExtField forall a b. (a -> b) -> a -> b
$ forall pass. XClsInstD pass -> ClsInstDecl pass -> InstDecl pass
ClsInstD NoExtField
noExtField forall a b. (a -> b) -> a -> b
$
          ClsInstDecl { cid_ext :: XCClsInstDecl GhcPs
cid_ext = (forall a. EpAnn a
noAnn, AnnSortKey
NoAnnSortKey), cid_poly_ty :: LHsSigType GhcPs
cid_poly_ty = GenLocated SrcSpanAnnA (HsSigType GhcPs)
inst_ty'
                      , cid_binds :: LHsBinds GhcPs
cid_binds = Bag (GenLocated SrcSpanAnnA (HsBind GhcPs))
binds'
                      , cid_sigs :: [LSig GhcPs]
cid_sigs = [LSig GhcPs] -> [LSig GhcPs]
Hs.mkClassOpSigs [GenLocated SrcSpanAnnA (Sig GhcPs)]
sigs'
                      , cid_tyfam_insts :: [LTyFamInstDecl GhcPs]
cid_tyfam_insts = [GenLocated SrcSpanAnnA (TyFamInstDecl GhcPs)]
ats', cid_datafam_insts :: [LDataFamInstDecl GhcPs]
cid_datafam_insts = [GenLocated SrcSpanAnnA (DataFamInstDecl GhcPs)]
adts'
                      , cid_overlap_mode :: Maybe (XRec GhcPs OverlapMode)
cid_overlap_mode
                                   = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall l e. l -> e -> GenLocated l e
L (forall a ann. SrcSpanAnn' a -> SrcAnn ann
l2l SrcSpanAnnA
loc) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Overlap -> OverlapMode
overlap) Maybe Overlap
o } }
  where
  overlap :: Overlap -> OverlapMode
overlap Overlap
pragma =
    case Overlap
pragma of
      Overlap
TH.Overlaps      -> SourceText -> OverlapMode
Hs.Overlaps     (String -> SourceText
SourceText String
"OVERLAPS")
      Overlap
TH.Overlappable  -> SourceText -> OverlapMode
Hs.Overlappable (String -> SourceText
SourceText String
"OVERLAPPABLE")
      Overlap
TH.Overlapping   -> SourceText -> OverlapMode
Hs.Overlapping  (String -> SourceText
SourceText String
"OVERLAPPING")
      Overlap
TH.Incoherent    -> SourceText -> OverlapMode
Hs.Incoherent   (String -> SourceText
SourceText String
"INCOHERENT")




cvtDec (ForeignD Foreign
ford)
  = do { ForeignDecl GhcPs
ford' <- Foreign -> CvtM (ForeignDecl GhcPs)
cvtForD Foreign
ford
       ; forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA forall a b. (a -> b) -> a -> b
$ forall p. XForD p -> ForeignDecl p -> HsDecl p
ForD NoExtField
noExtField ForeignDecl GhcPs
ford' }

cvtDec (DataFamilyD Name
tc [TyVarBndr ()]
tvs Maybe Type
kind)
  = do { (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
_, LocatedN RdrName
tc', LHsQTyVars GhcPs
tvs') <- [Type]
-> Name
-> [TyVarBndr ()]
-> CvtM (LHsContext GhcPs, LocatedN RdrName, LHsQTyVars GhcPs)
cvt_tycl_hdr [] Name
tc [TyVarBndr ()]
tvs
       ; GenLocated (SrcAnn NoEpAnns) (FamilyResultSig GhcPs)
result <- Maybe Type -> CvtM (LFamilyResultSig GhcPs)
cvtMaybeKindToFamilyResultSig Maybe Type
kind
       ; forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA forall a b. (a -> b) -> a -> b
$ forall p. XTyClD p -> TyClDecl p -> HsDecl p
TyClD NoExtField
noExtField forall a b. (a -> b) -> a -> b
$ forall pass. XFamDecl pass -> FamilyDecl pass -> TyClDecl pass
FamDecl NoExtField
noExtField forall a b. (a -> b) -> a -> b
$
         forall pass.
XCFamilyDecl pass
-> FamilyInfo pass
-> TopLevelFlag
-> LIdP pass
-> LHsQTyVars pass
-> LexicalFixity
-> LFamilyResultSig pass
-> Maybe (LInjectivityAnn pass)
-> FamilyDecl pass
FamilyDecl forall a. EpAnn a
noAnn forall pass. FamilyInfo pass
DataFamily TopLevelFlag
TopLevel LocatedN RdrName
tc' LHsQTyVars GhcPs
tvs' LexicalFixity
Prefix GenLocated (SrcAnn NoEpAnns) (FamilyResultSig GhcPs)
result forall a. Maybe a
Nothing }

cvtDec (DataInstD [Type]
ctxt Maybe [TyVarBndr ()]
bndrs Type
tys Maybe Type
ksig [Con]
constrs [DerivClause]
derivs)
  = do { (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
ctxt', LocatedN RdrName
tc', HsOuterFamEqnTyVarBndrs GhcPs
bndrs', [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
typats') <- [Type]
-> Maybe [TyVarBndr ()]
-> Type
-> CvtM
     (LHsContext GhcPs, LocatedN RdrName, HsOuterFamEqnTyVarBndrs GhcPs,
      HsTyPats GhcPs)
cvt_datainst_hdr [Type]
ctxt Maybe [TyVarBndr ()]
bndrs Type
tys
       ; Maybe (GenLocated SrcSpanAnnA (HsType GhcPs))
ksig' <- Type -> CvtM (LHsType GhcPs)
cvtKind forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
`traverse` Maybe Type
ksig
       ; [GenLocated SrcSpanAnnA (ConDecl GhcPs)]
cons' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Name -> CvtM (LocatedN RdrName)) -> Con -> CvtM (LConDecl GhcPs)
cvtConstr Name -> CvtM (LocatedN RdrName)
cNameN) [Con]
constrs
       ; [GenLocated (SrcAnn NoEpAnns) (HsDerivingClause GhcPs)]
derivs' <- [DerivClause] -> CvtM (HsDeriving GhcPs)
cvtDerivs [DerivClause]
derivs
       ; let defn :: HsDataDefn GhcPs
defn = HsDataDefn { dd_ext :: XCHsDataDefn GhcPs
dd_ext = NoExtField
noExtField
                               , dd_cType :: Maybe (XRec GhcPs CType)
dd_cType = forall a. Maybe a
Nothing
                               , dd_ctxt :: Maybe (LHsContext GhcPs)
dd_ctxt = LHsContext GhcPs -> Maybe (LHsContext GhcPs)
mkHsContextMaybe GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
ctxt'
                               , dd_kindSig :: Maybe (LHsType GhcPs)
dd_kindSig = Maybe (GenLocated SrcSpanAnnA (HsType GhcPs))
ksig'
                               , dd_cons :: DataDefnCons (LConDecl GhcPs)
dd_cons = forall a. Bool -> [a] -> DataDefnCons a
DataTypeCons Bool
False [GenLocated SrcSpanAnnA (ConDecl GhcPs)]
cons'
                               , dd_derivs :: HsDeriving GhcPs
dd_derivs = [GenLocated (SrcAnn NoEpAnns) (HsDerivingClause GhcPs)]
derivs' }

       ; forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA forall a b. (a -> b) -> a -> b
$ forall p. XInstD p -> InstDecl p -> HsDecl p
InstD NoExtField
noExtField forall a b. (a -> b) -> a -> b
$ DataFamInstD
           { dfid_ext :: XDataFamInstD GhcPs
dfid_ext = NoExtField
noExtField
           , dfid_inst :: DataFamInstDecl GhcPs
dfid_inst = DataFamInstDecl { dfid_eqn :: FamEqn GhcPs (HsDataDefn GhcPs)
dfid_eqn =
                           FamEqn { feqn_ext :: XCFamEqn GhcPs (HsDataDefn GhcPs)
feqn_ext = forall a. EpAnn a
noAnn
                                  , feqn_tycon :: XRec GhcPs (IdP GhcPs)
feqn_tycon = LocatedN RdrName
tc'
                                  , feqn_bndrs :: HsOuterFamEqnTyVarBndrs GhcPs
feqn_bndrs = HsOuterFamEqnTyVarBndrs GhcPs
bndrs'
                                  , feqn_pats :: HsTyPats GhcPs
feqn_pats = [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
typats'
                                  , feqn_rhs :: HsDataDefn GhcPs
feqn_rhs = HsDataDefn GhcPs
defn
                                  , feqn_fixity :: LexicalFixity
feqn_fixity = LexicalFixity
Prefix } }}}

cvtDec (NewtypeInstD [Type]
ctxt Maybe [TyVarBndr ()]
bndrs Type
tys Maybe Type
ksig Con
constr [DerivClause]
derivs)
  = do { (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
ctxt', LocatedN RdrName
tc', HsOuterFamEqnTyVarBndrs GhcPs
bndrs', [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
typats') <- [Type]
-> Maybe [TyVarBndr ()]
-> Type
-> CvtM
     (LHsContext GhcPs, LocatedN RdrName, HsOuterFamEqnTyVarBndrs GhcPs,
      HsTyPats GhcPs)
cvt_datainst_hdr [Type]
ctxt Maybe [TyVarBndr ()]
bndrs Type
tys
       ; Maybe (GenLocated SrcSpanAnnA (HsType GhcPs))
ksig' <- Type -> CvtM (LHsType GhcPs)
cvtKind forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
`traverse` Maybe Type
ksig
       ; GenLocated SrcSpanAnnA (ConDecl GhcPs)
con' <- (Name -> CvtM (LocatedN RdrName)) -> Con -> CvtM (LConDecl GhcPs)
cvtConstr Name -> CvtM (LocatedN RdrName)
cNameN Con
constr
       ; [GenLocated (SrcAnn NoEpAnns) (HsDerivingClause GhcPs)]
derivs' <- [DerivClause] -> CvtM (HsDeriving GhcPs)
cvtDerivs [DerivClause]
derivs
       ; let defn :: HsDataDefn GhcPs
defn = HsDataDefn { dd_ext :: XCHsDataDefn GhcPs
dd_ext = NoExtField
noExtField
                               , dd_cType :: Maybe (XRec GhcPs CType)
dd_cType = forall a. Maybe a
Nothing
                               , dd_ctxt :: Maybe (LHsContext GhcPs)
dd_ctxt = LHsContext GhcPs -> Maybe (LHsContext GhcPs)
mkHsContextMaybe GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
ctxt'
                               , dd_kindSig :: Maybe (LHsType GhcPs)
dd_kindSig = Maybe (GenLocated SrcSpanAnnA (HsType GhcPs))
ksig'
                               , dd_cons :: DataDefnCons (LConDecl GhcPs)
dd_cons = forall a. a -> DataDefnCons a
NewTypeCon GenLocated SrcSpanAnnA (ConDecl GhcPs)
con', dd_derivs :: HsDeriving GhcPs
dd_derivs = [GenLocated (SrcAnn NoEpAnns) (HsDerivingClause GhcPs)]
derivs' }
       ; forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA forall a b. (a -> b) -> a -> b
$ forall p. XInstD p -> InstDecl p -> HsDecl p
InstD NoExtField
noExtField forall a b. (a -> b) -> a -> b
$ DataFamInstD
           { dfid_ext :: XDataFamInstD GhcPs
dfid_ext = NoExtField
noExtField
           , dfid_inst :: DataFamInstDecl GhcPs
dfid_inst = DataFamInstDecl { dfid_eqn :: FamEqn GhcPs (HsDataDefn GhcPs)
dfid_eqn =
                           FamEqn { feqn_ext :: XCFamEqn GhcPs (HsDataDefn GhcPs)
feqn_ext = forall a. EpAnn a
noAnn
                                  , feqn_tycon :: XRec GhcPs (IdP GhcPs)
feqn_tycon = LocatedN RdrName
tc'
                                  , feqn_bndrs :: HsOuterFamEqnTyVarBndrs GhcPs
feqn_bndrs = HsOuterFamEqnTyVarBndrs GhcPs
bndrs'
                                  , feqn_pats :: HsTyPats GhcPs
feqn_pats = [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
typats'
                                  , feqn_rhs :: HsDataDefn GhcPs
feqn_rhs = HsDataDefn GhcPs
defn
                                  , feqn_fixity :: LexicalFixity
feqn_fixity = LexicalFixity
Prefix } }}}

cvtDec (TySynInstD TySynEqn
eqn)
  = do  { (L SrcSpanAnnA
_ FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
eqn') <- TySynEqn -> CvtM (LTyFamInstEqn GhcPs)
cvtTySynEqn TySynEqn
eqn
        ; forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA forall a b. (a -> b) -> a -> b
$ forall p. XInstD p -> InstDecl p -> HsDecl p
InstD NoExtField
noExtField forall a b. (a -> b) -> a -> b
$ TyFamInstD
            { tfid_ext :: XTyFamInstD GhcPs
tfid_ext = NoExtField
noExtField
            , tfid_inst :: TyFamInstDecl GhcPs
tfid_inst = TyFamInstDecl { tfid_xtn :: XCTyFamInstDecl GhcPs
tfid_xtn = forall a. EpAnn a
noAnn, tfid_eqn :: TyFamInstEqn GhcPs
tfid_eqn = FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
eqn' } }}

cvtDec (OpenTypeFamilyD TypeFamilyHead
head)
  = do { (LocatedN RdrName
tc', LHsQTyVars GhcPs
tyvars', GenLocated (SrcAnn NoEpAnns) (FamilyResultSig GhcPs)
result', Maybe (GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcPs))
injectivity') <- TypeFamilyHead
-> CvtM
     (LocatedN RdrName, LHsQTyVars GhcPs, LFamilyResultSig GhcPs,
      Maybe (LInjectivityAnn GhcPs))
cvt_tyfam_head TypeFamilyHead
head
       ; forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA forall a b. (a -> b) -> a -> b
$ forall p. XTyClD p -> TyClDecl p -> HsDecl p
TyClD NoExtField
noExtField forall a b. (a -> b) -> a -> b
$ forall pass. XFamDecl pass -> FamilyDecl pass -> TyClDecl pass
FamDecl NoExtField
noExtField forall a b. (a -> b) -> a -> b
$
         forall pass.
XCFamilyDecl pass
-> FamilyInfo pass
-> TopLevelFlag
-> LIdP pass
-> LHsQTyVars pass
-> LexicalFixity
-> LFamilyResultSig pass
-> Maybe (LInjectivityAnn pass)
-> FamilyDecl pass
FamilyDecl forall a. EpAnn a
noAnn forall pass. FamilyInfo pass
OpenTypeFamily TopLevelFlag
TopLevel LocatedN RdrName
tc' LHsQTyVars GhcPs
tyvars' LexicalFixity
Prefix GenLocated (SrcAnn NoEpAnns) (FamilyResultSig GhcPs)
result' Maybe (GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcPs))
injectivity'
       }

cvtDec (ClosedTypeFamilyD TypeFamilyHead
head [TySynEqn]
eqns)
  = do { (LocatedN RdrName
tc', LHsQTyVars GhcPs
tyvars', GenLocated (SrcAnn NoEpAnns) (FamilyResultSig GhcPs)
result', Maybe (GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcPs))
injectivity') <- TypeFamilyHead
-> CvtM
     (LocatedN RdrName, LHsQTyVars GhcPs, LFamilyResultSig GhcPs,
      Maybe (LInjectivityAnn GhcPs))
cvt_tyfam_head TypeFamilyHead
head
       ; [GenLocated
   SrcSpanAnnA (FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))]
eqns' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TySynEqn -> CvtM (LTyFamInstEqn GhcPs)
cvtTySynEqn [TySynEqn]
eqns
       ; forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA forall a b. (a -> b) -> a -> b
$ forall p. XTyClD p -> TyClDecl p -> HsDecl p
TyClD NoExtField
noExtField forall a b. (a -> b) -> a -> b
$ forall pass. XFamDecl pass -> FamilyDecl pass -> TyClDecl pass
FamDecl NoExtField
noExtField forall a b. (a -> b) -> a -> b
$
         forall pass.
XCFamilyDecl pass
-> FamilyInfo pass
-> TopLevelFlag
-> LIdP pass
-> LHsQTyVars pass
-> LexicalFixity
-> LFamilyResultSig pass
-> Maybe (LInjectivityAnn pass)
-> FamilyDecl pass
FamilyDecl forall a. EpAnn a
noAnn (forall pass. Maybe [LTyFamInstEqn pass] -> FamilyInfo pass
ClosedTypeFamily (forall a. a -> Maybe a
Just [GenLocated
   SrcSpanAnnA (FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))]
eqns')) TopLevelFlag
TopLevel LocatedN RdrName
tc' LHsQTyVars GhcPs
tyvars' LexicalFixity
Prefix
                           GenLocated (SrcAnn NoEpAnns) (FamilyResultSig GhcPs)
result' Maybe (GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcPs))
injectivity' }

cvtDec (TH.RoleAnnotD Name
tc [Role]
roles)
  = do { LocatedN RdrName
tc' <- Name -> CvtM (LocatedN RdrName)
tconNameN Name
tc
       ; [LocatedAn NoEpAnns (Maybe Role)]
roles' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall b c a. (b -> c) -> (a -> b) -> a -> c
. Role -> Maybe Role
cvtRole) [Role]
roles
       ; forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA
                   forall a b. (a -> b) -> a -> b
$ forall p. XRoleAnnotD p -> RoleAnnotDecl p -> HsDecl p
Hs.RoleAnnotD NoExtField
noExtField (forall pass.
XCRoleAnnotDecl pass
-> LIdP pass -> [XRec pass (Maybe Role)] -> RoleAnnotDecl pass
RoleAnnotDecl forall a. EpAnn a
noAnn LocatedN RdrName
tc' [LocatedAn NoEpAnns (Maybe Role)]
roles') }

cvtDec (TH.StandaloneDerivD Maybe DerivStrategy
ds [Type]
cxt Type
ty)
  = do { GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
cxt' <- PprPrec -> [Type] -> CvtM (LHsContext GhcPs)
cvtContext PprPrec
funPrec [Type]
cxt
       ; Maybe (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcPs))
ds'  <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse DerivStrategy -> CvtM (LDerivStrategy GhcPs)
cvtDerivStrategy Maybe DerivStrategy
ds
       ; (L SrcSpanAnnA
loc HsType GhcPs
ty') <- Type -> CvtM (LHsType GhcPs)
cvtType Type
ty
       ; let inst_ty' :: GenLocated SrcSpanAnnA (HsSigType GhcPs)
inst_ty' = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc forall a b. (a -> b) -> a -> b
$ LHsType GhcPs -> HsSigType GhcPs
mkHsImplicitSigType forall a b. (a -> b) -> a -> b
$
                        [Type]
-> SrcSpanAnnA
-> LHsContext GhcPs
-> LHsType GhcPs
-> LHsType GhcPs
mkHsQualTy [Type]
cxt SrcSpanAnnA
loc GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
cxt' forall a b. (a -> b) -> a -> b
$ forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc HsType GhcPs
ty'
       ; forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA forall a b. (a -> b) -> a -> b
$ forall p. XDerivD p -> DerivDecl p -> HsDecl p
DerivD NoExtField
noExtField forall a b. (a -> b) -> a -> b
$
         DerivDecl { deriv_ext :: XCDerivDecl GhcPs
deriv_ext = forall a. EpAnn a
noAnn
                   , deriv_strategy :: Maybe (LDerivStrategy GhcPs)
deriv_strategy = Maybe (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcPs))
ds'
                   , deriv_type :: LHsSigWcType GhcPs
deriv_type = forall thing. thing -> HsWildCardBndrs GhcPs thing
mkHsWildCardBndrs GenLocated SrcSpanAnnA (HsSigType GhcPs)
inst_ty'
                   , deriv_overlap_mode :: Maybe (XRec GhcPs OverlapMode)
deriv_overlap_mode = forall a. Maybe a
Nothing } }

cvtDec (TH.DefaultSigD Name
nm Type
typ)
  = do { LocatedN RdrName
nm' <- Name -> CvtM (LocatedN RdrName)
vNameN Name
nm
       ; GenLocated SrcSpanAnnA (HsSigType GhcPs)
ty' <- Type -> CvtM (LHsSigType GhcPs)
cvtSigType Type
typ
       ; forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA forall a b. (a -> b) -> a -> b
$ forall p. XSigD p -> Sig p -> HsDecl p
Hs.SigD NoExtField
noExtField
                      forall a b. (a -> b) -> a -> b
$ forall pass.
XClassOpSig pass
-> Bool -> [LIdP pass] -> LHsSigType pass -> Sig pass
ClassOpSig forall a. EpAnn a
noAnn Bool
True [LocatedN RdrName
nm'] GenLocated SrcSpanAnnA (HsSigType GhcPs)
ty'}

cvtDec (TH.PatSynD Name
nm PatSynArgs
args PatSynDir
dir Pat
pat)
  = do { LocatedN RdrName
nm'   <- Name -> CvtM (LocatedN RdrName)
cNameN Name
nm
       ; HsConDetails Void (LocatedN RdrName) [RecordPatSynField GhcPs]
args' <- forall {pass}.
(XCFieldOcc pass ~ NoExtField,
 XRec pass (IdP pass) ~ LocatedN RdrName,
 XRec pass RdrName ~ LocatedN RdrName) =>
PatSynArgs
-> CvtM'
     ConversionFailReason
     (HsConDetails Void (LocatedN RdrName) [RecordPatSynField pass])
cvtArgs PatSynArgs
args
       ; HsPatSynDir GhcPs
dir'  <- LocatedN RdrName
-> PatSynDir -> CvtM' ConversionFailReason (HsPatSynDir GhcPs)
cvtDir LocatedN RdrName
nm' PatSynDir
dir
       ; GenLocated SrcSpanAnnA (Pat GhcPs)
pat'  <- Pat -> CvtM (LPat GhcPs)
cvtPat Pat
pat
       ; forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA forall a b. (a -> b) -> a -> b
$ forall p. XValD p -> HsBind p -> HsDecl p
Hs.ValD NoExtField
noExtField forall a b. (a -> b) -> a -> b
$ forall idL idR.
XPatSynBind idL idR -> PatSynBind idL idR -> HsBindLR idL idR
PatSynBind NoExtField
noExtField forall a b. (a -> b) -> a -> b
$
           forall idL idR.
XPSB idL idR
-> LIdP idL
-> HsPatSynDetails idR
-> LPat idR
-> HsPatSynDir idR
-> PatSynBind idL idR
PSB forall a. EpAnn a
noAnn LocatedN RdrName
nm' HsConDetails Void (LocatedN RdrName) [RecordPatSynField GhcPs]
args' GenLocated SrcSpanAnnA (Pat GhcPs)
pat' HsPatSynDir GhcPs
dir' }
  where
    cvtArgs :: PatSynArgs
-> CvtM'
     ConversionFailReason
     (HsConDetails Void (LocatedN RdrName) [RecordPatSynField pass])
cvtArgs (TH.PrefixPatSyn [Name]
args) = forall tyarg arg rec.
[tyarg] -> [arg] -> HsConDetails tyarg arg rec
Hs.PrefixCon [Void]
noTypeArgs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> CvtM (LocatedN RdrName)
vNameN [Name]
args
    cvtArgs (TH.InfixPatSyn Name
a1 Name
a2) = forall tyarg arg rec. arg -> arg -> HsConDetails tyarg arg rec
Hs.InfixCon forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> CvtM (LocatedN RdrName)
vNameN Name
a1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Name -> CvtM (LocatedN RdrName)
vNameN Name
a2
    cvtArgs (TH.RecordPatSyn [Name]
sels)
      = do { [FieldOcc pass]
sels' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ (L SrcSpanAnnN
li RdrName
i) -> forall pass. XCFieldOcc pass -> XRec pass RdrName -> FieldOcc pass
FieldOcc NoExtField
noExtField (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
li RdrName
i)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> CvtM (LocatedN RdrName)
vNameN) [Name]
sels
           ; [LocatedN RdrName]
vars' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Name -> CvtM (LocatedN RdrName)
vNameN forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkNameS forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase) [Name]
sels
           ; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall tyarg arg rec. rec -> HsConDetails tyarg arg rec
Hs.RecCon forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall pass. FieldOcc pass -> LIdP pass -> RecordPatSynField pass
RecordPatSynField [FieldOcc pass]
sels' [LocatedN RdrName]
vars' }

    -- cvtDir :: LocatedN RdrName -> (PatSynDir -> CvtM (HsPatSynDir RdrName))
    cvtDir :: LocatedN RdrName
-> PatSynDir -> CvtM' ConversionFailReason (HsPatSynDir GhcPs)
cvtDir LocatedN RdrName
_ PatSynDir
Unidir          = forall (m :: * -> *) a. Monad m => a -> m a
return forall id. HsPatSynDir id
Unidirectional
    cvtDir LocatedN RdrName
_ PatSynDir
ImplBidir       = forall (m :: * -> *) a. Monad m => a -> m a
return forall id. HsPatSynDir id
ImplicitBidirectional
    cvtDir LocatedN RdrName
n (ExplBidir [Clause]
cls) =
      do { [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
ms <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (HsMatchContext GhcPs
-> Clause -> CvtM (LMatch GhcPs (LHsExpr GhcPs))
cvtClause (forall p. LIdP (NoGhcTc p) -> HsMatchContext p
mkPrefixFunRhs LocatedN RdrName
n)) [Clause]
cls
         ; Origin
th_origin <- CvtM Origin
getOrigin
         ; forall ann a b. (LocatedAn ann a -> b) -> a -> CvtM b
wrapParLA (forall id. MatchGroup id (LHsExpr id) -> HsPatSynDir id
ExplicitBidirectional forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: Pass) (body :: * -> *).
AnnoBody p body =>
Origin
-> LocatedL
     [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]
-> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))
mkMatchGroup Origin
th_origin) [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
ms }

cvtDec (TH.PatSynSigD Name
nm Type
ty)
  = do { LocatedN RdrName
nm' <- Name -> CvtM (LocatedN RdrName)
cNameN Name
nm
       ; GenLocated SrcSpanAnnA (HsSigType GhcPs)
ty' <- Type -> CvtM (LHsSigType GhcPs)
cvtPatSynSigTy Type
ty
       ; forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA forall a b. (a -> b) -> a -> b
$ forall p. XSigD p -> Sig p -> HsDecl p
Hs.SigD NoExtField
noExtField forall a b. (a -> b) -> a -> b
$ forall pass.
XPatSynSig pass -> [LIdP pass] -> LHsSigType pass -> Sig pass
PatSynSig forall a. EpAnn a
noAnn [LocatedN RdrName
nm'] GenLocated SrcSpanAnnA (HsSigType GhcPs)
ty'}

-- Implicit parameter bindings are handled in cvtLocalDecs and
-- cvtImplicitParamBind. They are not allowed in any other scope, so
-- reaching this case indicates an error.
cvtDec (TH.ImplicitParamBindD String
_ Exp
_)
  = forall a. ConversionFailReason -> CvtM a
failWith ConversionFailReason
InvalidImplicitParamBinding

-- Convert a @data@ declaration.
cvtDataDec :: TH.Cxt -> TH.Name -> [TH.TyVarBndr ()]
    -> Maybe TH.Kind -> [TH.Con] -> [TH.DerivClause]
    -> CvtM (Maybe (LHsDecl GhcPs))
cvtDataDec :: [Type]
-> Name
-> [TyVarBndr ()]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> CvtM (Maybe (LHsDecl GhcPs))
cvtDataDec = Bool
-> [Type]
-> Name
-> [TyVarBndr ()]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> CvtM (Maybe (LHsDecl GhcPs))
cvtGenDataDec Bool
False

-- Convert a @type data@ declaration.
-- These have neither contexts nor derived clauses.
-- See Note [Type data declarations] in GHC.Rename.Module.
cvtTypeDataDec :: TH.Name -> [TH.TyVarBndr ()] -> Maybe TH.Kind -> [TH.Con]
    -> CvtM (Maybe (LHsDecl GhcPs))
cvtTypeDataDec :: Name
-> [TyVarBndr ()]
-> Maybe Type
-> [Con]
-> CvtM (Maybe (LHsDecl GhcPs))
cvtTypeDataDec Name
tc [TyVarBndr ()]
tvs Maybe Type
ksig [Con]
constrs
  = Bool
-> [Type]
-> Name
-> [TyVarBndr ()]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> CvtM (Maybe (LHsDecl GhcPs))
cvtGenDataDec Bool
True [] Name
tc [TyVarBndr ()]
tvs Maybe Type
ksig [Con]
constrs []

-- Convert a @data@ or @type data@ declaration (flagged by the Bool arg).
-- See Note [Type data declarations] in GHC.Rename.Module.
cvtGenDataDec :: Bool -> TH.Cxt -> TH.Name -> [TH.TyVarBndr ()]
    -> Maybe TH.Kind -> [TH.Con] -> [TH.DerivClause]
    -> CvtM (Maybe (LHsDecl GhcPs))
cvtGenDataDec :: Bool
-> [Type]
-> Name
-> [TyVarBndr ()]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> CvtM (Maybe (LHsDecl GhcPs))
cvtGenDataDec Bool
type_data [Type]
ctxt Name
tc [TyVarBndr ()]
tvs Maybe Type
ksig [Con]
constrs [DerivClause]
derivs
  = do  { let isGadtCon :: Con -> Bool
isGadtCon (GadtC    [Name]
_ [BangType]
_ Type
_) = Bool
True
              isGadtCon (RecGadtC [Name]
_ [VarBangType]
_ Type
_) = Bool
True
              isGadtCon (ForallC  [TyVarBndr Specificity]
_ [Type]
_ Con
c) = Con -> Bool
isGadtCon Con
c
              isGadtCon Con
_                = Bool
False
              isGadtDecl :: Bool
isGadtDecl  = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Con -> Bool
isGadtCon [Con]
constrs
              isH98Decl :: Bool
isH98Decl   = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Con -> Bool
isGadtCon) [Con]
constrs
              -- A constructor in a @data@ or @newtype@ declaration is
              -- a data constructor.  A constructor in a @type data@
              -- declaration is a type constructor.
              -- See Note [Type data declarations] in GHC.Rename.Module.
              con_name :: Name -> CvtM (LocatedN RdrName)
con_name
                | Bool
type_data = Name -> CvtM (LocatedN RdrName)
tconNameN
                | Bool
otherwise = Name -> CvtM (LocatedN RdrName)
cNameN
        ; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
isGadtDecl Bool -> Bool -> Bool
|| Bool
isH98Decl)
                 (forall a. ConversionFailReason -> CvtM a
failWith ConversionFailReason
CannotMixGADTConsWith98Cons)
        ; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall a. Maybe a -> Bool
isNothing Maybe Type
ksig Bool -> Bool -> Bool
|| Bool
isGadtDecl)
                 (forall a. ConversionFailReason -> CvtM a
failWith ConversionFailReason
KindSigsOnlyAllowedOnGADTs)
        ; (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
ctxt', LocatedN RdrName
tc', LHsQTyVars GhcPs
tvs') <- [Type]
-> Name
-> [TyVarBndr ()]
-> CvtM (LHsContext GhcPs, LocatedN RdrName, LHsQTyVars GhcPs)
cvt_tycl_hdr [Type]
ctxt Name
tc [TyVarBndr ()]
tvs
        ; Maybe (GenLocated SrcSpanAnnA (HsType GhcPs))
ksig' <- Type -> CvtM (LHsType GhcPs)
cvtKind forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
`traverse` Maybe Type
ksig
        ; [GenLocated SrcSpanAnnA (ConDecl GhcPs)]
cons' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Name -> CvtM (LocatedN RdrName)) -> Con -> CvtM (LConDecl GhcPs)
cvtConstr Name -> CvtM (LocatedN RdrName)
con_name) [Con]
constrs
        ; [GenLocated (SrcAnn NoEpAnns) (HsDerivingClause GhcPs)]
derivs' <- [DerivClause] -> CvtM (HsDeriving GhcPs)
cvtDerivs [DerivClause]
derivs
        ; let defn :: HsDataDefn GhcPs
defn = HsDataDefn { dd_ext :: XCHsDataDefn GhcPs
dd_ext = NoExtField
noExtField
                                , dd_cType :: Maybe (XRec GhcPs CType)
dd_cType = forall a. Maybe a
Nothing
                                , dd_ctxt :: Maybe (LHsContext GhcPs)
dd_ctxt = LHsContext GhcPs -> Maybe (LHsContext GhcPs)
mkHsContextMaybe GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
ctxt'
                                , dd_kindSig :: Maybe (LHsType GhcPs)
dd_kindSig = Maybe (GenLocated SrcSpanAnnA (HsType GhcPs))
ksig'
                                , dd_cons :: DataDefnCons (LConDecl GhcPs)
dd_cons = forall a. Bool -> [a] -> DataDefnCons a
DataTypeCons Bool
type_data [GenLocated SrcSpanAnnA (ConDecl GhcPs)]
cons'
                                , dd_derivs :: HsDeriving GhcPs
dd_derivs = [GenLocated (SrcAnn NoEpAnns) (HsDerivingClause GhcPs)]
derivs' }
        ; forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA forall a b. (a -> b) -> a -> b
$ forall p. XTyClD p -> TyClDecl p -> HsDecl p
TyClD NoExtField
noExtField forall a b. (a -> b) -> a -> b
$
          DataDecl { tcdDExt :: XDataDecl GhcPs
tcdDExt = forall a. EpAnn a
noAnn
                   , tcdLName :: XRec GhcPs (IdP GhcPs)
tcdLName = LocatedN RdrName
tc', tcdTyVars :: LHsQTyVars GhcPs
tcdTyVars = LHsQTyVars GhcPs
tvs'
                   , tcdFixity :: LexicalFixity
tcdFixity = LexicalFixity
Prefix
                   , tcdDataDefn :: HsDataDefn GhcPs
tcdDataDefn = HsDataDefn GhcPs
defn } }

----------------
cvtTySynEqn :: TySynEqn -> CvtM (LTyFamInstEqn GhcPs)
cvtTySynEqn :: TySynEqn -> CvtM (LTyFamInstEqn GhcPs)
cvtTySynEqn (TySynEqn Maybe [TyVarBndr ()]
mb_bndrs Type
lhs Type
rhs)
  = do { Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)]
mb_bndrs' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall flag flag'.
CvtFlag flag flag' =>
TyVarBndr flag -> CvtM (LHsTyVarBndr flag' GhcPs)
cvt_tv) Maybe [TyVarBndr ()]
mb_bndrs
       ; let outer_bndrs :: HsOuterFamEqnTyVarBndrs GhcPs
outer_bndrs = Maybe [LHsTyVarBndr () GhcPs] -> HsOuterFamEqnTyVarBndrs GhcPs
mkHsOuterFamEqnTyVarBndrs Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)]
mb_bndrs'
       ; (Type
head_ty, [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
args) <- Type -> CvtM (Type, HsTyPats GhcPs)
split_ty_app Type
lhs
       ; case Type
head_ty of
           ConT Name
nm -> do { LocatedN RdrName
nm' <- Name -> CvtM (LocatedN RdrName)
tconNameN Name
nm
                         ; GenLocated SrcSpanAnnA (HsType GhcPs)
rhs' <- Type -> CvtM (LHsType GhcPs)
cvtType Type
rhs
                         ; let args' :: [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
args' = forall a b. (a -> b) -> [a] -> [b]
map LHsTypeArg GhcPs -> LHsTypeArg GhcPs
wrap_tyarg [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
args
                         ; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA
                            forall a b. (a -> b) -> a -> b
$ FamEqn { feqn_ext :: XCFamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
feqn_ext    = forall a. EpAnn a
noAnn
                                     , feqn_tycon :: XRec GhcPs (IdP GhcPs)
feqn_tycon  = LocatedN RdrName
nm'
                                     , feqn_bndrs :: HsOuterFamEqnTyVarBndrs GhcPs
feqn_bndrs  = HsOuterFamEqnTyVarBndrs GhcPs
outer_bndrs
                                     , feqn_pats :: HsTyPats GhcPs
feqn_pats   = [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
args'
                                     , feqn_fixity :: LexicalFixity
feqn_fixity = LexicalFixity
Prefix
                                     , feqn_rhs :: GenLocated SrcSpanAnnA (HsType GhcPs)
feqn_rhs    = GenLocated SrcSpanAnnA (HsType GhcPs)
rhs' } }
           InfixT Type
t1 Name
nm Type
t2 -> do { LocatedN RdrName
nm' <- Name -> CvtM (LocatedN RdrName)
tconNameN Name
nm
                                 ; [GenLocated SrcSpanAnnA (HsType GhcPs)]
args' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> CvtM (LHsType GhcPs)
cvtType [Type
t1,Type
t2]
                                 ; GenLocated SrcSpanAnnA (HsType GhcPs)
rhs' <- Type -> CvtM (LHsType GhcPs)
cvtType Type
rhs
                                 ; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA
                                      forall a b. (a -> b) -> a -> b
$ FamEqn { feqn_ext :: XCFamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
feqn_ext    = forall a. EpAnn a
noAnn
                                               , feqn_tycon :: XRec GhcPs (IdP GhcPs)
feqn_tycon  = LocatedN RdrName
nm'
                                               , feqn_bndrs :: HsOuterFamEqnTyVarBndrs GhcPs
feqn_bndrs  = HsOuterFamEqnTyVarBndrs GhcPs
outer_bndrs
                                               , feqn_pats :: HsTyPats GhcPs
feqn_pats   =
                                                (forall a b. (a -> b) -> [a] -> [b]
map forall tm ty. tm -> HsArg tm ty
HsValArg [GenLocated SrcSpanAnnA (HsType GhcPs)]
args') forall a. [a] -> [a] -> [a]
++ [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
args
                                               , feqn_fixity :: LexicalFixity
feqn_fixity = LexicalFixity
Hs.Infix
                                               , feqn_rhs :: GenLocated SrcSpanAnnA (HsType GhcPs)
feqn_rhs    = GenLocated SrcSpanAnnA (HsType GhcPs)
rhs' } }
           Type
_ -> forall a. ConversionFailReason -> CvtM a
failWith forall a b. (a -> b) -> a -> b
$ Type -> ConversionFailReason
InvalidTyFamInstLHS Type
lhs
        }

----------------
cvt_ci_decs :: THDeclDescriptor -> [TH.Dec]
            -> CvtM (LHsBinds GhcPs,
                     [LSig GhcPs],
                     [LFamilyDecl GhcPs],
                     [LTyFamInstDecl GhcPs],
                     [LDataFamInstDecl GhcPs])
-- Convert the declarations inside a class or instance decl
-- ie signatures, bindings, and associated types
cvt_ci_decs :: THDeclDescriptor
-> [Dec]
-> CvtM
     (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],
      [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs])
cvt_ci_decs THDeclDescriptor
declDescr [Dec]
decs
  = do  { [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
decs' <- [Dec] -> CvtM [LHsDecl GhcPs]
cvtDecs [Dec]
decs
        ; let ([GenLocated SrcSpanAnnA (TyFamInstDecl GhcPs)]
ats', [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
bind_sig_decs') = forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
partitionWith LHsDecl GhcPs -> Either (LTyFamInstDecl GhcPs) (LHsDecl GhcPs)
is_tyfam_inst [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
decs'
        ; let ([GenLocated SrcSpanAnnA (DataFamInstDecl GhcPs)]
adts', [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
no_ats')       = forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
partitionWith LHsDecl GhcPs -> Either (LDataFamInstDecl GhcPs) (LHsDecl GhcPs)
is_datafam_inst [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
bind_sig_decs'
        ; let ([GenLocated SrcSpanAnnA (Sig GhcPs)]
sigs', [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
prob_binds')   = forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
partitionWith LHsDecl GhcPs -> Either (LSig GhcPs) (LHsDecl GhcPs)
is_sig [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
no_ats'
        ; let ([GenLocated SrcSpanAnnA (HsBind GhcPs)]
binds', [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
prob_fams')   = forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
partitionWith LHsDecl GhcPs -> Either (LHsBind GhcPs) (LHsDecl GhcPs)
is_bind [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
prob_binds'
        ; let ([GenLocated SrcSpanAnnA (FamilyDecl GhcPs)]
fams', [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
bads)          = forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
partitionWith LHsDecl GhcPs -> Either (LFamilyDecl GhcPs) (LHsDecl GhcPs)
is_fam_decl [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
prob_fams'
        ; forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
bads) forall a b. (a -> b) -> a -> b
$ \ NonEmpty (GenLocated SrcSpanAnnA (HsDecl GhcPs))
bad_decls ->
            forall a. ConversionFailReason -> CvtM a
failWith (THDeclDescriptor -> IllegalDecls -> ConversionFailReason
IllegalDeclaration THDeclDescriptor
declDescr forall a b. (a -> b) -> a -> b
$ NonEmpty (LHsDecl GhcPs) -> IllegalDecls
IllegalDecls NonEmpty (GenLocated SrcSpanAnnA (HsDecl GhcPs))
bad_decls)
        ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> Bag a
listToBag [GenLocated SrcSpanAnnA (HsBind GhcPs)]
binds', [GenLocated SrcSpanAnnA (Sig GhcPs)]
sigs', [GenLocated SrcSpanAnnA (FamilyDecl GhcPs)]
fams', [GenLocated SrcSpanAnnA (TyFamInstDecl GhcPs)]
ats', [GenLocated SrcSpanAnnA (DataFamInstDecl GhcPs)]
adts') }

----------------
cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr ()]
             -> CvtM ( LHsContext GhcPs
                     , LocatedN RdrName
                     , LHsQTyVars GhcPs)
cvt_tycl_hdr :: [Type]
-> Name
-> [TyVarBndr ()]
-> CvtM (LHsContext GhcPs, LocatedN RdrName, LHsQTyVars GhcPs)
cvt_tycl_hdr [Type]
cxt Name
tc [TyVarBndr ()]
tvs
  = do { GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
cxt' <- PprPrec -> [Type] -> CvtM (LHsContext GhcPs)
cvtContext PprPrec
funPrec [Type]
cxt
       ; LocatedN RdrName
tc'  <- Name -> CvtM (LocatedN RdrName)
tconNameN Name
tc
       ; [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)]
tvs' <- forall flag flag'.
CvtFlag flag flag' =>
[TyVarBndr flag] -> CvtM [LHsTyVarBndr flag' GhcPs]
cvtTvs [TyVarBndr ()]
tvs
       ; forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
cxt', LocatedN RdrName
tc', [LHsTyVarBndr () GhcPs] -> LHsQTyVars GhcPs
mkHsQTvs [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)]
tvs')
       }

cvt_datainst_hdr :: TH.Cxt -> Maybe [TH.TyVarBndr ()] -> TH.Type
               -> CvtM ( LHsContext GhcPs
                       , LocatedN RdrName
                       , HsOuterFamEqnTyVarBndrs GhcPs
                       , HsTyPats GhcPs)
cvt_datainst_hdr :: [Type]
-> Maybe [TyVarBndr ()]
-> Type
-> CvtM
     (LHsContext GhcPs, LocatedN RdrName, HsOuterFamEqnTyVarBndrs GhcPs,
      HsTyPats GhcPs)
cvt_datainst_hdr [Type]
cxt Maybe [TyVarBndr ()]
bndrs Type
tys
  = do { GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
cxt' <- PprPrec -> [Type] -> CvtM (LHsContext GhcPs)
cvtContext PprPrec
funPrec [Type]
cxt
       ; Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)]
bndrs' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall flag flag'.
CvtFlag flag flag' =>
TyVarBndr flag -> CvtM (LHsTyVarBndr flag' GhcPs)
cvt_tv) Maybe [TyVarBndr ()]
bndrs
       ; let outer_bndrs :: HsOuterFamEqnTyVarBndrs GhcPs
outer_bndrs = Maybe [LHsTyVarBndr () GhcPs] -> HsOuterFamEqnTyVarBndrs GhcPs
mkHsOuterFamEqnTyVarBndrs Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)]
bndrs'
       ; (Type
head_ty, [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
args) <- Type -> CvtM (Type, HsTyPats GhcPs)
split_ty_app Type
tys
       ; case Type
head_ty of
          ConT Name
nm -> do { LocatedN RdrName
nm' <- Name -> CvtM (LocatedN RdrName)
tconNameN Name
nm
                        ; let args' :: [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
args' = forall a b. (a -> b) -> [a] -> [b]
map LHsTypeArg GhcPs -> LHsTypeArg GhcPs
wrap_tyarg [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
args
                        ; forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
cxt', LocatedN RdrName
nm', HsOuterFamEqnTyVarBndrs GhcPs
outer_bndrs, [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
args') }
          InfixT Type
t1 Name
nm Type
t2 -> do { LocatedN RdrName
nm' <- Name -> CvtM (LocatedN RdrName)
tconNameN Name
nm
                                ; [GenLocated SrcSpanAnnA (HsType GhcPs)]
args' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> CvtM (LHsType GhcPs)
cvtType [Type
t1,Type
t2]
                                ; forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
cxt', LocatedN RdrName
nm', HsOuterFamEqnTyVarBndrs GhcPs
outer_bndrs,
                                         ((forall a b. (a -> b) -> [a] -> [b]
map forall tm ty. tm -> HsArg tm ty
HsValArg [GenLocated SrcSpanAnnA (HsType GhcPs)]
args') forall a. [a] -> [a] -> [a]
++ [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
args)) }
          Type
_ -> forall a. ConversionFailReason -> CvtM a
failWith forall a b. (a -> b) -> a -> b
$ Type -> ConversionFailReason
InvalidTypeInstanceHeader Type
tys }

----------------
cvt_tyfam_head :: TypeFamilyHead
               -> CvtM ( LocatedN RdrName
                       , LHsQTyVars GhcPs
                       , Hs.LFamilyResultSig GhcPs
                       , Maybe (Hs.LInjectivityAnn GhcPs))

cvt_tyfam_head :: TypeFamilyHead
-> CvtM
     (LocatedN RdrName, LHsQTyVars GhcPs, LFamilyResultSig GhcPs,
      Maybe (LInjectivityAnn GhcPs))
cvt_tyfam_head (TypeFamilyHead Name
tc [TyVarBndr ()]
tyvars FamilyResultSig
result Maybe InjectivityAnn
injectivity)
  = do { (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
_, LocatedN RdrName
tc', LHsQTyVars GhcPs
tyvars') <- [Type]
-> Name
-> [TyVarBndr ()]
-> CvtM (LHsContext GhcPs, LocatedN RdrName, LHsQTyVars GhcPs)
cvt_tycl_hdr [] Name
tc [TyVarBndr ()]
tyvars
       ; GenLocated (SrcAnn NoEpAnns) (FamilyResultSig GhcPs)
result' <- FamilyResultSig -> CvtM (LFamilyResultSig GhcPs)
cvtFamilyResultSig FamilyResultSig
result
       ; Maybe (GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcPs))
injectivity' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse InjectivityAnn -> CvtM (LInjectivityAnn GhcPs)
cvtInjectivityAnnotation Maybe InjectivityAnn
injectivity
       ; forall (m :: * -> *) a. Monad m => a -> m a
return (LocatedN RdrName
tc', LHsQTyVars GhcPs
tyvars', GenLocated (SrcAnn NoEpAnns) (FamilyResultSig GhcPs)
result', Maybe (GenLocated (SrcAnn NoEpAnns) (InjectivityAnn GhcPs))
injectivity') }

-------------------------------------------------------------------
--              Partitioning declarations
-------------------------------------------------------------------

is_fam_decl :: LHsDecl GhcPs -> Either (LFamilyDecl GhcPs) (LHsDecl GhcPs)
is_fam_decl :: LHsDecl GhcPs -> Either (LFamilyDecl GhcPs) (LHsDecl GhcPs)
is_fam_decl (L SrcSpanAnnA
loc (TyClD XTyClD GhcPs
_ (FamDecl { tcdFam :: forall pass. TyClDecl pass -> FamilyDecl pass
tcdFam = FamilyDecl GhcPs
d }))) = forall a b. a -> Either a b
Left (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc FamilyDecl GhcPs
d)
is_fam_decl LHsDecl GhcPs
decl = forall a b. b -> Either a b
Right LHsDecl GhcPs
decl

is_tyfam_inst :: LHsDecl GhcPs -> Either (LTyFamInstDecl GhcPs) (LHsDecl GhcPs)
is_tyfam_inst :: LHsDecl GhcPs -> Either (LTyFamInstDecl GhcPs) (LHsDecl GhcPs)
is_tyfam_inst (L SrcSpanAnnA
loc (Hs.InstD XInstD GhcPs
_ (TyFamInstD { tfid_inst :: forall pass. InstDecl pass -> TyFamInstDecl pass
tfid_inst = TyFamInstDecl GhcPs
d })))
  = forall a b. a -> Either a b
Left (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc TyFamInstDecl GhcPs
d)
is_tyfam_inst LHsDecl GhcPs
decl
  = forall a b. b -> Either a b
Right LHsDecl GhcPs
decl

is_datafam_inst :: LHsDecl GhcPs
                -> Either (LDataFamInstDecl GhcPs) (LHsDecl GhcPs)
is_datafam_inst :: LHsDecl GhcPs -> Either (LDataFamInstDecl GhcPs) (LHsDecl GhcPs)
is_datafam_inst (L SrcSpanAnnA
loc (Hs.InstD  XInstD GhcPs
_ (DataFamInstD { dfid_inst :: forall pass. InstDecl pass -> DataFamInstDecl pass
dfid_inst = DataFamInstDecl GhcPs
d })))
  = forall a b. a -> Either a b
Left (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc DataFamInstDecl GhcPs
d)
is_datafam_inst LHsDecl GhcPs
decl
  = forall a b. b -> Either a b
Right LHsDecl GhcPs
decl

is_sig :: LHsDecl GhcPs -> Either (LSig GhcPs) (LHsDecl GhcPs)
is_sig :: LHsDecl GhcPs -> Either (LSig GhcPs) (LHsDecl GhcPs)
is_sig (L SrcSpanAnnA
loc (Hs.SigD XSigD GhcPs
_ Sig GhcPs
sig)) = forall a b. a -> Either a b
Left (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc Sig GhcPs
sig)
is_sig LHsDecl GhcPs
decl                    = forall a b. b -> Either a b
Right LHsDecl GhcPs
decl

is_bind :: LHsDecl GhcPs -> Either (LHsBind GhcPs) (LHsDecl GhcPs)
is_bind :: LHsDecl GhcPs -> Either (LHsBind GhcPs) (LHsDecl GhcPs)
is_bind (L SrcSpanAnnA
loc (Hs.ValD XValD GhcPs
_ HsBind GhcPs
bind)) = forall a b. a -> Either a b
Left (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc HsBind GhcPs
bind)
is_bind LHsDecl GhcPs
decl                     = forall a b. b -> Either a b
Right LHsDecl GhcPs
decl

is_ip_bind :: TH.Dec -> Either (String, TH.Exp) TH.Dec
is_ip_bind :: Dec -> Either (String, Exp) Dec
is_ip_bind (TH.ImplicitParamBindD String
n Exp
e) = forall a b. a -> Either a b
Left (String
n, Exp
e)
is_ip_bind Dec
decl             = forall a b. b -> Either a b
Right Dec
decl

---------------------------------------------------
--      Data types
---------------------------------------------------

cvtConstr :: (TH.Name -> CvtM (LocatedN RdrName)) -- ^ convert constructor name
    -> TH.Con -> CvtM (LConDecl GhcPs)

cvtConstr :: (Name -> CvtM (LocatedN RdrName)) -> Con -> CvtM (LConDecl GhcPs)
cvtConstr Name -> CvtM (LocatedN RdrName)
con_name (NormalC Name
c [BangType]
strtys)
  = do  { LocatedN RdrName
c'   <- Name -> CvtM (LocatedN RdrName)
con_name Name
c
        ; [GenLocated SrcSpanAnnA (HsType GhcPs)]
tys' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM BangType -> CvtM (LHsType GhcPs)
cvt_arg [BangType]
strtys
        ; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ EpAnn [AddEpAnn]
-> LocatedN RdrName
-> Maybe [LHsTyVarBndr Specificity GhcPs]
-> Maybe (LHsContext GhcPs)
-> HsConDeclH98Details GhcPs
-> ConDecl GhcPs
mkConDeclH98 forall a. EpAnn a
noAnn LocatedN RdrName
c' forall a. Maybe a
Nothing forall a. Maybe a
Nothing (forall tyarg arg rec.
[tyarg] -> [arg] -> HsConDetails tyarg arg rec
PrefixCon [Void]
noTypeArgs (forall a b. (a -> b) -> [a] -> [b]
map forall a (p :: Pass). a -> HsScaled (GhcPass p) a
hsLinear [GenLocated SrcSpanAnnA (HsType GhcPs)]
tys')) }

cvtConstr Name -> CvtM (LocatedN RdrName)
con_name (RecC Name
c [VarBangType]
varstrtys)
  = do  { LocatedN RdrName
c'    <- Name -> CvtM (LocatedN RdrName)
con_name Name
c
        ; [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
args' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM VarBangType -> CvtM (LConDeclField GhcPs)
cvt_id_arg [VarBangType]
varstrtys
        ; ConDecl GhcPs
con_decl <- forall ann a b. (LocatedAn ann a -> b) -> a -> CvtM b
wrapParLA (EpAnn [AddEpAnn]
-> LocatedN RdrName
-> Maybe [LHsTyVarBndr Specificity GhcPs]
-> Maybe (LHsContext GhcPs)
-> HsConDeclH98Details GhcPs
-> ConDecl GhcPs
mkConDeclH98 forall a. EpAnn a
noAnn LocatedN RdrName
c' forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall tyarg arg rec. rec -> HsConDetails tyarg arg rec
RecCon) [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
args'
        ; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA ConDecl GhcPs
con_decl }

cvtConstr Name -> CvtM (LocatedN RdrName)
con_name (InfixC BangType
st1 Name
c BangType
st2)
  = do  { LocatedN RdrName
c'   <- Name -> CvtM (LocatedN RdrName)
con_name Name
c
        ; GenLocated SrcSpanAnnA (HsType GhcPs)
st1' <- BangType -> CvtM (LHsType GhcPs)
cvt_arg BangType
st1
        ; GenLocated SrcSpanAnnA (HsType GhcPs)
st2' <- BangType -> CvtM (LHsType GhcPs)
cvt_arg BangType
st2
        ; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ EpAnn [AddEpAnn]
-> LocatedN RdrName
-> Maybe [LHsTyVarBndr Specificity GhcPs]
-> Maybe (LHsContext GhcPs)
-> HsConDeclH98Details GhcPs
-> ConDecl GhcPs
mkConDeclH98 forall a. EpAnn a
noAnn LocatedN RdrName
c' forall a. Maybe a
Nothing forall a. Maybe a
Nothing
                       (forall tyarg arg rec. arg -> arg -> HsConDetails tyarg arg rec
InfixCon (forall a (p :: Pass). a -> HsScaled (GhcPass p) a
hsLinear GenLocated SrcSpanAnnA (HsType GhcPs)
st1') (forall a (p :: Pass). a -> HsScaled (GhcPass p) a
hsLinear GenLocated SrcSpanAnnA (HsType GhcPs)
st2')) }

cvtConstr Name -> CvtM (LocatedN RdrName)
con_name (ForallC [TyVarBndr Specificity]
tvs [Type]
ctxt Con
con)
  = do  { [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)]
tvs'      <- forall flag flag'.
CvtFlag flag flag' =>
[TyVarBndr flag] -> CvtM [LHsTyVarBndr flag' GhcPs]
cvtTvs [TyVarBndr Specificity]
tvs
        ; GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
ctxt'     <- PprPrec -> [Type] -> CvtM (LHsContext GhcPs)
cvtContext PprPrec
funPrec [Type]
ctxt
        ; L SrcSpanAnnA
_ ConDecl GhcPs
con'  <- (Name -> CvtM (LocatedN RdrName)) -> Con -> CvtM (LConDecl GhcPs)
cvtConstr Name -> CvtM (LocatedN RdrName)
con_name Con
con
        ; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ [LHsTyVarBndr Specificity GhcPs]
-> LHsContext GhcPs -> ConDecl GhcPs -> ConDecl GhcPs
add_forall [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)]
tvs' GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
ctxt' ConDecl GhcPs
con' }
  where
    add_cxt :: GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> Maybe (GenLocated l [GenLocated SrcSpanAnnA (HsType GhcPs)])
-> Maybe (LHsContext GhcPs)
add_cxt GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
lcxt         Maybe (GenLocated l [GenLocated SrcSpanAnnA (HsType GhcPs)])
Nothing           = LHsContext GhcPs -> Maybe (LHsContext GhcPs)
mkHsContextMaybe GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
lcxt
    add_cxt (L SrcSpanAnnC
loc [GenLocated SrcSpanAnnA (HsType GhcPs)]
cxt1) (Just (L l
_ [GenLocated SrcSpanAnnA (HsType GhcPs)]
cxt2))
      = forall a. a -> Maybe a
Just (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnC
loc ([GenLocated SrcSpanAnnA (HsType GhcPs)]
cxt1 forall a. [a] -> [a] -> [a]
++ [GenLocated SrcSpanAnnA (HsType GhcPs)]
cxt2))

    add_forall :: [LHsTyVarBndr Hs.Specificity GhcPs] -> LHsContext GhcPs
               -> ConDecl GhcPs -> ConDecl GhcPs
    add_forall :: [LHsTyVarBndr Specificity GhcPs]
-> LHsContext GhcPs -> ConDecl GhcPs -> ConDecl GhcPs
add_forall [LHsTyVarBndr Specificity GhcPs]
tvs' LHsContext GhcPs
cxt' con :: ConDecl GhcPs
con@(ConDeclGADT { con_bndrs :: forall pass. ConDecl pass -> XRec pass (HsOuterSigTyVarBndrs pass)
con_bndrs = L SrcSpanAnnA
l HsOuterTyVarBndrs Specificity GhcPs
outer_bndrs, con_mb_cxt :: forall pass. ConDecl pass -> Maybe (LHsContext pass)
con_mb_cxt = Maybe (LHsContext GhcPs)
cxt })
      = ConDecl GhcPs
con { con_bndrs :: XRec GhcPs (HsOuterTyVarBndrs Specificity GhcPs)
con_bndrs  = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l HsOuterTyVarBndrs Specificity GhcPs
outer_bndrs'
            , con_mb_cxt :: Maybe (LHsContext GhcPs)
con_mb_cxt = forall {l}.
GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> Maybe (GenLocated l [GenLocated SrcSpanAnnA (HsType GhcPs)])
-> Maybe
     (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)])
add_cxt LHsContext GhcPs
cxt' Maybe (LHsContext GhcPs)
cxt }
      where
        outer_bndrs' :: HsOuterTyVarBndrs Specificity GhcPs
outer_bndrs'
          | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)]
all_tvs = forall flag. HsOuterTyVarBndrs flag GhcPs
mkHsOuterImplicit
          | Bool
otherwise    = forall flag.
EpAnnForallTy
-> [LHsTyVarBndr flag GhcPs] -> HsOuterTyVarBndrs flag GhcPs
mkHsOuterExplicit forall a. EpAnn a
noAnn [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)]
all_tvs

        all_tvs :: [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)]
all_tvs = [LHsTyVarBndr Specificity GhcPs]
tvs' forall a. [a] -> [a] -> [a]
++ [LHsTyVarBndr Specificity (NoGhcTc GhcPs)]
outer_exp_tvs

        outer_exp_tvs :: [LHsTyVarBndr Specificity (NoGhcTc GhcPs)]
outer_exp_tvs = forall flag (p :: Pass).
HsOuterTyVarBndrs flag (GhcPass p)
-> [LHsTyVarBndr flag (NoGhcTc (GhcPass p))]
hsOuterExplicitBndrs HsOuterTyVarBndrs Specificity GhcPs
outer_bndrs

    add_forall [LHsTyVarBndr Specificity GhcPs]
tvs' LHsContext GhcPs
cxt' con :: ConDecl GhcPs
con@(ConDeclH98 { con_ex_tvs :: forall pass. ConDecl pass -> [LHsTyVarBndr Specificity pass]
con_ex_tvs = [LHsTyVarBndr Specificity GhcPs]
ex_tvs, con_mb_cxt :: forall pass. ConDecl pass -> Maybe (LHsContext pass)
con_mb_cxt = Maybe (LHsContext GhcPs)
cxt })
      = ConDecl GhcPs
con { con_forall :: Bool
con_forall = Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)]
all_tvs)
            , con_ex_tvs :: [LHsTyVarBndr Specificity GhcPs]
con_ex_tvs = [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)]
all_tvs
            , con_mb_cxt :: Maybe (LHsContext GhcPs)
con_mb_cxt = forall {l}.
GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> Maybe (GenLocated l [GenLocated SrcSpanAnnA (HsType GhcPs)])
-> Maybe
     (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)])
add_cxt LHsContext GhcPs
cxt' Maybe (LHsContext GhcPs)
cxt }
      where
        all_tvs :: [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)]
all_tvs = [LHsTyVarBndr Specificity GhcPs]
tvs' forall a. [a] -> [a] -> [a]
++ [LHsTyVarBndr Specificity GhcPs]
ex_tvs

cvtConstr Name -> CvtM (LocatedN RdrName)
con_name (GadtC [Name]
c [BangType]
strtys Type
ty) = case forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [Name]
c of
    Maybe (NonEmpty Name)
Nothing -> forall a. ConversionFailReason -> CvtM a
failWith ConversionFailReason
GadtNoCons
    Just NonEmpty Name
c -> do
        { NonEmpty (LocatedN RdrName)
c'      <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> CvtM (LocatedN RdrName)
con_name NonEmpty Name
c
        ; [GenLocated SrcSpanAnnA (HsType GhcPs)]
args    <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM BangType -> CvtM (LHsType GhcPs)
cvt_arg [BangType]
strtys
        ; GenLocated SrcSpanAnnA (HsType GhcPs)
ty'     <- Type -> CvtM (LHsType GhcPs)
cvtType Type
ty
        ; NonEmpty (LocatedN RdrName)
-> HsConDeclGADTDetails GhcPs
-> LHsType GhcPs
-> CvtM (LConDecl GhcPs)
mk_gadt_decl NonEmpty (LocatedN RdrName)
c' (forall pass.
[HsScaled pass (LBangType pass)] -> HsConDeclGADTDetails pass
PrefixConGADT forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a (p :: Pass). a -> HsScaled (GhcPass p) a
hsLinear [GenLocated SrcSpanAnnA (HsType GhcPs)]
args) GenLocated SrcSpanAnnA (HsType GhcPs)
ty'}

cvtConstr Name -> CvtM (LocatedN RdrName)
con_name (RecGadtC [Name]
c [VarBangType]
varstrtys Type
ty) = case forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [Name]
c of
    Maybe (NonEmpty Name)
Nothing -> forall a. ConversionFailReason -> CvtM a
failWith ConversionFailReason
RecGadtNoCons
    Just NonEmpty Name
c -> do
        { NonEmpty (LocatedN RdrName)
c'       <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> CvtM (LocatedN RdrName)
con_name NonEmpty Name
c
        ; GenLocated SrcSpanAnnA (HsType GhcPs)
ty'      <- Type -> CvtM (LHsType GhcPs)
cvtType Type
ty
        ; [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
rec_flds <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM VarBangType -> CvtM (LConDeclField GhcPs)
cvt_id_arg [VarBangType]
varstrtys
        ; LocatedAn AnnList [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
lrec_flds <- forall e ann. e -> CvtM (LocatedAn ann e)
returnLA [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
rec_flds
        ; NonEmpty (LocatedN RdrName)
-> HsConDeclGADTDetails GhcPs
-> LHsType GhcPs
-> CvtM (LConDecl GhcPs)
mk_gadt_decl NonEmpty (LocatedN RdrName)
c' (forall pass.
XRec pass [LConDeclField pass]
-> LHsUniToken "->" "\8594" pass -> HsConDeclGADTDetails pass
RecConGADT LocatedAn AnnList [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
lrec_flds forall (tok :: Symbol) (utok :: Symbol).
GenLocated TokenLocation (HsUniToken tok utok)
noHsUniTok) GenLocated SrcSpanAnnA (HsType GhcPs)
ty' }

mk_gadt_decl :: NonEmpty (LocatedN RdrName) -> HsConDeclGADTDetails GhcPs -> LHsType GhcPs
             -> CvtM (LConDecl GhcPs)
mk_gadt_decl :: NonEmpty (LocatedN RdrName)
-> HsConDeclGADTDetails GhcPs
-> LHsType GhcPs
-> CvtM (LConDecl GhcPs)
mk_gadt_decl NonEmpty (LocatedN RdrName)
names HsConDeclGADTDetails GhcPs
args LHsType GhcPs
res_ty
  = do GenLocated SrcSpanAnnA (HsOuterTyVarBndrs Specificity GhcPs)
bndrs <- forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall flag. HsOuterTyVarBndrs flag GhcPs
mkHsOuterImplicit
       forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ ConDeclGADT
                   { con_g_ext :: XConDeclGADT GhcPs
con_g_ext  = forall a. EpAnn a
noAnn
                   , con_names :: NonEmpty (XRec GhcPs (IdP GhcPs))
con_names  = NonEmpty (LocatedN RdrName)
names
                   , con_dcolon :: LHsUniToken "::" "\8759" GhcPs
con_dcolon = forall (tok :: Symbol) (utok :: Symbol).
GenLocated TokenLocation (HsUniToken tok utok)
noHsUniTok
                   , con_bndrs :: XRec GhcPs (HsOuterTyVarBndrs Specificity GhcPs)
con_bndrs  = GenLocated SrcSpanAnnA (HsOuterTyVarBndrs Specificity GhcPs)
bndrs
                   , con_mb_cxt :: Maybe (LHsContext GhcPs)
con_mb_cxt = forall a. Maybe a
Nothing
                   , con_g_args :: HsConDeclGADTDetails GhcPs
con_g_args = HsConDeclGADTDetails GhcPs
args
                   , con_res_ty :: LHsType GhcPs
con_res_ty = LHsType GhcPs
res_ty
                   , con_doc :: Maybe (LHsDoc GhcPs)
con_doc    = forall a. Maybe a
Nothing }

cvtSrcUnpackedness :: TH.SourceUnpackedness -> SrcUnpackedness
cvtSrcUnpackedness :: SourceUnpackedness -> SrcUnpackedness
cvtSrcUnpackedness SourceUnpackedness
NoSourceUnpackedness = SrcUnpackedness
NoSrcUnpack
cvtSrcUnpackedness SourceUnpackedness
SourceNoUnpack       = SrcUnpackedness
SrcNoUnpack
cvtSrcUnpackedness SourceUnpackedness
SourceUnpack         = SrcUnpackedness
SrcUnpack

cvtSrcStrictness :: TH.SourceStrictness -> SrcStrictness
cvtSrcStrictness :: SourceStrictness -> SrcStrictness
cvtSrcStrictness SourceStrictness
NoSourceStrictness = SrcStrictness
NoSrcStrict
cvtSrcStrictness SourceStrictness
SourceLazy         = SrcStrictness
SrcLazy
cvtSrcStrictness SourceStrictness
SourceStrict       = SrcStrictness
SrcStrict

cvt_arg :: (TH.Bang, TH.Type) -> CvtM (LHsType GhcPs)
cvt_arg :: BangType -> CvtM (LHsType GhcPs)
cvt_arg (Bang SourceUnpackedness
su SourceStrictness
ss, Type
ty)
  = do { GenLocated SrcSpanAnnA (HsType GhcPs)
ty'' <- Type -> CvtM (LHsType GhcPs)
cvtType Type
ty
       ; let ty' :: LHsType GhcPs
ty' = forall (p :: Pass).
PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)
parenthesizeHsType PprPrec
appPrec GenLocated SrcSpanAnnA (HsType GhcPs)
ty''
             su' :: SrcUnpackedness
su' = SourceUnpackedness -> SrcUnpackedness
cvtSrcUnpackedness SourceUnpackedness
su
             ss' :: SrcStrictness
ss' = SourceStrictness -> SrcStrictness
cvtSrcStrictness SourceStrictness
ss
       ; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ forall pass.
XBangTy pass -> HsSrcBang -> LHsType pass -> HsType pass
HsBangTy forall a. EpAnn a
noAnn (SourceText -> SrcUnpackedness -> SrcStrictness -> HsSrcBang
HsSrcBang SourceText
NoSourceText SrcUnpackedness
su' SrcStrictness
ss') LHsType GhcPs
ty' }

cvt_id_arg :: (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField GhcPs)
cvt_id_arg :: VarBangType -> CvtM (LConDeclField GhcPs)
cvt_id_arg (Name
i, Bang
str, Type
ty)
  = do  { L SrcSpanAnnN
li RdrName
i' <- Name -> CvtM (LocatedN RdrName)
vNameN Name
i
        ; GenLocated SrcSpanAnnA (HsType GhcPs)
ty' <- BangType -> CvtM (LHsType GhcPs)
cvt_arg (Bang
str,Type
ty)
        ; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ ConDeclField
                          { cd_fld_ext :: XConDeclField GhcPs
cd_fld_ext = forall a. EpAnn a
noAnn
                          , cd_fld_names :: [LFieldOcc GhcPs]
cd_fld_names
                              = [forall l e. l -> e -> GenLocated l e
L (forall a ann. SrcSpanAnn' a -> SrcAnn ann
l2l SrcSpanAnnN
li) forall a b. (a -> b) -> a -> b
$ forall pass. XCFieldOcc pass -> XRec pass RdrName -> FieldOcc pass
FieldOcc NoExtField
noExtField (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
li RdrName
i')]
                          , cd_fld_type :: LHsType GhcPs
cd_fld_type =  GenLocated SrcSpanAnnA (HsType GhcPs)
ty'
                          , cd_fld_doc :: Maybe (LHsDoc GhcPs)
cd_fld_doc = forall a. Maybe a
Nothing} }

cvtDerivs :: [TH.DerivClause] -> CvtM (HsDeriving GhcPs)
cvtDerivs :: [DerivClause] -> CvtM (HsDeriving GhcPs)
cvtDerivs [DerivClause]
cs = do { forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM DerivClause -> CvtM (LHsDerivingClause GhcPs)
cvtDerivClause [DerivClause]
cs }

cvt_fundep :: TH.FunDep -> CvtM (LHsFunDep GhcPs)
cvt_fundep :: FunDep -> CvtM (LHsFunDep GhcPs)
cvt_fundep (TH.FunDep [Name]
xs [Name]
ys) = do { [LocatedN RdrName]
xs' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> CvtM (LocatedN RdrName)
tNameN [Name]
xs
                                  ; [LocatedN RdrName]
ys' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> CvtM (LocatedN RdrName)
tNameN [Name]
ys
                                  ; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA (forall pass.
XCFunDep pass -> [LIdP pass] -> [LIdP pass] -> FunDep pass
Hs.FunDep forall a. EpAnn a
noAnn [LocatedN RdrName]
xs' [LocatedN RdrName]
ys') }


------------------------------------------
--      Foreign declarations
------------------------------------------

cvtForD :: Foreign -> CvtM (ForeignDecl GhcPs)
cvtForD :: Foreign -> CvtM (ForeignDecl GhcPs)
cvtForD (ImportF Callconv
callconv Safety
safety String
from Name
nm Type
ty) =
  do { SrcSpan
l <- CvtM SrcSpan
getL
     ; if -- the prim and javascript calling conventions do not support headers
          -- and are inserted verbatim, analogous to mkImport in GHC.Parser.PostProcess
          |  Callconv
callconv forall a. Eq a => a -> a -> Bool
== Callconv
TH.Prim Bool -> Bool -> Bool
|| Callconv
callconv forall a. Eq a => a -> a -> Bool
== Callconv
TH.JavaScript
          -> ForeignImport GhcPs -> CvtM (ForeignDecl GhcPs)
mk_imp (forall pass.
XCImport pass
-> XRec pass CCallConv
-> XRec pass Safety
-> Maybe Header
-> CImportSpec
-> ForeignImport pass
CImport (forall l e. l -> e -> GenLocated l e
L SrcSpan
l forall a b. (a -> b) -> a -> b
$ String -> SourceText
quotedSourceText String
from) (forall l e. l -> e -> GenLocated l e
L SrcSpan
l (Callconv -> CCallConv
cvt_conv Callconv
callconv)) (forall l e. l -> e -> GenLocated l e
L SrcSpan
l Safety
safety') forall a. Maybe a
Nothing
                             (CCallTarget -> CImportSpec
CFunction (SourceText -> CLabelString -> Maybe Unit -> Bool -> CCallTarget
StaticTarget (String -> SourceText
SourceText String
from)
                                                      (String -> CLabelString
mkFastString String
from) forall a. Maybe a
Nothing
                                                      Bool
True)))
          |  Just ForeignImport GhcPs
impspec <- forall (p :: Pass).
Located CCallConv
-> Located Safety
-> CLabelString
-> String
-> GenLocated SrcSpan SourceText
-> Maybe (ForeignImport (GhcPass p))
parseCImport (forall l e. l -> e -> GenLocated l e
L SrcSpan
l (Callconv -> CCallConv
cvt_conv Callconv
callconv)) (forall l e. l -> e -> GenLocated l e
L SrcSpan
l Safety
safety')
                                          (String -> CLabelString
mkFastString (Name -> String
TH.nameBase Name
nm))
                                          String
from (forall l e. l -> e -> GenLocated l e
L SrcSpan
l forall a b. (a -> b) -> a -> b
$ String -> SourceText
quotedSourceText String
from)
          -> ForeignImport GhcPs -> CvtM (ForeignDecl GhcPs)
mk_imp ForeignImport GhcPs
impspec
          |  Bool
otherwise
          -> forall a. ConversionFailReason -> CvtM a
failWith forall a b. (a -> b) -> a -> b
$ String -> ConversionFailReason
InvalidCCallImpent String
from }
  where
    mk_imp :: ForeignImport GhcPs -> CvtM (ForeignDecl GhcPs)
mk_imp ForeignImport GhcPs
impspec
      = do { LocatedN RdrName
nm' <- Name -> CvtM (LocatedN RdrName)
vNameN Name
nm
           ; GenLocated SrcSpanAnnA (HsSigType GhcPs)
ty' <- Type -> CvtM (LHsSigType GhcPs)
cvtSigType Type
ty
           ; forall (m :: * -> *) a. Monad m => a -> m a
return (ForeignImport { fd_i_ext :: XForeignImport GhcPs
fd_i_ext = forall a. EpAnn a
noAnn
                                   , fd_name :: XRec GhcPs (IdP GhcPs)
fd_name = LocatedN RdrName
nm'
                                   , fd_sig_ty :: LHsSigType GhcPs
fd_sig_ty = GenLocated SrcSpanAnnA (HsSigType GhcPs)
ty'
                                   , fd_fi :: ForeignImport GhcPs
fd_fi = ForeignImport GhcPs
impspec })
           }
    safety' :: Safety
safety' = case Safety
safety of
                     Safety
Unsafe     -> Safety
PlayRisky
                     Safety
Safe       -> Safety
PlaySafe
                     Safety
Interruptible -> Safety
PlayInterruptible

cvtForD (ExportF Callconv
callconv String
as Name
nm Type
ty)
  = do  { LocatedN RdrName
nm' <- Name -> CvtM (LocatedN RdrName)
vNameN Name
nm
        ; GenLocated SrcSpanAnnA (HsSigType GhcPs)
ty' <- Type -> CvtM (LHsSigType GhcPs)
cvtSigType Type
ty
        ; SrcSpan
l <- CvtM SrcSpan
getL
        ; let e :: ForeignExport GhcPs
e = forall pass.
XCExport pass -> XRec pass CExportSpec -> ForeignExport pass
CExport (forall l e. l -> e -> GenLocated l e
L SrcSpan
l (String -> SourceText
SourceText String
as)) (forall l e. l -> e -> GenLocated l e
L SrcSpan
l (SourceText -> CLabelString -> CCallConv -> CExportSpec
CExportStatic (String -> SourceText
SourceText String
as)
                                                (String -> CLabelString
mkFastString String
as)
                                                (Callconv -> CCallConv
cvt_conv Callconv
callconv)))
        ; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ForeignExport { fd_e_ext :: XForeignExport GhcPs
fd_e_ext = forall a. EpAnn a
noAnn
                                 , fd_name :: XRec GhcPs (IdP GhcPs)
fd_name = LocatedN RdrName
nm'
                                 , fd_sig_ty :: LHsSigType GhcPs
fd_sig_ty = GenLocated SrcSpanAnnA (HsSigType GhcPs)
ty'
                                 , fd_fe :: ForeignExport GhcPs
fd_fe = ForeignExport GhcPs
e } }

cvt_conv :: TH.Callconv -> CCallConv
cvt_conv :: Callconv -> CCallConv
cvt_conv Callconv
TH.CCall      = CCallConv
CCallConv
cvt_conv Callconv
TH.StdCall    = CCallConv
StdCallConv
cvt_conv Callconv
TH.CApi       = CCallConv
CApiConv
cvt_conv Callconv
TH.Prim       = CCallConv
PrimCallConv
cvt_conv Callconv
TH.JavaScript = CCallConv
JavaScriptCallConv

------------------------------------------
--              Pragmas
------------------------------------------

cvtPragmaD :: Pragma -> CvtM (Maybe (LHsDecl GhcPs))
cvtPragmaD :: Pragma -> CvtM (Maybe (LHsDecl GhcPs))
cvtPragmaD (InlineP Name
nm Inline
inline RuleMatch
rm Phases
phases)
  = do { LocatedN RdrName
nm' <- Name -> CvtM (LocatedN RdrName)
vNameN Name
nm
       ; let dflt :: Activation
dflt = Inline -> Activation
dfltActivation Inline
inline
       ; let src :: Inline -> String
src Inline
TH.NoInline  = String
"{-# NOINLINE"
             src Inline
TH.Inline    = String
"{-# INLINE"
             src Inline
TH.Inlinable = String
"{-# INLINABLE"
       ; let ip :: InlinePragma
ip   = InlinePragma { inl_src :: SourceText
inl_src    = Inline -> SourceText
toSrcTxt Inline
inline
                                 , inl_inline :: InlineSpec
inl_inline = Inline -> SourceText -> InlineSpec
cvtInline Inline
inline (Inline -> SourceText
toSrcTxt Inline
inline)
                                 , inl_rule :: RuleMatchInfo
inl_rule   = RuleMatch -> RuleMatchInfo
cvtRuleMatch RuleMatch
rm
                                 , inl_act :: Activation
inl_act    = Phases -> Activation -> Activation
cvtPhases Phases
phases Activation
dflt
                                 , inl_sat :: Maybe Int
inl_sat    = forall a. Maybe a
Nothing }
                    where
                     toSrcTxt :: Inline -> SourceText
toSrcTxt Inline
a = String -> SourceText
SourceText forall a b. (a -> b) -> a -> b
$ Inline -> String
src Inline
a
       ; forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA forall a b. (a -> b) -> a -> b
$ forall p. XSigD p -> Sig p -> HsDecl p
Hs.SigD NoExtField
noExtField forall a b. (a -> b) -> a -> b
$ forall pass.
XInlineSig pass -> LIdP pass -> InlinePragma -> Sig pass
InlineSig forall a. EpAnn a
noAnn LocatedN RdrName
nm' InlinePragma
ip }

cvtPragmaD (OpaqueP Name
nm)
  = do { LocatedN RdrName
nm' <- Name -> CvtM (LocatedN RdrName)
vNameN Name
nm
       ; let ip :: InlinePragma
ip = InlinePragma { inl_src :: SourceText
inl_src    = SourceText
srcTxt
                               , inl_inline :: InlineSpec
inl_inline = SourceText -> InlineSpec
Opaque SourceText
srcTxt
                               , inl_rule :: RuleMatchInfo
inl_rule   = RuleMatchInfo
Hs.FunLike
                               , inl_act :: Activation
inl_act    = Activation
NeverActive
                               , inl_sat :: Maybe Int
inl_sat    = forall a. Maybe a
Nothing }
                  where
                    srcTxt :: SourceText
srcTxt = String -> SourceText
SourceText String
"{-# OPAQUE"
       ; forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA forall a b. (a -> b) -> a -> b
$ forall p. XSigD p -> Sig p -> HsDecl p
Hs.SigD NoExtField
noExtField forall a b. (a -> b) -> a -> b
$ forall pass.
XInlineSig pass -> LIdP pass -> InlinePragma -> Sig pass
InlineSig forall a. EpAnn a
noAnn LocatedN RdrName
nm' InlinePragma
ip }

cvtPragmaD (SpecialiseP Name
nm Type
ty Maybe Inline
inline Phases
phases)
  = do { LocatedN RdrName
nm' <- Name -> CvtM (LocatedN RdrName)
vNameN Name
nm
       ; GenLocated SrcSpanAnnA (HsSigType GhcPs)
ty' <- Type -> CvtM (LHsSigType GhcPs)
cvtSigType Type
ty
       ; let src :: Inline -> String
src Inline
TH.NoInline  = String
"{-# SPECIALISE NOINLINE"
             src Inline
TH.Inline    = String
"{-# SPECIALISE INLINE"
             src Inline
TH.Inlinable = String
"{-# SPECIALISE INLINE"
       ; let (InlineSpec
inline', Activation
dflt, SourceText
srcText) = case Maybe Inline
inline of
               Just Inline
inline1 -> (Inline -> SourceText -> InlineSpec
cvtInline Inline
inline1 (Inline -> SourceText
toSrcTxt Inline
inline1), Inline -> Activation
dfltActivation Inline
inline1,
                                Inline -> SourceText
toSrcTxt Inline
inline1)
               Maybe Inline
Nothing      -> (InlineSpec
NoUserInlinePrag,   Activation
AlwaysActive,
                                String -> SourceText
SourceText String
"{-# SPECIALISE")
               where
                toSrcTxt :: Inline -> SourceText
toSrcTxt Inline
a = String -> SourceText
SourceText forall a b. (a -> b) -> a -> b
$ Inline -> String
src Inline
a
       ; let ip :: InlinePragma
ip = InlinePragma { inl_src :: SourceText
inl_src    = SourceText
srcText
                               , inl_inline :: InlineSpec
inl_inline = InlineSpec
inline'
                               , inl_rule :: RuleMatchInfo
inl_rule   = RuleMatchInfo
Hs.FunLike
                               , inl_act :: Activation
inl_act    = Phases -> Activation -> Activation
cvtPhases Phases
phases Activation
dflt
                               , inl_sat :: Maybe Int
inl_sat    = forall a. Maybe a
Nothing }
       ; forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA forall a b. (a -> b) -> a -> b
$ forall p. XSigD p -> Sig p -> HsDecl p
Hs.SigD NoExtField
noExtField forall a b. (a -> b) -> a -> b
$ forall pass.
XSpecSig pass
-> LIdP pass -> [LHsSigType pass] -> InlinePragma -> Sig pass
SpecSig forall a. EpAnn a
noAnn LocatedN RdrName
nm' [GenLocated SrcSpanAnnA (HsSigType GhcPs)
ty'] InlinePragma
ip }

cvtPragmaD (SpecialiseInstP Type
ty)
  = do { GenLocated SrcSpanAnnA (HsSigType GhcPs)
ty' <- Type -> CvtM (LHsSigType GhcPs)
cvtSigType Type
ty
       ; forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA forall a b. (a -> b) -> a -> b
$ forall p. XSigD p -> Sig p -> HsDecl p
Hs.SigD NoExtField
noExtField forall a b. (a -> b) -> a -> b
$
         forall pass. XSpecInstSig pass -> LHsSigType pass -> Sig pass
SpecInstSig (forall a. EpAnn a
noAnn, (String -> SourceText
SourceText String
"{-# SPECIALISE")) GenLocated SrcSpanAnnA (HsSigType GhcPs)
ty' }

cvtPragmaD (RuleP String
nm Maybe [TyVarBndr ()]
ty_bndrs [RuleBndr]
tm_bndrs Exp
lhs Exp
rhs Phases
phases)
  = do { let nm' :: CLabelString
nm' = String -> CLabelString
mkFastString String
nm
       ; LocatedAn NoEpAnns CLabelString
rd_name' <- forall e ann. e -> CvtM (LocatedAn ann e)
returnLA CLabelString
nm'
       ; let act :: Activation
act = Phases -> Activation -> Activation
cvtPhases Phases
phases Activation
AlwaysActive
       ; Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)]
ty_bndrs' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall flag flag'.
CvtFlag flag flag' =>
[TyVarBndr flag] -> CvtM [LHsTyVarBndr flag' GhcPs]
cvtTvs Maybe [TyVarBndr ()]
ty_bndrs
       ; [GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcPs)]
tm_bndrs' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM RuleBndr -> CvtM (LRuleBndr GhcPs)
cvtRuleBndr [RuleBndr]
tm_bndrs
       ; GenLocated SrcSpanAnnA (HsExpr GhcPs)
lhs'   <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
lhs
       ; GenLocated SrcSpanAnnA (HsExpr GhcPs)
rhs'   <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
rhs
       ; LocatedAn AnnListItem (RuleDecl GhcPs)
rule <- forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$
                   HsRule { rd_ext :: XHsRule GhcPs
rd_ext  = (forall a. EpAnn a
noAnn, String -> SourceText
quotedSourceText String
nm)
                          , rd_name :: XRec GhcPs CLabelString
rd_name = LocatedAn NoEpAnns CLabelString
rd_name'
                          , rd_act :: Activation
rd_act  = Activation
act
                          , rd_tyvs :: Maybe [LHsTyVarBndr () (NoGhcTc GhcPs)]
rd_tyvs = Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)]
ty_bndrs'
                          , rd_tmvs :: [LRuleBndr GhcPs]
rd_tmvs = [GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcPs)]
tm_bndrs'
                          , rd_lhs :: LHsExpr GhcPs
rd_lhs  = GenLocated SrcSpanAnnA (HsExpr GhcPs)
lhs'
                          , rd_rhs :: LHsExpr GhcPs
rd_rhs  = GenLocated SrcSpanAnnA (HsExpr GhcPs)
rhs' }
       ; forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA forall a b. (a -> b) -> a -> b
$ forall p. XRuleD p -> RuleDecls p -> HsDecl p
Hs.RuleD NoExtField
noExtField
            forall a b. (a -> b) -> a -> b
$ HsRules { rds_ext :: XCRuleDecls GhcPs
rds_ext = (forall a. EpAnn a
noAnn, String -> SourceText
SourceText String
"{-# RULES")
                      , rds_rules :: [LRuleDecl GhcPs]
rds_rules = [LocatedAn AnnListItem (RuleDecl GhcPs)
rule] }

          }

cvtPragmaD (AnnP AnnTarget
target Exp
exp)
  = do { GenLocated SrcSpanAnnA (HsExpr GhcPs)
exp' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
exp
       ; AnnProvenance GhcPs
target' <- case AnnTarget
target of
         AnnTarget
ModuleAnnotation  -> forall (m :: * -> *) a. Monad m => a -> m a
return forall pass. AnnProvenance pass
ModuleAnnProvenance
         TypeAnnotation Name
n  -> do
           RdrName
n' <- Name -> CvtM RdrName
tconName Name
n
           forall ann a b. (LocatedAn ann a -> b) -> a -> CvtM b
wrapParLA forall pass. LIdP pass -> AnnProvenance pass
TypeAnnProvenance RdrName
n'
         ValueAnnotation Name
n -> do
           RdrName
n' <- Name -> CvtM RdrName
vcName Name
n
           forall ann a b. (LocatedAn ann a -> b) -> a -> CvtM b
wrapParLA forall pass. LIdP pass -> AnnProvenance pass
ValueAnnProvenance RdrName
n'
       ; forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA forall a b. (a -> b) -> a -> b
$ forall p. XAnnD p -> AnnDecl p -> HsDecl p
Hs.AnnD NoExtField
noExtField
                     forall a b. (a -> b) -> a -> b
$ forall pass.
XHsAnnotation pass
-> AnnProvenance pass -> XRec pass (HsExpr pass) -> AnnDecl pass
HsAnnotation (forall a. EpAnn a
noAnn, (String -> SourceText
SourceText String
"{-# ANN")) AnnProvenance GhcPs
target' GenLocated SrcSpanAnnA (HsExpr GhcPs)
exp'
       }

-- NB: This is the only place in GHC.ThToHs that makes use of the `setL`
-- function. See Note [Source locations within TH splices].
cvtPragmaD (LineP Int
line String
file)
  = do { SrcSpan -> CvtM ()
setL (SrcLoc -> SrcSpan
srcLocSpan (CLabelString -> Int -> Int -> SrcLoc
mkSrcLoc (String -> CLabelString
fsLit String
file) Int
line Int
1))
       ; forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
       }
cvtPragmaD (CompleteP [Name]
cls Maybe Name
mty)
  = do { Located [LocatedN RdrName]
cls'  <- forall a. CvtM a -> CvtM (Located a)
wrapL forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> CvtM (LocatedN RdrName)
cNameN [Name]
cls
       ; Maybe (LocatedN RdrName)
mty'  <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Name -> CvtM (LocatedN RdrName)
tconNameN Maybe Name
mty
       ; forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA forall a b. (a -> b) -> a -> b
$ forall p. XSigD p -> Sig p -> HsDecl p
Hs.SigD NoExtField
noExtField
                   forall a b. (a -> b) -> a -> b
$ forall pass.
XCompleteMatchSig pass
-> XRec pass [LIdP pass] -> Maybe (LIdP pass) -> Sig pass
CompleteMatchSig (forall a. EpAnn a
noAnn, SourceText
NoSourceText) Located [LocatedN RdrName]
cls' Maybe (LocatedN RdrName)
mty' }

dfltActivation :: TH.Inline -> Activation
dfltActivation :: Inline -> Activation
dfltActivation Inline
TH.NoInline = Activation
NeverActive
dfltActivation Inline
_           = Activation
AlwaysActive

cvtInline :: TH.Inline  -> SourceText -> Hs.InlineSpec
cvtInline :: Inline -> SourceText -> InlineSpec
cvtInline Inline
TH.NoInline   SourceText
srcText  = SourceText -> InlineSpec
Hs.NoInline  SourceText
srcText
cvtInline Inline
TH.Inline     SourceText
srcText  = SourceText -> InlineSpec
Hs.Inline    SourceText
srcText
cvtInline Inline
TH.Inlinable  SourceText
srcText  = SourceText -> InlineSpec
Hs.Inlinable SourceText
srcText

cvtRuleMatch :: TH.RuleMatch -> RuleMatchInfo
cvtRuleMatch :: RuleMatch -> RuleMatchInfo
cvtRuleMatch RuleMatch
TH.ConLike = RuleMatchInfo
Hs.ConLike
cvtRuleMatch RuleMatch
TH.FunLike = RuleMatchInfo
Hs.FunLike

cvtPhases :: TH.Phases -> Activation -> Activation
cvtPhases :: Phases -> Activation -> Activation
cvtPhases Phases
AllPhases       Activation
dflt = Activation
dflt
cvtPhases (FromPhase Int
i)   Activation
_    = SourceText -> Int -> Activation
ActiveAfter SourceText
NoSourceText Int
i
cvtPhases (BeforePhase Int
i) Activation
_    = SourceText -> Int -> Activation
ActiveBefore SourceText
NoSourceText Int
i

cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.LRuleBndr GhcPs)
cvtRuleBndr :: RuleBndr -> CvtM (LRuleBndr GhcPs)
cvtRuleBndr (RuleVar Name
n)
  = do { LocatedN RdrName
n' <- Name -> CvtM (LocatedN RdrName)
vNameN Name
n
       ; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ forall pass. XCRuleBndr pass -> LIdP pass -> RuleBndr pass
Hs.RuleBndr forall a. EpAnn a
noAnn LocatedN RdrName
n' }
cvtRuleBndr (TypedRuleVar Name
n Type
ty)
  = do { LocatedN RdrName
n'  <- Name -> CvtM (LocatedN RdrName)
vNameN Name
n
       ; GenLocated SrcSpanAnnA (HsType GhcPs)
ty' <- Type -> CvtM (LHsType GhcPs)
cvtType Type
ty
       ; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ forall pass.
XRuleBndrSig pass
-> LIdP pass -> HsPatSigType pass -> RuleBndr pass
Hs.RuleBndrSig forall a. EpAnn a
noAnn LocatedN RdrName
n' forall a b. (a -> b) -> a -> b
$ EpAnnCO -> LHsType GhcPs -> HsPatSigType GhcPs
mkHsPatSigType forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (HsType GhcPs)
ty' }

---------------------------------------------------
--              Declarations
---------------------------------------------------

cvtLocalDecs :: THDeclDescriptor -> [TH.Dec] -> CvtM (HsLocalBinds GhcPs)
cvtLocalDecs :: THDeclDescriptor -> [Dec] -> CvtM (HsLocalBinds GhcPs)
cvtLocalDecs THDeclDescriptor
declDescr [Dec]
ds
  = case forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
partitionWith Dec -> Either (String, Exp) Dec
is_ip_bind [Dec]
ds of
      ([], []) -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall idL idR. XEmptyLocalBinds idL idR -> HsLocalBindsLR idL idR
EmptyLocalBinds NoExtField
noExtField)
      ([], [Dec]
_) -> do
        [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
ds' <- [Dec] -> CvtM [LHsDecl GhcPs]
cvtDecs [Dec]
ds
        let ([GenLocated SrcSpanAnnA (HsBind GhcPs)]
binds, [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
prob_sigs) = forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
partitionWith LHsDecl GhcPs -> Either (LHsBind GhcPs) (LHsDecl GhcPs)
is_bind [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
ds'
        let ([GenLocated SrcSpanAnnA (Sig GhcPs)]
sigs, [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
bads) = forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
partitionWith LHsDecl GhcPs -> Either (LSig GhcPs) (LHsDecl GhcPs)
is_sig [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
prob_sigs
        forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
bads) forall a b. (a -> b) -> a -> b
$ \ NonEmpty (GenLocated SrcSpanAnnA (HsDecl GhcPs))
bad_decls ->
          forall a. ConversionFailReason -> CvtM a
failWith (THDeclDescriptor -> IllegalDecls -> ConversionFailReason
IllegalDeclaration THDeclDescriptor
declDescr forall a b. (a -> b) -> a -> b
$ NonEmpty (LHsDecl GhcPs) -> IllegalDecls
IllegalDecls NonEmpty (GenLocated SrcSpanAnnA (HsDecl GhcPs))
bad_decls)
        forall (m :: * -> *) a. Monad m => a -> m a
return (forall idL idR.
XHsValBinds idL idR
-> HsValBindsLR idL idR -> HsLocalBindsLR idL idR
HsValBinds forall a. EpAnn a
noAnn (forall idL idR.
XValBinds idL idR
-> LHsBindsLR idL idR -> [LSig idR] -> HsValBindsLR idL idR
ValBinds AnnSortKey
NoAnnSortKey (forall a. [a] -> Bag a
listToBag [GenLocated SrcSpanAnnA (HsBind GhcPs)]
binds) [GenLocated SrcSpanAnnA (Sig GhcPs)]
sigs))
      ([(String, Exp)]
ip_binds, []) -> do
        [GenLocated SrcSpanAnnA (IPBind GhcPs)]
binds <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> Exp -> CvtM (LIPBind GhcPs)
cvtImplicitParamBind) [(String, Exp)]
ip_binds
        forall (m :: * -> *) a. Monad m => a -> m a
return (forall idL idR.
XHsIPBinds idL idR -> HsIPBinds idR -> HsLocalBindsLR idL idR
HsIPBinds forall a. EpAnn a
noAnn (forall id. XIPBinds id -> [LIPBind id] -> HsIPBinds id
IPBinds NoExtField
noExtField [GenLocated SrcSpanAnnA (IPBind GhcPs)]
binds))
      (((String, Exp)
_:[(String, Exp)]
_), (Dec
_:[Dec]
_)) ->
        forall a. ConversionFailReason -> CvtM a
failWith ConversionFailReason
ImplicitParamsWithOtherBinds

cvtClause :: HsMatchContext GhcPs
          -> TH.Clause -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))
cvtClause :: HsMatchContext GhcPs
-> Clause -> CvtM (LMatch GhcPs (LHsExpr GhcPs))
cvtClause HsMatchContext GhcPs
ctxt (Clause [Pat]
ps Body
body [Dec]
wheres)
  = do  { [GenLocated SrcSpanAnnA (Pat GhcPs)]
ps' <- [Pat] -> CvtM [LPat GhcPs]
cvtPats [Pat]
ps
        ; let pps :: [GenLocated SrcSpanAnnA (Pat GhcPs)]
pps = forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: Pass).
IsPass p =>
PprPrec -> LPat (GhcPass p) -> LPat (GhcPass p)
parenthesizePat PprPrec
appPrec) [GenLocated SrcSpanAnnA (Pat GhcPs)]
ps'
        ; [GenLocated
   (SrcAnn NoEpAnns)
   (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
g'  <- Body -> CvtM [LGRHS GhcPs (LHsExpr GhcPs)]
cvtGuard Body
body
        ; HsLocalBinds GhcPs
ds' <- THDeclDescriptor -> [Dec] -> CvtM (HsLocalBinds GhcPs)
cvtLocalDecs THDeclDescriptor
WhereClause [Dec]
wheres
        ; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ forall p body.
XCMatch p body
-> HsMatchContext p -> [LPat p] -> GRHSs p body -> Match p body
Hs.Match forall a. EpAnn a
noAnn HsMatchContext GhcPs
ctxt [GenLocated SrcSpanAnnA (Pat GhcPs)]
pps (forall p body.
XCGRHSs p body -> [LGRHS p body] -> HsLocalBinds p -> GRHSs p body
GRHSs EpAnnComments
emptyComments [GenLocated
   (SrcAnn NoEpAnns)
   (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
g' HsLocalBinds GhcPs
ds') }

cvtImplicitParamBind :: String -> TH.Exp -> CvtM (LIPBind GhcPs)
cvtImplicitParamBind :: String -> Exp -> CvtM (LIPBind GhcPs)
cvtImplicitParamBind String
n Exp
e = do
    Located HsIPName
n' <- forall a. CvtM a -> CvtM (Located a)
wrapL (String -> CvtM HsIPName
ipName String
n)
    GenLocated SrcSpanAnnA (HsExpr GhcPs)
e' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
e
    forall e ann. e -> CvtM (LocatedAn ann e)
returnLA (forall id.
XCIPBind id -> XRec id HsIPName -> LHsExpr id -> IPBind id
IPBind forall a. EpAnn a
noAnn (forall e ann. Located e -> LocatedAn ann e
reLocA Located HsIPName
n') GenLocated SrcSpanAnnA (HsExpr GhcPs)
e')

-------------------------------------------------------------------
--              Expressions
-------------------------------------------------------------------

cvtl :: TH.Exp -> CvtM (LHsExpr GhcPs)
cvtl :: Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
e = forall a. CvtM a -> CvtM (LocatedA a)
wrapLA (Exp -> CvtM' ConversionFailReason (HsExpr GhcPs)
cvt Exp
e)
  where
    cvt :: Exp -> CvtM' ConversionFailReason (HsExpr GhcPs)
cvt (VarE Name
s)   = do { RdrName
s' <- Name -> CvtM RdrName
vName Name
s; forall ann a b. (LocatedAn ann a -> b) -> a -> CvtM b
wrapParLA (forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
noExtField) RdrName
s' }
    cvt (ConE Name
s)   = do { RdrName
s' <- Name -> CvtM RdrName
cName Name
s; forall ann a b. (LocatedAn ann a -> b) -> a -> CvtM b
wrapParLA (forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
noExtField) RdrName
s' }
    cvt (LitE Lit
l)
      | Lit -> Bool
overloadedLit Lit
l = forall (l :: * -> *).
(Lit -> CvtM (l GhcPs))
-> (l GhcPs -> HsExpr GhcPs)
-> (l GhcPs -> Bool)
-> CvtM' ConversionFailReason (HsExpr GhcPs)
go Lit -> CvtM (HsOverLit GhcPs)
cvtOverLit (forall p. XOverLitE p -> HsOverLit p -> HsExpr p
HsOverLit EpAnnCO
noComments)
                             (forall x. PprPrec -> HsOverLit x -> Bool
hsOverLitNeedsParens PprPrec
appPrec)
      | Bool
otherwise       = forall (l :: * -> *).
(Lit -> CvtM (l GhcPs))
-> (l GhcPs -> HsExpr GhcPs)
-> (l GhcPs -> Bool)
-> CvtM' ConversionFailReason (HsExpr GhcPs)
go Lit -> CvtM (HsLit GhcPs)
cvtLit (forall p. XLitE p -> HsLit p -> HsExpr p
HsLit EpAnnCO
noComments)
                             (forall x. PprPrec -> HsLit x -> Bool
hsLitNeedsParens PprPrec
appPrec)
      where
        go :: (Lit -> CvtM (l GhcPs))
           -> (l GhcPs -> HsExpr GhcPs)
           -> (l GhcPs -> Bool)
           -> CvtM (HsExpr GhcPs)
        go :: forall (l :: * -> *).
(Lit -> CvtM (l GhcPs))
-> (l GhcPs -> HsExpr GhcPs)
-> (l GhcPs -> Bool)
-> CvtM' ConversionFailReason (HsExpr GhcPs)
go Lit -> CvtM (l GhcPs)
cvt_lit l GhcPs -> HsExpr GhcPs
mk_expr l GhcPs -> Bool
is_compound_lit = do
          l GhcPs
l' <- Lit -> CvtM (l GhcPs)
cvt_lit Lit
l
          let e' :: HsExpr GhcPs
e' = l GhcPs -> HsExpr GhcPs
mk_expr l GhcPs
l'
          if l GhcPs -> Bool
is_compound_lit l GhcPs
l' then forall ann a b. (LocatedAn ann a -> b) -> a -> CvtM b
wrapParLA forall (id :: Pass). LHsExpr (GhcPass id) -> HsExpr (GhcPass id)
gHsPar HsExpr GhcPs
e' else forall (f :: * -> *) a. Applicative f => a -> f a
pure HsExpr GhcPs
e'
    cvt (AppE Exp
e1 Exp
e2)   = do { GenLocated SrcSpanAnnA (HsExpr GhcPs)
e1' <- forall (p :: Pass).
IsPass p =>
PprPrec -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
parenthesizeHsExpr PprPrec
opPrec forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
e1
                            ; GenLocated SrcSpanAnnA (HsExpr GhcPs)
e2' <- forall (p :: Pass).
IsPass p =>
PprPrec -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
parenthesizeHsExpr PprPrec
appPrec forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
e2
                            ; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp EpAnnCO
noComments GenLocated SrcSpanAnnA (HsExpr GhcPs)
e1' GenLocated SrcSpanAnnA (HsExpr GhcPs)
e2' }
    cvt (AppTypeE Exp
e Type
t) = do { GenLocated SrcSpanAnnA (HsExpr GhcPs)
e' <- forall (p :: Pass).
IsPass p =>
PprPrec -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
parenthesizeHsExpr PprPrec
opPrec forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
e
                            ; GenLocated SrcSpanAnnA (HsType GhcPs)
t' <- forall (p :: Pass).
PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)
parenthesizeHsType PprPrec
appPrec forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> CvtM (LHsType GhcPs)
cvtType Type
t
                            ; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p.
XAppTypeE p
-> LHsExpr p -> LHsToken "@" p -> LHsWcType (NoGhcTc p) -> HsExpr p
HsAppType NoExtField
noExtField GenLocated SrcSpanAnnA (HsExpr GhcPs)
e' forall (tok :: Symbol). GenLocated TokenLocation (HsToken tok)
noHsTok
                                     forall a b. (a -> b) -> a -> b
$ forall thing. thing -> HsWildCardBndrs GhcPs thing
mkHsWildCardBndrs GenLocated SrcSpanAnnA (HsType GhcPs)
t' }
    cvt (LamE [] Exp
e)    = Exp -> CvtM' ConversionFailReason (HsExpr GhcPs)
cvt Exp
e -- Degenerate case. We convert the body as its
                               -- own expression to avoid pretty-printing
                               -- oddities that can result from zero-argument
                               -- lambda expressions. See #13856.
    cvt (LamE [Pat]
ps Exp
e)    = do { [GenLocated SrcSpanAnnA (Pat GhcPs)]
ps' <- [Pat] -> CvtM [LPat GhcPs]
cvtPats [Pat]
ps; GenLocated SrcSpanAnnA (HsExpr GhcPs)
e' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
e
                            ; let pats :: [GenLocated SrcSpanAnnA (Pat GhcPs)]
pats = forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: Pass).
IsPass p =>
PprPrec -> LPat (GhcPass p) -> LPat (GhcPass p)
parenthesizePat PprPrec
appPrec) [GenLocated SrcSpanAnnA (Pat GhcPs)]
ps'
                            ; Origin
th_origin <- CvtM Origin
getOrigin
                            ; forall ann a b. (LocatedAn ann a -> b) -> a -> CvtM b
wrapParLA (forall p. XLam p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLam NoExtField
noExtField forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: Pass) (body :: * -> *).
AnnoBody p body =>
Origin
-> LocatedL
     [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]
-> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))
mkMatchGroup Origin
th_origin)
                                        [forall (p :: Pass) (body :: * -> *).
(Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcSpanAnnA,
 Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcAnn NoEpAnns) =>
HsMatchContext (GhcPass p)
-> [LPat (GhcPass p)]
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkSimpleMatch forall p. HsMatchContext p
LambdaExpr [GenLocated SrcSpanAnnA (Pat GhcPs)]
pats GenLocated SrcSpanAnnA (HsExpr GhcPs)
e']}
    cvt (LamCaseE [Match]
ms)  = do { [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
ms' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (HsMatchContext GhcPs
-> Match -> CvtM (LMatch GhcPs (LHsExpr GhcPs))
cvtMatch forall a b. (a -> b) -> a -> b
$ forall p. LamCaseVariant -> HsMatchContext p
LamCaseAlt LamCaseVariant
LamCase) [Match]
ms
                            ; Origin
th_origin <- CvtM Origin
getOrigin
                            ; forall ann a b. (LocatedAn ann a -> b) -> a -> CvtM b
wrapParLA (forall p.
XLamCase p
-> LamCaseVariant -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLamCase forall a. EpAnn a
noAnn LamCaseVariant
LamCase forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: Pass) (body :: * -> *).
AnnoBody p body =>
Origin
-> LocatedL
     [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]
-> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))
mkMatchGroup Origin
th_origin) [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
ms'
                            }
    cvt (LamCasesE [Clause]
ms)
      | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Clause]
ms   = forall a. ConversionFailReason -> CvtM a
failWith ConversionFailReason
CasesExprWithoutAlts
      | Bool
otherwise = do { [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
ms' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (HsMatchContext GhcPs
-> Clause -> CvtM (LMatch GhcPs (LHsExpr GhcPs))
cvtClause forall a b. (a -> b) -> a -> b
$ forall p. LamCaseVariant -> HsMatchContext p
LamCaseAlt LamCaseVariant
LamCases) [Clause]
ms
                       ; Origin
th_origin <- CvtM Origin
getOrigin
                       ; forall ann a b. (LocatedAn ann a -> b) -> a -> CvtM b
wrapParLA (forall p.
XLamCase p
-> LamCaseVariant -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLamCase forall a. EpAnn a
noAnn LamCaseVariant
LamCases forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: Pass) (body :: * -> *).
AnnoBody p body =>
Origin
-> LocatedL
     [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]
-> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))
mkMatchGroup Origin
th_origin) [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
ms'
                       }
    cvt (TupE [Maybe Exp]
es)        = [Maybe Exp] -> Boxity -> CvtM' ConversionFailReason (HsExpr GhcPs)
cvt_tup [Maybe Exp]
es Boxity
Boxed
    cvt (UnboxedTupE [Maybe Exp]
es) = [Maybe Exp] -> Boxity -> CvtM' ConversionFailReason (HsExpr GhcPs)
cvt_tup [Maybe Exp]
es Boxity
Unboxed
    cvt (UnboxedSumE Exp
e Int
alt Int
arity) = do { GenLocated SrcSpanAnnA (HsExpr GhcPs)
e' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
e
                                       ; Int -> Int -> CvtM ()
unboxedSumChecks Int
alt Int
arity
                                       ; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p. XExplicitSum p -> Int -> Int -> LHsExpr p -> HsExpr p
ExplicitSum forall a. EpAnn a
noAnn Int
alt Int
arity GenLocated SrcSpanAnnA (HsExpr GhcPs)
e'}
    cvt (CondE Exp
x Exp
y Exp
z)  = do { GenLocated SrcSpanAnnA (HsExpr GhcPs)
x' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
x; GenLocated SrcSpanAnnA (HsExpr GhcPs)
y' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
y; GenLocated SrcSpanAnnA (HsExpr GhcPs)
z' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
z;
                            ; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs
-> LHsExpr GhcPs -> LHsExpr GhcPs -> EpAnn AnnsIf -> HsExpr GhcPs
mkHsIf GenLocated SrcSpanAnnA (HsExpr GhcPs)
x' GenLocated SrcSpanAnnA (HsExpr GhcPs)
y' GenLocated SrcSpanAnnA (HsExpr GhcPs)
z' forall a. EpAnn a
noAnn }
    cvt (MultiIfE [(Guard, Exp)]
alts)
      | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Guard, Exp)]
alts      = forall a. ConversionFailReason -> CvtM a
failWith ConversionFailReason
MultiWayIfWithoutAlts
      | Bool
otherwise      = do { [GenLocated
   (SrcAnn NoEpAnns)
   (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
alts' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Guard, Exp) -> CvtM (LGRHS GhcPs (LHsExpr GhcPs))
cvtpair [(Guard, Exp)]
alts
                            ; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p. XMultiIf p -> [LGRHS p (LHsExpr p)] -> HsExpr p
HsMultiIf forall a. EpAnn a
noAnn [GenLocated
   (SrcAnn NoEpAnns)
   (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
alts' }
    cvt (LetE [Dec]
ds Exp
e)    = do { HsLocalBinds GhcPs
ds' <- THDeclDescriptor -> [Dec] -> CvtM (HsLocalBinds GhcPs)
cvtLocalDecs THDeclDescriptor
LetExpression [Dec]
ds
                            ; GenLocated SrcSpanAnnA (HsExpr GhcPs)
e' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
e; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p.
XLet p
-> LHsToken "let" p
-> HsLocalBinds p
-> LHsToken "in" p
-> LHsExpr p
-> HsExpr p
HsLet forall a. EpAnn a
noAnn forall (tok :: Symbol). GenLocated TokenLocation (HsToken tok)
noHsTok HsLocalBinds GhcPs
ds' forall (tok :: Symbol). GenLocated TokenLocation (HsToken tok)
noHsTok GenLocated SrcSpanAnnA (HsExpr GhcPs)
e'}
    cvt (CaseE Exp
e [Match]
ms)   = do { GenLocated SrcSpanAnnA (HsExpr GhcPs)
e' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
e; [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
ms' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (HsMatchContext GhcPs
-> Match -> CvtM (LMatch GhcPs (LHsExpr GhcPs))
cvtMatch forall p. HsMatchContext p
CaseAlt) [Match]
ms
                            ; Origin
th_origin <- CvtM Origin
getOrigin
                            ; forall ann a b. (LocatedAn ann a -> b) -> a -> CvtM b
wrapParLA (forall p.
XCase p -> LHsExpr p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsCase forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (HsExpr GhcPs)
e' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: Pass) (body :: * -> *).
AnnoBody p body =>
Origin
-> LocatedL
     [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]
-> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))
mkMatchGroup Origin
th_origin) [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
ms' }
    cvt (DoE Maybe ModName
m [Stmt]
ss)     = HsDoFlavour -> [Stmt] -> CvtM' ConversionFailReason (HsExpr GhcPs)
cvtHsDo (Maybe ModuleName -> HsDoFlavour
DoExpr (ModName -> ModuleName
mk_mod forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ModName
m)) [Stmt]
ss
    cvt (MDoE Maybe ModName
m [Stmt]
ss)    = HsDoFlavour -> [Stmt] -> CvtM' ConversionFailReason (HsExpr GhcPs)
cvtHsDo (Maybe ModuleName -> HsDoFlavour
MDoExpr (ModName -> ModuleName
mk_mod forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ModName
m)) [Stmt]
ss
    cvt (CompE [Stmt]
ss)     = HsDoFlavour -> [Stmt] -> CvtM' ConversionFailReason (HsExpr GhcPs)
cvtHsDo HsDoFlavour
ListComp [Stmt]
ss
    cvt (ArithSeqE Range
dd) = do { ArithSeqInfo GhcPs
dd' <- Range -> CvtM (ArithSeqInfo GhcPs)
cvtDD Range
dd
                            ; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p.
XArithSeq p -> Maybe (SyntaxExpr p) -> ArithSeqInfo p -> HsExpr p
ArithSeq forall a. EpAnn a
noAnn forall a. Maybe a
Nothing ArithSeqInfo GhcPs
dd' }
    cvt (ListE [Exp]
xs)
      | Just String
s <- [Exp] -> Maybe String
allCharLs [Exp]
xs       = do { HsLit GhcPs
l' <- Lit -> CvtM (HsLit GhcPs)
cvtLit (String -> Lit
StringL String
s)
                                          ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. XLitE p -> HsLit p -> HsExpr p
HsLit EpAnnCO
noComments HsLit GhcPs
l') }
             -- Note [Converting strings]
      | Bool
otherwise       = do { [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
xs' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Exp -> CvtM (LHsExpr GhcPs)
cvtl [Exp]
xs
                             ; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p. XExplicitList p -> [LHsExpr p] -> HsExpr p
ExplicitList forall a. EpAnn a
noAnn [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
xs'
                             }

    -- Infix expressions
    cvt (InfixE (Just Exp
x) Exp
s (Just Exp
y)) = forall a. Exp -> CvtM a -> CvtM a
ensureValidOpExp Exp
s forall a b. (a -> b) -> a -> b
$
      do { GenLocated SrcSpanAnnA (HsExpr GhcPs)
x' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
x
         ; GenLocated SrcSpanAnnA (HsExpr GhcPs)
s' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
s
         ; GenLocated SrcSpanAnnA (HsExpr GhcPs)
y' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
y
         ; let px :: LHsExpr GhcPs
px = forall (p :: Pass).
IsPass p =>
PprPrec -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
parenthesizeHsExpr PprPrec
opPrec GenLocated SrcSpanAnnA (HsExpr GhcPs)
x'
               py :: LHsExpr GhcPs
py = forall (p :: Pass).
IsPass p =>
PprPrec -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
parenthesizeHsExpr PprPrec
opPrec GenLocated SrcSpanAnnA (HsExpr GhcPs)
y'
         ; forall ann a b. (LocatedAn ann a -> b) -> a -> CvtM b
wrapParLA forall (id :: Pass). LHsExpr (GhcPass id) -> HsExpr (GhcPass id)
gHsPar
           forall a b. (a -> b) -> a -> b
$ forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp forall a. EpAnn a
noAnn LHsExpr GhcPs
px GenLocated SrcSpanAnnA (HsExpr GhcPs)
s' LHsExpr GhcPs
py }
           -- Parenthesise both arguments and result,
           -- to ensure this operator application does
           -- does not get re-associated
           -- See Note [Operator association]
    cvt (InfixE Maybe Exp
Nothing  Exp
s (Just Exp
y)) = forall a. Exp -> CvtM a -> CvtM a
ensureValidOpExp Exp
s forall a b. (a -> b) -> a -> b
$
                                       do { GenLocated SrcSpanAnnA (HsExpr GhcPs)
s' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
s; GenLocated SrcSpanAnnA (HsExpr GhcPs)
y' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
y
                                          ; forall ann a b. (LocatedAn ann a -> b) -> a -> CvtM b
wrapParLA forall (id :: Pass). LHsExpr (GhcPass id) -> HsExpr (GhcPass id)
gHsPar forall a b. (a -> b) -> a -> b
$
                                                          forall p. XSectionR p -> LHsExpr p -> LHsExpr p -> HsExpr p
SectionR EpAnnCO
noComments GenLocated SrcSpanAnnA (HsExpr GhcPs)
s' GenLocated SrcSpanAnnA (HsExpr GhcPs)
y' }
                                            -- See Note [Sections in HsSyn] in GHC.Hs.Expr
    cvt (InfixE (Just Exp
x) Exp
s Maybe Exp
Nothing ) = forall a. Exp -> CvtM a -> CvtM a
ensureValidOpExp Exp
s forall a b. (a -> b) -> a -> b
$
                                       do { GenLocated SrcSpanAnnA (HsExpr GhcPs)
x' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
x; GenLocated SrcSpanAnnA (HsExpr GhcPs)
s' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
s
                                          ; forall ann a b. (LocatedAn ann a -> b) -> a -> CvtM b
wrapParLA forall (id :: Pass). LHsExpr (GhcPass id) -> HsExpr (GhcPass id)
gHsPar forall a b. (a -> b) -> a -> b
$
                                                          forall p. XSectionL p -> LHsExpr p -> LHsExpr p -> HsExpr p
SectionL EpAnnCO
noComments GenLocated SrcSpanAnnA (HsExpr GhcPs)
x' GenLocated SrcSpanAnnA (HsExpr GhcPs)
s' }

    cvt (InfixE Maybe Exp
Nothing  Exp
s Maybe Exp
Nothing ) = forall a. Exp -> CvtM a -> CvtM a
ensureValidOpExp Exp
s forall a b. (a -> b) -> a -> b
$
                                       do { GenLocated SrcSpanAnnA (HsExpr GhcPs)
s' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
s
                                          ; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (id :: Pass). LHsExpr (GhcPass id) -> HsExpr (GhcPass id)
gHsPar GenLocated SrcSpanAnnA (HsExpr GhcPs)
s' }
                                       -- Can I indicate this is an infix thing?
                                       -- Note [Dropping constructors]

    cvt (UInfixE Exp
x Exp
s Exp
y)  = forall a. Exp -> CvtM a -> CvtM a
ensureValidOpExp Exp
s forall a b. (a -> b) -> a -> b
$
                           do { GenLocated SrcSpanAnnA (HsExpr GhcPs)
x' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
x
                              ; let x'' :: GenLocated SrcSpanAnnA (HsExpr GhcPs)
x'' = case forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (HsExpr GhcPs)
x' of
                                            OpApp {} -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
x'
                                            HsExpr GhcPs
_ -> forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkLHsPar GenLocated SrcSpanAnnA (HsExpr GhcPs)
x'
                              ; LHsExpr GhcPs
-> Exp -> Exp -> CvtM' ConversionFailReason (HsExpr GhcPs)
cvtOpApp GenLocated SrcSpanAnnA (HsExpr GhcPs)
x'' Exp
s Exp
y } --  Note [Converting UInfix]

    cvt (ParensE Exp
e)      = do { GenLocated SrcSpanAnnA (HsExpr GhcPs)
e' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
e; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (id :: Pass). LHsExpr (GhcPass id) -> HsExpr (GhcPass id)
gHsPar GenLocated SrcSpanAnnA (HsExpr GhcPs)
e' }
    cvt (SigE Exp
e Type
t)       = do { GenLocated SrcSpanAnnA (HsExpr GhcPs)
e' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
e; GenLocated SrcSpanAnnA (HsSigType GhcPs)
t' <- Type -> CvtM (LHsSigType GhcPs)
cvtSigType Type
t
                              ; let pe :: LHsExpr GhcPs
pe = forall (p :: Pass).
IsPass p =>
PprPrec -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
parenthesizeHsExpr PprPrec
sigPrec GenLocated SrcSpanAnnA (HsExpr GhcPs)
e'
                              ; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p.
XExprWithTySig p
-> LHsExpr p -> LHsSigWcType (NoGhcTc p) -> HsExpr p
ExprWithTySig forall a. EpAnn a
noAnn LHsExpr GhcPs
pe (forall thing. thing -> HsWildCardBndrs GhcPs thing
mkHsWildCardBndrs GenLocated SrcSpanAnnA (HsSigType GhcPs)
t') }
    cvt (RecConE Name
c [FieldExp]
flds) = do { LocatedN RdrName
c' <- Name -> CvtM (LocatedN RdrName)
cNameN Name
c
                              ; [GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs))
      (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
flds' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall t.
(RdrName -> CvtM t)
-> FieldExp
-> CvtM (LHsFieldBind GhcPs (LocatedAn NoEpAnns t) (LHsExpr GhcPs))
cvtFld (forall ann a b. (LocatedAn ann a -> b) -> a -> CvtM b
wrapParLA LocatedN RdrName -> FieldOcc GhcPs
mkFieldOcc)) [FieldExp]
flds
                              ; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ LocatedN RdrName
-> HsRecordBinds GhcPs -> EpAnn [AddEpAnn] -> HsExpr GhcPs
mkRdrRecordCon LocatedN RdrName
c' (forall p arg.
[LHsRecField p arg]
-> Maybe (XRec p RecFieldsDotDot) -> HsRecFields p arg
HsRecFields [GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs))
      (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
flds' forall a. Maybe a
Nothing) forall a. EpAnn a
noAnn }
    cvt (RecUpdE Exp
e [FieldExp]
flds) = do { GenLocated SrcSpanAnnA (HsExpr GhcPs)
e' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
e
                              ; [GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (LocatedAn NoEpAnns (AmbiguousFieldOcc GhcPs))
      (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
flds'
                                  <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall t.
(RdrName -> CvtM t)
-> FieldExp
-> CvtM (LHsFieldBind GhcPs (LocatedAn NoEpAnns t) (LHsExpr GhcPs))
cvtFld (forall ann a b. (LocatedAn ann a -> b) -> a -> CvtM b
wrapParLA LocatedN RdrName -> AmbiguousFieldOcc GhcPs
mkAmbiguousFieldOcc))
                                           [FieldExp]
flds
                              ; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p.
XRecordUpd p
-> LHsExpr p
-> Either [LHsRecUpdField p] [LHsRecUpdProj p]
-> HsExpr p
RecordUpd forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (HsExpr GhcPs)
e' (forall a b. a -> Either a b
Left [GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (LocatedAn NoEpAnns (AmbiguousFieldOcc GhcPs))
      (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
flds') }
    cvt (StaticE Exp
e)      = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall p. XStatic p -> LHsExpr p -> HsExpr p
HsStatic forall a. EpAnn a
noAnn) forall a b. (a -> b) -> a -> b
$ Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
e
    cvt (UnboundVarE Name
s)  = do -- Use of 'vcName' here instead of 'vName' is
                              -- important, because UnboundVarE may contain
                              -- constructor names - see #14627.
                              { RdrName
s' <- Name -> CvtM RdrName
vcName Name
s
                              ; forall ann a b. (LocatedAn ann a -> b) -> a -> CvtM b
wrapParLA (forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
noExtField) RdrName
s' }
    cvt (LabelE String
s)       = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p. XOverLabel p -> SourceText -> CLabelString -> HsExpr p
HsOverLabel EpAnnCO
noComments SourceText
NoSourceText (String -> CLabelString
fsLit String
s)
    cvt (ImplicitParamVarE String
n) = do { HsIPName
n' <- String -> CvtM HsIPName
ipName String
n; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p. XIPVar p -> HsIPName -> HsExpr p
HsIPVar EpAnnCO
noComments HsIPName
n' }
    cvt (GetFieldE Exp
exp String
f) = do { GenLocated SrcSpanAnnA (HsExpr GhcPs)
e' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
exp
                               ; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p.
XGetField p -> LHsExpr p -> XRec p (DotFieldOcc p) -> HsExpr p
HsGetField EpAnnCO
noComments GenLocated SrcSpanAnnA (HsExpr GhcPs)
e'
                                         (forall l e. l -> e -> GenLocated l e
L forall ann. SrcAnn ann
noSrcSpanA (forall p.
XCDotFieldOcc p -> XRec p FieldLabelString -> DotFieldOcc p
DotFieldOcc forall a. EpAnn a
noAnn (forall l e. l -> e -> GenLocated l e
L forall ann. SrcAnn ann
noSrcSpanA (CLabelString -> FieldLabelString
FieldLabelString (String -> CLabelString
fsLit String
f))))) }
    cvt (ProjectionE NonEmpty String
xs) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p.
XProjection p -> NonEmpty (XRec p (DotFieldOcc p)) -> HsExpr p
HsProjection forall a. EpAnn a
noAnn forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
                                         (forall l e. l -> e -> GenLocated l e
L forall ann. SrcAnn ann
noSrcSpanA forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p.
XCDotFieldOcc p -> XRec p FieldLabelString -> DotFieldOcc p
DotFieldOcc forall a. EpAnn a
noAnn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. l -> e -> GenLocated l e
L forall ann. SrcAnn ann
noSrcSpanA forall b c a. (b -> c) -> (a -> b) -> a -> c
. CLabelString -> FieldLabelString
FieldLabelString  forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> CLabelString
fsLit) NonEmpty String
xs

{- | #16895 Ensure an infix expression's operator is a variable/constructor.
Consider this example:

  $(uInfixE [|1|] [|id id|] [|2|])

This infix expression is obviously ill-formed so we use this helper function
to reject such programs outright.

The constructors `ensureValidOpExp` permits should be in sync with `pprInfixExp`
in Language.Haskell.TH.Ppr from the template-haskell library.
-}
ensureValidOpExp :: TH.Exp -> CvtM a -> CvtM a
ensureValidOpExp :: forall a. Exp -> CvtM a -> CvtM a
ensureValidOpExp (VarE Name
_n) CvtM a
m = CvtM a
m
ensureValidOpExp (ConE Name
_n) CvtM a
m = CvtM a
m
ensureValidOpExp (UnboundVarE Name
_n) CvtM a
m = CvtM a
m
ensureValidOpExp Exp
_e CvtM a
_m = forall a. ConversionFailReason -> CvtM a
failWith ConversionFailReason
NonVarInInfixExpr

{- Note [Dropping constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When we drop constructors from the input, we must insert parentheses around the
argument. For example:

  UInfixE x * (AppE (InfixE (Just y) + Nothing) z)

If we convert the InfixE expression to an operator section but don't insert
parentheses, the above expression would be reassociated to

  OpApp (OpApp x * y) + z

which we don't want.
-}

cvtFld :: (RdrName -> CvtM t) -> (TH.Name, TH.Exp)
       -> CvtM (LHsFieldBind GhcPs (LocatedAn NoEpAnns t) (LHsExpr GhcPs))
cvtFld :: forall t.
(RdrName -> CvtM t)
-> FieldExp
-> CvtM (LHsFieldBind GhcPs (LocatedAn NoEpAnns t) (LHsExpr GhcPs))
cvtFld RdrName -> CvtM t
f (Name
v,Exp
e)
  = do  { LocatedA RdrName
v' <- Name -> CvtM (LocatedA RdrName)
vNameL Name
v
        ; GenLocated SrcSpanAnnA t
lhs' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse RdrName -> CvtM t
f LocatedA RdrName
v'
        ; GenLocated SrcSpanAnnA (HsExpr GhcPs)
e' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
e
        ; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ HsFieldBind { hfbAnn :: XHsFieldBind (LocatedAn NoEpAnns t)
hfbAnn = forall a. EpAnn a
noAnn
                                 , hfbLHS :: LocatedAn NoEpAnns t
hfbLHS = forall ann1 a2 ann2. LocatedAn ann1 a2 -> LocatedAn ann2 a2
la2la GenLocated SrcSpanAnnA t
lhs'
                                 , hfbRHS :: GenLocated SrcSpanAnnA (HsExpr GhcPs)
hfbRHS = GenLocated SrcSpanAnnA (HsExpr GhcPs)
e'
                                 , hfbPun :: Bool
hfbPun = Bool
False} }

cvtDD :: Range -> CvtM (ArithSeqInfo GhcPs)
cvtDD :: Range -> CvtM (ArithSeqInfo GhcPs)
cvtDD (FromR Exp
x)           = do { GenLocated SrcSpanAnnA (HsExpr GhcPs)
x' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
x; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall id. LHsExpr id -> ArithSeqInfo id
From GenLocated SrcSpanAnnA (HsExpr GhcPs)
x' }
cvtDD (FromThenR Exp
x Exp
y)     = do { GenLocated SrcSpanAnnA (HsExpr GhcPs)
x' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
x; GenLocated SrcSpanAnnA (HsExpr GhcPs)
y' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
y; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall id. LHsExpr id -> LHsExpr id -> ArithSeqInfo id
FromThen GenLocated SrcSpanAnnA (HsExpr GhcPs)
x' GenLocated SrcSpanAnnA (HsExpr GhcPs)
y' }
cvtDD (FromToR Exp
x Exp
y)       = do { GenLocated SrcSpanAnnA (HsExpr GhcPs)
x' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
x; GenLocated SrcSpanAnnA (HsExpr GhcPs)
y' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
y; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall id. LHsExpr id -> LHsExpr id -> ArithSeqInfo id
FromTo GenLocated SrcSpanAnnA (HsExpr GhcPs)
x' GenLocated SrcSpanAnnA (HsExpr GhcPs)
y' }
cvtDD (FromThenToR Exp
x Exp
y Exp
z) = do { GenLocated SrcSpanAnnA (HsExpr GhcPs)
x' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
x; GenLocated SrcSpanAnnA (HsExpr GhcPs)
y' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
y; GenLocated SrcSpanAnnA (HsExpr GhcPs)
z' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
z; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall id.
LHsExpr id -> LHsExpr id -> LHsExpr id -> ArithSeqInfo id
FromThenTo GenLocated SrcSpanAnnA (HsExpr GhcPs)
x' GenLocated SrcSpanAnnA (HsExpr GhcPs)
y' GenLocated SrcSpanAnnA (HsExpr GhcPs)
z' }

cvt_tup :: [Maybe Exp] -> Boxity -> CvtM (HsExpr GhcPs)
cvt_tup :: [Maybe Exp] -> Boxity -> CvtM' ConversionFailReason (HsExpr GhcPs)
cvt_tup [Maybe Exp]
es Boxity
boxity = do { let cvtl_maybe :: Maybe Exp -> CvtM' ConversionFailReason (HsTupArg GhcPs)
cvtl_maybe Maybe Exp
Nothing  = forall (m :: * -> *) a. Monad m => a -> m a
return (EpAnn EpaLocation -> HsTupArg GhcPs
missingTupArg forall a. EpAnn a
noAnn)
                             cvtl_maybe (Just Exp
e) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall id. XPresent id -> LHsExpr id -> HsTupArg id
Present forall a. EpAnn a
noAnn) (Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
e)
                       ; [HsTupArg GhcPs]
es' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Maybe Exp -> CvtM' ConversionFailReason (HsTupArg GhcPs)
cvtl_maybe [Maybe Exp]
es
                       ; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p. XExplicitTuple p -> [HsTupArg p] -> Boxity -> HsExpr p
ExplicitTuple
                                    forall a. EpAnn a
noAnn
                                    [HsTupArg GhcPs]
es'
                                    Boxity
boxity }

{- Note [Operator association]
   ~~~~~~~~~~~~~~~~~~~~~~~~~~~
We must be quite careful about adding parens:
  * Infix (UInfix ...) op arg      Needs parens round the first arg
  * Infix (Infix ...) op arg       Needs parens round the first arg
  * UInfix (UInfix ...) op arg     No parens for first arg
  * UInfix (Infix ...) op arg      Needs parens round first arg


Note [Converting UInfix]
~~~~~~~~~~~~~~~~~~~~~~~~
When converting @UInfixE@, @UInfixP@, @UInfixT@, and @PromotedUInfixT@ values,
we want to readjust the trees to reflect the fixities of the underlying
operators:

  UInfixE x * (UInfixE y + z) ---> (x * y) + z

This is done by the renamer (see @mkOppAppRn@, @mkConOppPatRn@, and
@mkHsOpTyRn@ in GHC.Rename.HsType), which expects that the input will be
completely right-biased for types and left-biased for everything else. So we
left-bias the trees of @UInfixP@ and @UInfixE@ and right-bias the trees of
@UInfixT@ and @PromotedUnfixT@.

Sample input:

  UInfixE
   (UInfixE x op1 y)
   op2
   (UInfixE z op3 w)

Sample output:

  OpApp
    (OpApp
      (OpApp x op1 y)
      op2
      z)
    op3
    w

The functions @cvtOpApp@, @cvtOpAppP@, and @cvtOpAppT@ are responsible for this
biasing.
-}

{- | @cvtOpApp x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@.
The produced tree of infix expressions will be left-biased, provided @x@ is.

We can see that @cvtOpApp@ is correct as follows. The inductive hypothesis
is that @cvtOpApp x op y@ is left-biased, provided @x@ is. It is clear that
this holds for both branches (of @cvtOpApp@), provided we assume it holds for
the recursive calls to @cvtOpApp@.

When we call @cvtOpApp@ from @cvtl@, the first argument will always be left-biased
since we have already run @cvtl@ on it.
-}
cvtOpApp :: LHsExpr GhcPs -> TH.Exp -> TH.Exp -> CvtM (HsExpr GhcPs)
cvtOpApp :: LHsExpr GhcPs
-> Exp -> Exp -> CvtM' ConversionFailReason (HsExpr GhcPs)
cvtOpApp LHsExpr GhcPs
x Exp
op1 (UInfixE Exp
y Exp
op2 Exp
z)
  = do { GenLocated SrcSpanAnnA (HsExpr GhcPs)
l <- forall a. CvtM a -> CvtM (LocatedA a)
wrapLA forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs
-> Exp -> Exp -> CvtM' ConversionFailReason (HsExpr GhcPs)
cvtOpApp LHsExpr GhcPs
x Exp
op1 Exp
y
       ; LHsExpr GhcPs
-> Exp -> Exp -> CvtM' ConversionFailReason (HsExpr GhcPs)
cvtOpApp GenLocated SrcSpanAnnA (HsExpr GhcPs)
l Exp
op2 Exp
z }
cvtOpApp LHsExpr GhcPs
x Exp
op Exp
y
  = do { GenLocated SrcSpanAnnA (HsExpr GhcPs)
op' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
op
       ; GenLocated SrcSpanAnnA (HsExpr GhcPs)
y' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
y
       ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp forall a. EpAnn a
noAnn LHsExpr GhcPs
x GenLocated SrcSpanAnnA (HsExpr GhcPs)
op' GenLocated SrcSpanAnnA (HsExpr GhcPs)
y') }

-------------------------------------
--      Do notation and statements
-------------------------------------

cvtHsDo :: HsDoFlavour -> [TH.Stmt] -> CvtM (HsExpr GhcPs)
cvtHsDo :: HsDoFlavour -> [Stmt] -> CvtM' ConversionFailReason (HsExpr GhcPs)
cvtHsDo HsDoFlavour
do_or_lc [Stmt]
stmts = case forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [Stmt]
stmts of
    Maybe (NonEmpty Stmt)
Nothing -> forall a. ConversionFailReason -> CvtM a
failWith ConversionFailReason
EmptyStmtListInDoBlock
    Just NonEmpty Stmt
stmts -> do
        { NonEmpty
  (GenLocated
     SrcSpanAnnA
     (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
stmts' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Stmt -> CvtM (LStmt GhcPs (LHsExpr GhcPs))
cvtStmt NonEmpty Stmt
stmts
        ; let stmts'' :: [GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
stmts'' = forall a. NonEmpty a -> [a]
NE.init NonEmpty
  (GenLocated
     SrcSpanAnnA
     (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
stmts'
              last' :: GenLocated
  SrcSpanAnnA
  (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
last' = forall a. NonEmpty a -> a
NE.last NonEmpty
  (GenLocated
     SrcSpanAnnA
     (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
stmts'

        ; GenLocated
  SrcSpanAnnA
  (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
last'' <- case GenLocated
  SrcSpanAnnA
  (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
last' of
                    (L SrcSpanAnnA
loc (BodyStmt XBodyStmt GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
_ GenLocated SrcSpanAnnA (HsExpr GhcPs)
body SyntaxExpr GhcPs
_ SyntaxExpr GhcPs
_))
                      -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (forall (idR :: Pass) (bodyR :: * -> *) (idL :: Pass).
IsPass idR =>
LocatedA (bodyR (GhcPass idR))
-> StmtLR
     (GhcPass idL) (GhcPass idR) (LocatedA (bodyR (GhcPass idR)))
mkLastStmt GenLocated SrcSpanAnnA (HsExpr GhcPs)
body))
                    GenLocated
  SrcSpanAnnA
  (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
_ -> forall a. ConversionFailReason -> CvtM a
failWith (GenLocated
  SrcSpanAnnA
  (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> ConversionFailReason
bad_last GenLocated
  SrcSpanAnnA
  (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
last')

        ; forall ann a b. (LocatedAn ann a -> b) -> a -> CvtM b
wrapParLA (forall p. XDo p -> HsDoFlavour -> XRec p [ExprLStmt p] -> HsExpr p
HsDo forall a. EpAnn a
noAnn HsDoFlavour
do_or_lc) ([GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
stmts'' forall a. [a] -> [a] -> [a]
++ [GenLocated
  SrcSpanAnnA
  (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
last'']) }
  where
    bad_last :: GenLocated
  SrcSpanAnnA
  (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> ConversionFailReason
bad_last GenLocated
  SrcSpanAnnA
  (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
stmt = HsDoFlavour -> LStmt GhcPs (LHsExpr GhcPs) -> ConversionFailReason
IllegalLastStatement HsDoFlavour
do_or_lc GenLocated
  SrcSpanAnnA
  (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
stmt

cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt GhcPs (LHsExpr GhcPs)]
cvtStmts :: [Stmt] -> CvtM [LStmt GhcPs (LHsExpr GhcPs)]
cvtStmts = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Stmt -> CvtM (LStmt GhcPs (LHsExpr GhcPs))
cvtStmt

cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt GhcPs (LHsExpr GhcPs))
cvtStmt :: Stmt -> CvtM (LStmt GhcPs (LHsExpr GhcPs))
cvtStmt (NoBindS Exp
e)    = do { GenLocated SrcSpanAnnA (HsExpr GhcPs)
e' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
e; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ forall (bodyR :: * -> *) (idL :: Pass).
LocatedA (bodyR GhcPs)
-> StmtLR (GhcPass idL) GhcPs (LocatedA (bodyR GhcPs))
mkBodyStmt GenLocated SrcSpanAnnA (HsExpr GhcPs)
e' }
cvtStmt (TH.BindS Pat
p Exp
e) = do { GenLocated SrcSpanAnnA (Pat GhcPs)
p' <- Pat -> CvtM (LPat GhcPs)
cvtPat Pat
p; GenLocated SrcSpanAnnA (HsExpr GhcPs)
e' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
e; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ forall (bodyR :: * -> *).
EpAnn [AddEpAnn]
-> LPat GhcPs
-> LocatedA (bodyR GhcPs)
-> StmtLR GhcPs GhcPs (LocatedA (bodyR GhcPs))
mkPsBindStmt forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (Pat GhcPs)
p' GenLocated SrcSpanAnnA (HsExpr GhcPs)
e' }
cvtStmt (TH.LetS [Dec]
ds)   = do { HsLocalBinds GhcPs
ds' <- THDeclDescriptor -> [Dec] -> CvtM (HsLocalBinds GhcPs)
cvtLocalDecs THDeclDescriptor
LetBinding [Dec]
ds
                            ; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ forall idL idR body.
XLetStmt idL idR body
-> HsLocalBindsLR idL idR -> StmtLR idL idR body
LetStmt forall a. EpAnn a
noAnn HsLocalBinds GhcPs
ds' }
cvtStmt (TH.ParS [[Stmt]]
dss)  = do { [ParStmtBlock GhcPs GhcPs]
dss' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {idR} {p :: Pass}.
(XParStmtBlock GhcPs idR ~ NoExtField,
 SyntaxExprGhc p ~ SyntaxExpr idR, IsPass p) =>
[Stmt] -> CvtM' ConversionFailReason (ParStmtBlock GhcPs idR)
cvt_one [[Stmt]]
dss
                            ; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ forall idL idR body.
XParStmt idL idR body
-> [ParStmtBlock idL idR]
-> HsExpr idR
-> SyntaxExpr idR
-> StmtLR idL idR body
ParStmt NoExtField
noExtField [ParStmtBlock GhcPs GhcPs]
dss' forall (p :: Pass). HsExpr (GhcPass p)
noExpr forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
noSyntaxExpr }
  where
    cvt_one :: [Stmt] -> CvtM' ConversionFailReason (ParStmtBlock GhcPs idR)
cvt_one [Stmt]
ds = do { [GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
ds' <- [Stmt] -> CvtM [LStmt GhcPs (LHsExpr GhcPs)]
cvtStmts [Stmt]
ds
                    ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall idL idR.
XParStmtBlock idL idR
-> [ExprLStmt idL]
-> [IdP idR]
-> SyntaxExpr idR
-> ParStmtBlock idL idR
ParStmtBlock NoExtField
noExtField [GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
ds' forall a. HasCallStack => a
undefined forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
noSyntaxExpr) }
cvtStmt (TH.RecS [Stmt]
ss) = do { [GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
ss' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Stmt -> CvtM (LStmt GhcPs (LHsExpr GhcPs))
cvtStmt [Stmt]
ss
                          ; StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
rec_stmt <- forall ann a b. (LocatedAn ann a -> b) -> a -> CvtM b
wrapParLA (forall (idL :: Pass) bodyR.
(Anno
   [GenLocated
      (Anno (StmtLR (GhcPass idL) GhcPs bodyR))
      (StmtLR (GhcPass idL) GhcPs bodyR)]
 ~ SrcSpanAnnL) =>
EpAnn AnnList
-> LocatedL [LStmtLR (GhcPass idL) GhcPs bodyR]
-> StmtLR (GhcPass idL) GhcPs bodyR
mkRecStmt forall a. EpAnn a
noAnn) [GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
ss'
                          ; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
rec_stmt }

cvtMatch :: HsMatchContext GhcPs
         -> TH.Match -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))
cvtMatch :: HsMatchContext GhcPs
-> Match -> CvtM (LMatch GhcPs (LHsExpr GhcPs))
cvtMatch HsMatchContext GhcPs
ctxt (TH.Match Pat
p Body
body [Dec]
decs)
  = do  { GenLocated SrcSpanAnnA (Pat GhcPs)
p' <- Pat -> CvtM (LPat GhcPs)
cvtPat Pat
p
        ; let lp :: GenLocated SrcSpanAnnA (Pat GhcPs)
lp = case GenLocated SrcSpanAnnA (Pat GhcPs)
p' of
                     (L SrcSpanAnnA
loc SigPat{}) -> forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (forall (pass :: Pass). LPat (GhcPass pass) -> Pat (GhcPass pass)
gParPat GenLocated SrcSpanAnnA (Pat GhcPs)
p') -- #14875
                     GenLocated SrcSpanAnnA (Pat GhcPs)
_                -> GenLocated SrcSpanAnnA (Pat GhcPs)
p'
        ; [GenLocated
   (SrcAnn NoEpAnns)
   (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
g' <- Body -> CvtM [LGRHS GhcPs (LHsExpr GhcPs)]
cvtGuard Body
body
        ; HsLocalBinds GhcPs
decs' <- THDeclDescriptor -> [Dec] -> CvtM (HsLocalBinds GhcPs)
cvtLocalDecs THDeclDescriptor
WhereClause [Dec]
decs
        ; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ forall p body.
XCMatch p body
-> HsMatchContext p -> [LPat p] -> GRHSs p body -> Match p body
Hs.Match forall a. EpAnn a
noAnn HsMatchContext GhcPs
ctxt [GenLocated SrcSpanAnnA (Pat GhcPs)
lp] (forall p body.
XCGRHSs p body -> [LGRHS p body] -> HsLocalBinds p -> GRHSs p body
GRHSs EpAnnComments
emptyComments [GenLocated
   (SrcAnn NoEpAnns)
   (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
g' HsLocalBinds GhcPs
decs') }

cvtGuard :: TH.Body -> CvtM [LGRHS GhcPs (LHsExpr GhcPs)]
cvtGuard :: Body -> CvtM [LGRHS GhcPs (LHsExpr GhcPs)]
cvtGuard (GuardedB [(Guard, Exp)]
pairs) = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Guard, Exp) -> CvtM (LGRHS GhcPs (LHsExpr GhcPs))
cvtpair [(Guard, Exp)]
pairs
cvtGuard (NormalB Exp
e)      = do { GenLocated SrcSpanAnnA (HsExpr GhcPs)
e' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
e
                               ; GenLocated
  (SrcAnn NoEpAnns)
  (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
g' <- forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ forall p body.
XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body
GRHS forall a. EpAnn a
noAnn [] GenLocated SrcSpanAnnA (HsExpr GhcPs)
e'; forall (m :: * -> *) a. Monad m => a -> m a
return [GenLocated
  (SrcAnn NoEpAnns)
  (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
g'] }

cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS GhcPs (LHsExpr GhcPs))
cvtpair :: (Guard, Exp) -> CvtM (LGRHS GhcPs (LHsExpr GhcPs))
cvtpair (NormalG Exp
ge,Exp
rhs) = do { GenLocated SrcSpanAnnA (HsExpr GhcPs)
ge' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
ge; GenLocated SrcSpanAnnA (HsExpr GhcPs)
rhs' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
rhs
                              ; GenLocated
  SrcSpanAnnA
  (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
g' <- forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ forall (bodyR :: * -> *) (idL :: Pass).
LocatedA (bodyR GhcPs)
-> StmtLR (GhcPass idL) GhcPs (LocatedA (bodyR GhcPs))
mkBodyStmt GenLocated SrcSpanAnnA (HsExpr GhcPs)
ge'
                              ; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ forall p body.
XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body
GRHS forall a. EpAnn a
noAnn [GenLocated
  SrcSpanAnnA
  (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
g'] GenLocated SrcSpanAnnA (HsExpr GhcPs)
rhs' }
cvtpair (PatG [Stmt]
gs,Exp
rhs)    = do { [GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
gs' <- [Stmt] -> CvtM [LStmt GhcPs (LHsExpr GhcPs)]
cvtStmts [Stmt]
gs; GenLocated SrcSpanAnnA (HsExpr GhcPs)
rhs' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
rhs
                              ; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ forall p body.
XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body
GRHS forall a. EpAnn a
noAnn [GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
gs' GenLocated SrcSpanAnnA (HsExpr GhcPs)
rhs' }

cvtOverLit :: Lit -> CvtM (HsOverLit GhcPs)
cvtOverLit :: Lit -> CvtM (HsOverLit GhcPs)
cvtOverLit (IntegerL Integer
i)
  = do { forall a. a -> CvtM ()
force Integer
i; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ IntegralLit -> HsOverLit GhcPs
mkHsIntegral   (forall a. Integral a => a -> IntegralLit
mkIntegralLit Integer
i) }
cvtOverLit (RationalL Rational
r)
  = do { forall a. a -> CvtM ()
force Rational
r; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ FractionalLit -> HsOverLit GhcPs
mkHsFractional (Rational -> FractionalLit
mkTHFractionalLit Rational
r) }
cvtOverLit (StringL String
s)
  = do { let { s' :: CLabelString
s' = String -> CLabelString
mkFastString String
s }
       ; forall a. a -> CvtM ()
force CLabelString
s'
       ; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ SourceText -> CLabelString -> HsOverLit GhcPs
mkHsIsString (String -> SourceText
quotedSourceText String
s) CLabelString
s'
       }
cvtOverLit Lit
_ = forall a. HasCallStack => String -> a
panic String
"Convert.cvtOverLit: Unexpected overloaded literal"
-- An Integer is like an (overloaded) '3' in a Haskell source program
-- Similarly 3.5 for fractionals

{- Note [Converting strings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If we get (ListE [CharL 'x', CharL 'y']) we'd like to convert to
a string literal for "xy".  Of course, we might hope to get
(LitE (StringL "xy")), but not always, and allCharLs fails quickly
if it isn't a literal string
-}

allCharLs :: [TH.Exp] -> Maybe String
-- Note [Converting strings]
-- NB: only fire up this setup for a non-empty list, else
--     there's a danger of returning "" for [] :: [Int]!
allCharLs :: [Exp] -> Maybe String
allCharLs [Exp]
xs
  = case [Exp]
xs of
      LitE (CharL Char
c) : [Exp]
ys -> String -> [Exp] -> Maybe String
go [Char
c] [Exp]
ys
      [Exp]
_                   -> forall a. Maybe a
Nothing
  where
    go :: String -> [Exp] -> Maybe String
go String
cs []                    = forall a. a -> Maybe a
Just (forall a. [a] -> [a]
reverse String
cs)
    go String
cs (LitE (CharL Char
c) : [Exp]
ys) = String -> [Exp] -> Maybe String
go (Char
cforall a. a -> [a] -> [a]
:String
cs) [Exp]
ys
    go String
_  [Exp]
_                     = forall a. Maybe a
Nothing

cvtLit :: Lit -> CvtM (HsLit GhcPs)
cvtLit :: Lit -> CvtM (HsLit GhcPs)
cvtLit (IntPrimL Integer
i)    = do { forall a. a -> CvtM ()
force Integer
i; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall x. XHsIntPrim x -> Integer -> HsLit x
HsIntPrim SourceText
NoSourceText Integer
i }
cvtLit (WordPrimL Integer
w)   = do { forall a. a -> CvtM ()
force Integer
w; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall x. XHsWordPrim x -> Integer -> HsLit x
HsWordPrim SourceText
NoSourceText Integer
w }
cvtLit (FloatPrimL Rational
f)
  = do { forall a. a -> CvtM ()
force Rational
f; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall x. XHsFloatPrim x -> FractionalLit -> HsLit x
HsFloatPrim NoExtField
noExtField (Rational -> FractionalLit
mkTHFractionalLit Rational
f) }
cvtLit (DoublePrimL Rational
f)
  = do { forall a. a -> CvtM ()
force Rational
f; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall x. XHsDoublePrim x -> FractionalLit -> HsLit x
HsDoublePrim NoExtField
noExtField (Rational -> FractionalLit
mkTHFractionalLit Rational
f) }
cvtLit (CharL Char
c)       = do { forall a. a -> CvtM ()
force Char
c; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall x. XHsChar x -> Char -> HsLit x
HsChar SourceText
NoSourceText Char
c }
cvtLit (CharPrimL Char
c)   = do { forall a. a -> CvtM ()
force Char
c; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall x. XHsCharPrim x -> Char -> HsLit x
HsCharPrim SourceText
NoSourceText Char
c }
cvtLit (StringL String
s)     = do { let { s' :: CLabelString
s' = String -> CLabelString
mkFastString String
s }
                            ; forall a. a -> CvtM ()
force CLabelString
s'
                            ; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall x. XHsString x -> CLabelString -> HsLit x
HsString (String -> SourceText
quotedSourceText String
s) CLabelString
s' }
cvtLit (StringPrimL [Word8]
s) = do { let { !s' :: ByteString
s' = [Word8] -> ByteString
BS.pack [Word8]
s }
                            ; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall x. XHsStringPrim x -> ByteString -> HsLit x
HsStringPrim SourceText
NoSourceText ByteString
s' }
cvtLit (BytesPrimL (Bytes ForeignPtr Word8
fptr Word
off Word
sz)) = do
  let bs :: ByteString
bs = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fptr forall a b. (a -> b) -> a -> b
$ \Ptr Word8
ptr ->
             CStringLen -> IO ByteString
BS.packCStringLen (Ptr Word8
ptr forall a b. Ptr a -> Int -> Ptr b
`plusPtr` forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
off, forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
sz)
  forall a. a -> CvtM ()
force ByteString
bs
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall x. XHsStringPrim x -> ByteString -> HsLit x
HsStringPrim SourceText
NoSourceText ByteString
bs
cvtLit Lit
_ = forall a. HasCallStack => String -> a
panic String
"Convert.cvtLit: Unexpected literal"
        -- cvtLit should not be called on IntegerL, RationalL
        -- That precondition is established right here in
        -- "GHC.ThToHs", hence panic

quotedSourceText :: String -> SourceText
quotedSourceText :: String -> SourceText
quotedSourceText String
s = String -> SourceText
SourceText forall a b. (a -> b) -> a -> b
$ String
"\"" forall a. [a] -> [a] -> [a]
++ String
s forall a. [a] -> [a] -> [a]
++ String
"\""

cvtPats :: [TH.Pat] -> CvtM [Hs.LPat GhcPs]
cvtPats :: [Pat] -> CvtM [LPat GhcPs]
cvtPats [Pat]
pats = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pat -> CvtM (LPat GhcPs)
cvtPat [Pat]
pats

cvtPat :: TH.Pat -> CvtM (Hs.LPat GhcPs)
cvtPat :: Pat -> CvtM (LPat GhcPs)
cvtPat Pat
pat = forall a. CvtM a -> CvtM (LocatedA a)
wrapLA (Pat -> CvtM (Pat GhcPs)
cvtp Pat
pat)

cvtp :: TH.Pat -> CvtM (Hs.Pat GhcPs)
cvtp :: Pat -> CvtM (Pat GhcPs)
cvtp (TH.LitP Lit
l)
  | Lit -> Bool
overloadedLit Lit
l    = do { HsOverLit GhcPs
l' <- Lit -> CvtM (HsOverLit GhcPs)
cvtOverLit Lit
l
                            ; LocatedAn NoEpAnns (HsOverLit GhcPs)
l'' <- forall e ann. e -> CvtM (LocatedAn ann e)
returnLA HsOverLit GhcPs
l'
                            ; forall (m :: * -> *) a. Monad m => a -> m a
return (LocatedAn NoEpAnns (HsOverLit GhcPs)
-> Maybe (SyntaxExpr GhcPs) -> EpAnn [AddEpAnn] -> Pat GhcPs
mkNPat LocatedAn NoEpAnns (HsOverLit GhcPs)
l'' forall a. Maybe a
Nothing forall a. EpAnn a
noAnn) }
                                  -- Not right for negative patterns;
                                  -- need to think about that!
  | Bool
otherwise          = do { HsLit GhcPs
l' <- Lit -> CvtM (HsLit GhcPs)
cvtLit Lit
l; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p. XLitPat p -> HsLit p -> Pat p
Hs.LitPat NoExtField
noExtField HsLit GhcPs
l' }
cvtp (TH.VarP Name
s)       = do { RdrName
s' <- Name -> CvtM RdrName
vName Name
s
                            ; forall ann a b. (LocatedAn ann a -> b) -> a -> CvtM b
wrapParLA (forall p. XVarPat p -> LIdP p -> Pat p
Hs.VarPat NoExtField
noExtField) RdrName
s' }
cvtp (TupP [Pat]
ps)         = do { [GenLocated SrcSpanAnnA (Pat GhcPs)]
ps' <- [Pat] -> CvtM [LPat GhcPs]
cvtPats [Pat]
ps
                            ; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p. XTuplePat p -> [LPat p] -> Boxity -> Pat p
TuplePat forall a. EpAnn a
noAnn [GenLocated SrcSpanAnnA (Pat GhcPs)]
ps' Boxity
Boxed }
cvtp (UnboxedTupP [Pat]
ps)  = do { [GenLocated SrcSpanAnnA (Pat GhcPs)]
ps' <- [Pat] -> CvtM [LPat GhcPs]
cvtPats [Pat]
ps
                            ; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p. XTuplePat p -> [LPat p] -> Boxity -> Pat p
TuplePat forall a. EpAnn a
noAnn [GenLocated SrcSpanAnnA (Pat GhcPs)]
ps' Boxity
Unboxed }
cvtp (UnboxedSumP Pat
p Int
alt Int
arity)
                       = do { GenLocated SrcSpanAnnA (Pat GhcPs)
p' <- Pat -> CvtM (LPat GhcPs)
cvtPat Pat
p
                            ; Int -> Int -> CvtM ()
unboxedSumChecks Int
alt Int
arity
                            ; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p. XSumPat p -> LPat p -> Int -> Int -> Pat p
SumPat forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (Pat GhcPs)
p' Int
alt Int
arity }
cvtp (ConP Name
s [Type]
ts [Pat]
ps)    = do { LocatedN RdrName
s' <- Name -> CvtM (LocatedN RdrName)
cNameN Name
s
                            ; [GenLocated SrcSpanAnnA (Pat GhcPs)]
ps' <- [Pat] -> CvtM [LPat GhcPs]
cvtPats [Pat]
ps
                            ; [GenLocated SrcSpanAnnA (HsType GhcPs)]
ts' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> CvtM (LHsType GhcPs)
cvtType [Type]
ts
                            ; let pps :: [GenLocated SrcSpanAnnA (Pat GhcPs)]
pps = forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: Pass).
IsPass p =>
PprPrec -> LPat (GhcPass p) -> LPat (GhcPass p)
parenthesizePat PprPrec
appPrec) [GenLocated SrcSpanAnnA (Pat GhcPs)]
ps'
                                  pts :: [HsConPatTyArg GhcPs]
pts = forall a b. (a -> b) -> [a] -> [b]
map (\GenLocated SrcSpanAnnA (HsType GhcPs)
t -> forall p. LHsToken "@" p -> HsPatSigType p -> HsConPatTyArg p
HsConPatTyArg forall (tok :: Symbol). GenLocated TokenLocation (HsToken tok)
noHsTok (EpAnnCO -> LHsType GhcPs -> HsPatSigType GhcPs
mkHsPatSigType forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (HsType GhcPs)
t)) [GenLocated SrcSpanAnnA (HsType GhcPs)]
ts'
                            ; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ConPat
                                { pat_con_ext :: XConPat GhcPs
pat_con_ext = forall a. EpAnn a
noAnn
                                , pat_con :: XRec GhcPs (ConLikeP GhcPs)
pat_con = LocatedN RdrName
s'
                                , pat_args :: HsConPatDetails GhcPs
pat_args = forall tyarg arg rec.
[tyarg] -> [arg] -> HsConDetails tyarg arg rec
PrefixCon [HsConPatTyArg GhcPs]
pts [GenLocated SrcSpanAnnA (Pat GhcPs)]
pps
                                }
                            }
cvtp (InfixP Pat
p1 Name
s Pat
p2)  = do { LocatedN RdrName
s' <- Name -> CvtM (LocatedN RdrName)
cNameN Name
s; GenLocated SrcSpanAnnA (Pat GhcPs)
p1' <- Pat -> CvtM (LPat GhcPs)
cvtPat Pat
p1; GenLocated SrcSpanAnnA (Pat GhcPs)
p2' <- Pat -> CvtM (LPat GhcPs)
cvtPat Pat
p2
                            ; forall ann a b. (LocatedAn ann a -> b) -> a -> CvtM b
wrapParLA forall (pass :: Pass). LPat (GhcPass pass) -> Pat (GhcPass pass)
gParPat forall a b. (a -> b) -> a -> b
$
                              ConPat
                                { pat_con_ext :: XConPat GhcPs
pat_con_ext = forall a. EpAnn a
noAnn
                                , pat_con :: XRec GhcPs (ConLikeP GhcPs)
pat_con = LocatedN RdrName
s'
                                , pat_args :: HsConPatDetails GhcPs
pat_args = forall tyarg arg rec. arg -> arg -> HsConDetails tyarg arg rec
InfixCon
                                    (forall (p :: Pass).
IsPass p =>
PprPrec -> LPat (GhcPass p) -> LPat (GhcPass p)
parenthesizePat PprPrec
opPrec GenLocated SrcSpanAnnA (Pat GhcPs)
p1')
                                    (forall (p :: Pass).
IsPass p =>
PprPrec -> LPat (GhcPass p) -> LPat (GhcPass p)
parenthesizePat PprPrec
opPrec GenLocated SrcSpanAnnA (Pat GhcPs)
p2')
                                }
                            }
                            -- See Note [Operator association]
cvtp (UInfixP Pat
p1 Name
s Pat
p2) = do { GenLocated SrcSpanAnnA (Pat GhcPs)
p1' <- Pat -> CvtM (LPat GhcPs)
cvtPat Pat
p1; LPat GhcPs -> Name -> Pat -> CvtM (Pat GhcPs)
cvtOpAppP GenLocated SrcSpanAnnA (Pat GhcPs)
p1' Name
s Pat
p2 } -- Note [Converting UInfix]
cvtp (ParensP Pat
p)       = do { GenLocated SrcSpanAnnA (Pat GhcPs)
p' <- Pat -> CvtM (LPat GhcPs)
cvtPat Pat
p;
                            ; case forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (Pat GhcPs)
p' of  -- may be wrapped ConPatIn
                                ParPat {} -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (Pat GhcPs)
p'
                                Pat GhcPs
_         -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (pass :: Pass). LPat (GhcPass pass) -> Pat (GhcPass pass)
gParPat GenLocated SrcSpanAnnA (Pat GhcPs)
p' }
cvtp (TildeP Pat
p)        = do { GenLocated SrcSpanAnnA (Pat GhcPs)
p' <- Pat -> CvtM (LPat GhcPs)
cvtPat Pat
p; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p. XLazyPat p -> LPat p -> Pat p
LazyPat forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (Pat GhcPs)
p' }
cvtp (BangP Pat
p)         = do { GenLocated SrcSpanAnnA (Pat GhcPs)
p' <- Pat -> CvtM (LPat GhcPs)
cvtPat Pat
p; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p. XBangPat p -> LPat p -> Pat p
BangPat forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (Pat GhcPs)
p' }
cvtp (TH.AsP Name
s Pat
p)      = do { LocatedN RdrName
s' <- Name -> CvtM (LocatedN RdrName)
vNameN Name
s; GenLocated SrcSpanAnnA (Pat GhcPs)
p' <- Pat -> CvtM (LPat GhcPs)
cvtPat Pat
p
                            ; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p. XAsPat p -> LIdP p -> LHsToken "@" p -> LPat p -> Pat p
AsPat forall a. EpAnn a
noAnn LocatedN RdrName
s' forall (tok :: Symbol). GenLocated TokenLocation (HsToken tok)
noHsTok GenLocated SrcSpanAnnA (Pat GhcPs)
p' }
cvtp Pat
TH.WildP          = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p. XWildPat p -> Pat p
WildPat NoExtField
noExtField
cvtp (RecP Name
c [FieldPat]
fs)       = do { LocatedN RdrName
c' <- Name -> CvtM (LocatedN RdrName)
cNameN Name
c; [GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs))
      (GenLocated SrcSpanAnnA (Pat GhcPs)))]
fs' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FieldPat -> CvtM (LHsRecField GhcPs (LPat GhcPs))
cvtPatFld [FieldPat]
fs
                            ; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ConPat
                                { pat_con_ext :: XConPat GhcPs
pat_con_ext = forall a. EpAnn a
noAnn
                                , pat_con :: XRec GhcPs (ConLikeP GhcPs)
pat_con = LocatedN RdrName
c'
                                , pat_args :: HsConPatDetails GhcPs
pat_args = forall tyarg arg rec. rec -> HsConDetails tyarg arg rec
Hs.RecCon forall a b. (a -> b) -> a -> b
$ forall p arg.
[LHsRecField p arg]
-> Maybe (XRec p RecFieldsDotDot) -> HsRecFields p arg
HsRecFields [GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs))
      (GenLocated SrcSpanAnnA (Pat GhcPs)))]
fs' forall a. Maybe a
Nothing
                                }
                            }
cvtp (ListP [Pat]
ps)        = do { [GenLocated SrcSpanAnnA (Pat GhcPs)]
ps' <- [Pat] -> CvtM [LPat GhcPs]
cvtPats [Pat]
ps
                            ; forall (m :: * -> *) a. Monad m => a -> m a
return
                                   forall a b. (a -> b) -> a -> b
$ forall p. XListPat p -> [LPat p] -> Pat p
ListPat forall a. EpAnn a
noAnn [GenLocated SrcSpanAnnA (Pat GhcPs)]
ps'}
cvtp (SigP Pat
p Type
t)        = do { GenLocated SrcSpanAnnA (Pat GhcPs)
p' <- Pat -> CvtM (LPat GhcPs)
cvtPat Pat
p; GenLocated SrcSpanAnnA (HsType GhcPs)
t' <- Type -> CvtM (LHsType GhcPs)
cvtType Type
t
                            ; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p. XSigPat p -> LPat p -> HsPatSigType (NoGhcTc p) -> Pat p
SigPat forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (Pat GhcPs)
p' (EpAnnCO -> LHsType GhcPs -> HsPatSigType GhcPs
mkHsPatSigType forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (HsType GhcPs)
t') }
cvtp (ViewP Exp
e Pat
p)       = do { GenLocated SrcSpanAnnA (HsExpr GhcPs)
e' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
e; GenLocated SrcSpanAnnA (Pat GhcPs)
p' <- Pat -> CvtM (LPat GhcPs)
cvtPat Pat
p
                            ; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p. XViewPat p -> LHsExpr p -> LPat p -> Pat p
ViewPat forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (HsExpr GhcPs)
e' GenLocated SrcSpanAnnA (Pat GhcPs)
p'}

cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField GhcPs (LPat GhcPs))
cvtPatFld :: FieldPat -> CvtM (LHsRecField GhcPs (LPat GhcPs))
cvtPatFld (Name
s,Pat
p)
  = do  { L SrcSpanAnnN
ls RdrName
s' <- Name -> CvtM (LocatedN RdrName)
vNameN Name
s
        ; GenLocated SrcSpanAnnA (Pat GhcPs)
p' <- Pat -> CvtM (LPat GhcPs)
cvtPat Pat
p
        ; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ HsFieldBind { hfbAnn :: XHsFieldBind (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs))
hfbAnn = forall a. EpAnn a
noAnn
                                 , hfbLHS :: GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs)
hfbLHS
                                    = forall l e. l -> e -> GenLocated l e
L (forall a ann. SrcSpanAnn' a -> SrcAnn ann
l2l SrcSpanAnnN
ls) forall a b. (a -> b) -> a -> b
$ LocatedN RdrName -> FieldOcc GhcPs
mkFieldOcc (forall l e. l -> e -> GenLocated l e
L (forall a ann. SrcSpanAnn' a -> SrcAnn ann
l2l SrcSpanAnnN
ls) RdrName
s')
                                 , hfbRHS :: GenLocated SrcSpanAnnA (Pat GhcPs)
hfbRHS = GenLocated SrcSpanAnnA (Pat GhcPs)
p'
                                 , hfbPun :: Bool
hfbPun = Bool
False} }

{- | @cvtOpAppP x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@.
The produced tree of infix patterns will be left-biased, provided @x@ is.

See the @cvtOpApp@ documentation for how this function works.
-}
cvtOpAppP :: Hs.LPat GhcPs -> TH.Name -> TH.Pat -> CvtM (Hs.Pat GhcPs)
cvtOpAppP :: LPat GhcPs -> Name -> Pat -> CvtM (Pat GhcPs)
cvtOpAppP LPat GhcPs
x Name
op1 (UInfixP Pat
y Name
op2 Pat
z)
  = do { GenLocated SrcSpanAnnA (Pat GhcPs)
l <- forall a. CvtM a -> CvtM (LocatedA a)
wrapLA forall a b. (a -> b) -> a -> b
$ LPat GhcPs -> Name -> Pat -> CvtM (Pat GhcPs)
cvtOpAppP LPat GhcPs
x Name
op1 Pat
y
       ; LPat GhcPs -> Name -> Pat -> CvtM (Pat GhcPs)
cvtOpAppP GenLocated SrcSpanAnnA (Pat GhcPs)
l Name
op2 Pat
z }
cvtOpAppP LPat GhcPs
x Name
op Pat
y
  = do { LocatedN RdrName
op' <- Name -> CvtM (LocatedN RdrName)
cNameN Name
op
       ; GenLocated SrcSpanAnnA (Pat GhcPs)
y' <- Pat -> CvtM (LPat GhcPs)
cvtPat Pat
y
       ; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ConPat
          { pat_con_ext :: XConPat GhcPs
pat_con_ext = forall a. EpAnn a
noAnn
          , pat_con :: XRec GhcPs (ConLikeP GhcPs)
pat_con = LocatedN RdrName
op'
          , pat_args :: HsConPatDetails GhcPs
pat_args = forall tyarg arg rec. arg -> arg -> HsConDetails tyarg arg rec
InfixCon LPat GhcPs
x GenLocated SrcSpanAnnA (Pat GhcPs)
y'
          }
       }

-----------------------------------------------------------
--      Types and type variables

class CvtFlag flag flag' | flag -> flag' where
  cvtFlag :: flag -> flag'

instance CvtFlag () () where
  cvtFlag :: () -> ()
cvtFlag () = ()

instance CvtFlag TH.Specificity Hs.Specificity where
  cvtFlag :: Specificity -> Specificity
cvtFlag Specificity
TH.SpecifiedSpec = Specificity
Hs.SpecifiedSpec
  cvtFlag Specificity
TH.InferredSpec  = Specificity
Hs.InferredSpec

cvtTvs :: CvtFlag flag flag' => [TH.TyVarBndr flag] -> CvtM [LHsTyVarBndr flag' GhcPs]
cvtTvs :: forall flag flag'.
CvtFlag flag flag' =>
[TyVarBndr flag] -> CvtM [LHsTyVarBndr flag' GhcPs]
cvtTvs [TyVarBndr flag]
tvs = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall flag flag'.
CvtFlag flag flag' =>
TyVarBndr flag -> CvtM (LHsTyVarBndr flag' GhcPs)
cvt_tv [TyVarBndr flag]
tvs

cvt_tv :: CvtFlag flag flag' => (TH.TyVarBndr flag) -> CvtM (LHsTyVarBndr flag' GhcPs)
cvt_tv :: forall flag flag'.
CvtFlag flag flag' =>
TyVarBndr flag -> CvtM (LHsTyVarBndr flag' GhcPs)
cvt_tv (TH.PlainTV Name
nm flag
fl)
  = do { LocatedN RdrName
nm' <- Name -> CvtM (LocatedN RdrName)
tNameN Name
nm
       ; let fl' :: flag'
fl' = forall flag flag'. CvtFlag flag flag' => flag -> flag'
cvtFlag flag
fl
       ; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ forall flag pass.
XUserTyVar pass -> flag -> LIdP pass -> HsTyVarBndr flag pass
UserTyVar forall a. EpAnn a
noAnn flag'
fl' LocatedN RdrName
nm' }
cvt_tv (TH.KindedTV Name
nm flag
fl Type
ki)
  = do { LocatedN RdrName
nm' <- Name -> CvtM (LocatedN RdrName)
tNameN Name
nm
       ; let fl' :: flag'
fl' = forall flag flag'. CvtFlag flag flag' => flag -> flag'
cvtFlag flag
fl
       ; GenLocated SrcSpanAnnA (HsType GhcPs)
ki' <- Type -> CvtM (LHsType GhcPs)
cvtKind Type
ki
       ; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ forall flag pass.
XKindedTyVar pass
-> flag -> LIdP pass -> LHsKind pass -> HsTyVarBndr flag pass
KindedTyVar forall a. EpAnn a
noAnn flag'
fl' LocatedN RdrName
nm' GenLocated SrcSpanAnnA (HsType GhcPs)
ki' }

cvtRole :: TH.Role -> Maybe Coercion.Role
cvtRole :: Role -> Maybe Role
cvtRole Role
TH.NominalR          = forall a. a -> Maybe a
Just Role
Coercion.Nominal
cvtRole Role
TH.RepresentationalR = forall a. a -> Maybe a
Just Role
Coercion.Representational
cvtRole Role
TH.PhantomR          = forall a. a -> Maybe a
Just Role
Coercion.Phantom
cvtRole Role
TH.InferR            = forall a. Maybe a
Nothing

cvtContext :: PprPrec -> TH.Cxt -> CvtM (LHsContext GhcPs)
cvtContext :: PprPrec -> [Type] -> CvtM (LHsContext GhcPs)
cvtContext PprPrec
p [Type]
tys = do { [GenLocated SrcSpanAnnA (HsType GhcPs)]
preds' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> CvtM (LHsType GhcPs)
cvtPred [Type]
tys
                      ; forall (p :: Pass).
PprPrec -> LHsContext (GhcPass p) -> LHsContext (GhcPass p)
parenthesizeHsContext PprPrec
p forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e ann. e -> CvtM (LocatedAn ann e)
returnLA [GenLocated SrcSpanAnnA (HsType GhcPs)]
preds' }

cvtPred :: TH.Pred -> CvtM (LHsType GhcPs)
cvtPred :: Type -> CvtM (LHsType GhcPs)
cvtPred = Type -> CvtM (LHsType GhcPs)
cvtType

cvtDerivClauseTys :: TH.Cxt -> CvtM (LDerivClauseTys GhcPs)
cvtDerivClauseTys :: [Type] -> CvtM (LDerivClauseTys GhcPs)
cvtDerivClauseTys [Type]
tys
  = do { [GenLocated SrcSpanAnnA (HsSigType GhcPs)]
tys' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> CvtM (LHsSigType GhcPs)
cvtSigType [Type]
tys
         -- Since TH.Cxt doesn't indicate the presence or absence of
         -- parentheses in a deriving clause, we have to choose between
         -- DctSingle and DctMulti somewhat arbitrarily. We opt to use DctMulti
         -- unless the TH.Cxt is a singleton list whose type is a bare type
         -- constructor with no arguments.
       ; case [GenLocated SrcSpanAnnA (HsSigType GhcPs)]
tys' of
           [ty' :: GenLocated SrcSpanAnnA (HsSigType GhcPs)
ty'@(L SrcSpanAnnA
l (HsSig { sig_bndrs :: forall pass. HsSigType pass -> HsOuterSigTyVarBndrs pass
sig_bndrs = HsOuterImplicit{}
                            , sig_body :: forall pass. HsSigType pass -> LHsType pass
sig_body  = L SrcSpanAnnA
_ (HsTyVar XTyVar GhcPs
_ PromotionFlag
NotPromoted XRec GhcPs (IdP GhcPs)
_) }))]
                 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l e. l -> e -> GenLocated l e
L (forall a ann. SrcSpanAnn' a -> SrcAnn ann
l2l SrcSpanAnnA
l) forall a b. (a -> b) -> a -> b
$ forall pass.
XDctSingle pass -> LHsSigType pass -> DerivClauseTys pass
DctSingle NoExtField
noExtField GenLocated SrcSpanAnnA (HsSigType GhcPs)
ty'
           [GenLocated SrcSpanAnnA (HsSigType GhcPs)]
_     -> forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ forall pass.
XDctMulti pass -> [LHsSigType pass] -> DerivClauseTys pass
DctMulti NoExtField
noExtField [GenLocated SrcSpanAnnA (HsSigType GhcPs)]
tys' }

cvtDerivClause :: TH.DerivClause
               -> CvtM (LHsDerivingClause GhcPs)
cvtDerivClause :: DerivClause -> CvtM (LHsDerivingClause GhcPs)
cvtDerivClause (TH.DerivClause Maybe DerivStrategy
ds [Type]
tys)
  = do { GenLocated SrcSpanAnnC (DerivClauseTys GhcPs)
tys' <- [Type] -> CvtM (LDerivClauseTys GhcPs)
cvtDerivClauseTys [Type]
tys
       ; Maybe (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcPs))
ds'  <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse DerivStrategy -> CvtM (LDerivStrategy GhcPs)
cvtDerivStrategy Maybe DerivStrategy
ds
       ; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ forall pass.
XCHsDerivingClause pass
-> Maybe (LDerivStrategy pass)
-> LDerivClauseTys pass
-> HsDerivingClause pass
HsDerivingClause forall a. EpAnn a
noAnn Maybe (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcPs))
ds' GenLocated SrcSpanAnnC (DerivClauseTys GhcPs)
tys' }

cvtDerivStrategy :: TH.DerivStrategy -> CvtM (Hs.LDerivStrategy GhcPs)
cvtDerivStrategy :: DerivStrategy -> CvtM (LDerivStrategy GhcPs)
cvtDerivStrategy DerivStrategy
TH.StockStrategy    = forall e ann. e -> CvtM (LocatedAn ann e)
returnLA (forall pass. XStockStrategy pass -> DerivStrategy pass
Hs.StockStrategy forall a. EpAnn a
noAnn)
cvtDerivStrategy DerivStrategy
TH.AnyclassStrategy = forall e ann. e -> CvtM (LocatedAn ann e)
returnLA (forall pass. XAnyClassStrategy pass -> DerivStrategy pass
Hs.AnyclassStrategy forall a. EpAnn a
noAnn)
cvtDerivStrategy DerivStrategy
TH.NewtypeStrategy  = forall e ann. e -> CvtM (LocatedAn ann e)
returnLA (forall pass. XNewtypeStrategy pass -> DerivStrategy pass
Hs.NewtypeStrategy forall a. EpAnn a
noAnn)
cvtDerivStrategy (TH.ViaStrategy Type
ty) = do
  GenLocated SrcSpanAnnA (HsSigType GhcPs)
ty' <- Type -> CvtM (LHsSigType GhcPs)
cvtSigType Type
ty
  forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ forall pass. XViaStrategy pass -> DerivStrategy pass
Hs.ViaStrategy (EpAnn [AddEpAnn] -> LHsSigType GhcPs -> XViaStrategyPs
XViaStrategyPs forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (HsSigType GhcPs)
ty')

cvtType :: TH.Type -> CvtM (LHsType GhcPs)
cvtType :: Type -> CvtM (LHsType GhcPs)
cvtType = TypeOrKind -> Type -> CvtM (LHsType GhcPs)
cvtTypeKind TypeOrKind
TypeLevel

cvtSigType :: TH.Type -> CvtM (LHsSigType GhcPs)
cvtSigType :: Type -> CvtM (LHsSigType GhcPs)
cvtSigType = TypeOrKind -> Type -> CvtM (LHsSigType GhcPs)
cvtSigTypeKind TypeOrKind
TypeLevel

-- | Convert a Template Haskell 'Type' to an 'LHsSigType'. To avoid duplicating
-- the logic in 'cvtTypeKind' here, we simply reuse 'cvtTypeKind' and perform
-- surgery on the 'LHsType' it returns to turn it into an 'LHsSigType'.
cvtSigTypeKind :: TypeOrKind -> TH.Type -> CvtM (LHsSigType GhcPs)
cvtSigTypeKind :: TypeOrKind -> Type -> CvtM (LHsSigType GhcPs)
cvtSigTypeKind TypeOrKind
typeOrKind Type
ty = do
  GenLocated SrcSpanAnnA (HsType GhcPs)
ty' <- TypeOrKind -> Type -> CvtM (LHsType GhcPs)
cvtTypeKind TypeOrKind
typeOrKind Type
ty
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ LHsType GhcPs -> LHsSigType GhcPs
hsTypeToHsSigType forall a b. (a -> b) -> a -> b
$ forall (p :: Pass).
PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)
parenthesizeHsType PprPrec
sigPrec GenLocated SrcSpanAnnA (HsType GhcPs)
ty'

cvtTypeKind :: TypeOrKind -> TH.Type -> CvtM (LHsType GhcPs)
cvtTypeKind :: TypeOrKind -> Type -> CvtM (LHsType GhcPs)
cvtTypeKind TypeOrKind
typeOrKind Type
ty
  = do { (Type
head_ty, [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
tys') <- Type -> CvtM (Type, HsTyPats GhcPs)
split_ty_app Type
ty
       ; let m_normals :: Maybe [GenLocated SrcSpanAnnA (HsType GhcPs)]
m_normals = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {a} {ty}. HsArg a ty -> Maybe a
extract_normal [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
tys'
                                where extract_normal :: HsArg a ty -> Maybe a
extract_normal (HsValArg a
ty) = forall a. a -> Maybe a
Just a
ty
                                      extract_normal HsArg a ty
_ = forall a. Maybe a
Nothing

       ; case Type
head_ty of
           TupleT Int
n
            | Just [GenLocated SrcSpanAnnA (HsType GhcPs)]
normals <- Maybe [GenLocated SrcSpanAnnA (HsType GhcPs)]
m_normals
            , [GenLocated SrcSpanAnnA (HsType GhcPs)]
normals forall a. [a] -> Int -> Bool
`lengthIs` Int
n         -- Saturated
            -> forall e ann. e -> CvtM (LocatedAn ann e)
returnLA (forall pass.
XTupleTy pass -> HsTupleSort -> [LHsType pass] -> HsType pass
HsTupleTy forall a. EpAnn a
noAnn HsTupleSort
HsBoxedOrConstraintTuple [GenLocated SrcSpanAnnA (HsType GhcPs)]
normals)
            | Bool
otherwise
            -> do { LocatedN RdrName
tuple_tc <- forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ forall thing. NamedThing thing => thing -> RdrName
getRdrName forall a b. (a -> b) -> a -> b
$ Boxity -> Int -> TyCon
tupleTyCon Boxity
Boxed Int
n
                  ; HsType GhcPs -> HsTyPats GhcPs -> CvtM (LHsType GhcPs)
mk_apps (forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar forall a. EpAnn a
noAnn PromotionFlag
NotPromoted LocatedN RdrName
tuple_tc) [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
tys' }
           UnboxedTupleT Int
n
             | Just [GenLocated SrcSpanAnnA (HsType GhcPs)]
normals <- Maybe [GenLocated SrcSpanAnnA (HsType GhcPs)]
m_normals
             , [GenLocated SrcSpanAnnA (HsType GhcPs)]
normals forall a. [a] -> Int -> Bool
`lengthIs` Int
n               -- Saturated
             -> forall e ann. e -> CvtM (LocatedAn ann e)
returnLA (forall pass.
XTupleTy pass -> HsTupleSort -> [LHsType pass] -> HsType pass
HsTupleTy forall a. EpAnn a
noAnn HsTupleSort
HsUnboxedTuple [GenLocated SrcSpanAnnA (HsType GhcPs)]
normals)
             | Bool
otherwise
             -> do { LocatedN RdrName
tuple_tc <- forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ forall thing. NamedThing thing => thing -> RdrName
getRdrName forall a b. (a -> b) -> a -> b
$ Boxity -> Int -> TyCon
tupleTyCon Boxity
Unboxed Int
n
                   ; HsType GhcPs -> HsTyPats GhcPs -> CvtM (LHsType GhcPs)
mk_apps (forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar forall a. EpAnn a
noAnn PromotionFlag
NotPromoted LocatedN RdrName
tuple_tc) [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
tys' }
           UnboxedSumT Int
n
             | Int
n forall a. Ord a => a -> a -> Bool
< Int
2
            -> forall a. ConversionFailReason -> CvtM a
failWith forall a b. (a -> b) -> a -> b
$ Int -> ConversionFailReason
IllegalSumArity Int
n
             | Just [GenLocated SrcSpanAnnA (HsType GhcPs)]
normals <- Maybe [GenLocated SrcSpanAnnA (HsType GhcPs)]
m_normals
             , [GenLocated SrcSpanAnnA (HsType GhcPs)]
normals forall a. [a] -> Int -> Bool
`lengthIs` Int
n -- Saturated
             -> forall e ann. e -> CvtM (LocatedAn ann e)
returnLA (forall pass. XSumTy pass -> [LHsType pass] -> HsType pass
HsSumTy forall a. EpAnn a
noAnn [GenLocated SrcSpanAnnA (HsType GhcPs)]
normals)
             | Bool
otherwise
             -> do { LocatedN RdrName
sum_tc <- forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ forall thing. NamedThing thing => thing -> RdrName
getRdrName forall a b. (a -> b) -> a -> b
$ Int -> TyCon
sumTyCon Int
n
                   ; HsType GhcPs -> HsTyPats GhcPs -> CvtM (LHsType GhcPs)
mk_apps (forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar forall a. EpAnn a
noAnn PromotionFlag
NotPromoted LocatedN RdrName
sum_tc) [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
tys' }
           Type
ArrowT
             | Just [GenLocated SrcSpanAnnA (HsType GhcPs)]
normals <- Maybe [GenLocated SrcSpanAnnA (HsType GhcPs)]
m_normals
             , [GenLocated SrcSpanAnnA (HsType GhcPs)
x',GenLocated SrcSpanAnnA (HsType GhcPs)
y'] <- [GenLocated SrcSpanAnnA (HsType GhcPs)]
normals -> do
                 GenLocated SrcSpanAnnA (HsType GhcPs)
x'' <- case forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (HsType GhcPs)
x' of
                          HsFunTy{}    -> forall e ann. e -> CvtM (LocatedAn ann e)
returnLA (forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (HsType GhcPs)
x')
                          HsForAllTy{} -> forall e ann. e -> CvtM (LocatedAn ann e)
returnLA (forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (HsType GhcPs)
x') -- #14646
                          HsQualTy{}   -> forall e ann. e -> CvtM (LocatedAn ann e)
returnLA (forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (HsType GhcPs)
x') -- #15324
                          HsType GhcPs
_            -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
                                          forall (p :: Pass).
PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)
parenthesizeHsType PprPrec
sigPrec GenLocated SrcSpanAnnA (HsType GhcPs)
x'
                 let y'' :: LHsType GhcPs
y'' = forall (p :: Pass).
PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)
parenthesizeHsType PprPrec
sigPrec GenLocated SrcSpanAnnA (HsType GhcPs)
y'
                 forall e ann. e -> CvtM (LocatedAn ann e)
returnLA (forall pass.
XFunTy pass
-> HsArrow pass -> LHsType pass -> LHsType pass -> HsType pass
HsFunTy forall a. EpAnn a
noAnn (forall pass. LHsUniToken "->" "\8594" pass -> HsArrow pass
HsUnrestrictedArrow forall (tok :: Symbol) (utok :: Symbol).
GenLocated TokenLocation (HsUniToken tok utok)
noHsUniTok) GenLocated SrcSpanAnnA (HsType GhcPs)
x'' LHsType GhcPs
y'')
             | Bool
otherwise
             -> do { LocatedN RdrName
fun_tc <- forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ forall thing. NamedThing thing => thing -> RdrName
getRdrName TyCon
unrestrictedFunTyCon
                   ; HsType GhcPs -> HsTyPats GhcPs -> CvtM (LHsType GhcPs)
mk_apps (forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar forall a. EpAnn a
noAnn PromotionFlag
NotPromoted LocatedN RdrName
fun_tc) [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
tys' }
           Type
MulArrowT
             | Just [GenLocated SrcSpanAnnA (HsType GhcPs)]
normals <- Maybe [GenLocated SrcSpanAnnA (HsType GhcPs)]
m_normals
             , [GenLocated SrcSpanAnnA (HsType GhcPs)
w',GenLocated SrcSpanAnnA (HsType GhcPs)
x',GenLocated SrcSpanAnnA (HsType GhcPs)
y'] <- [GenLocated SrcSpanAnnA (HsType GhcPs)]
normals -> do
                 GenLocated SrcSpanAnnA (HsType GhcPs)
x'' <- case forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (HsType GhcPs)
x' of
                          HsFunTy{}    -> forall e ann. e -> CvtM (LocatedAn ann e)
returnLA (forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (HsType GhcPs)
x')
                          HsForAllTy{} -> forall e ann. e -> CvtM (LocatedAn ann e)
returnLA (forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (HsType GhcPs)
x') -- #14646
                          HsQualTy{}   -> forall e ann. e -> CvtM (LocatedAn ann e)
returnLA (forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (HsType GhcPs)
x') -- #15324
                          HsType GhcPs
_            -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
                                          forall (p :: Pass).
PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)
parenthesizeHsType PprPrec
sigPrec GenLocated SrcSpanAnnA (HsType GhcPs)
x'
                 let y'' :: LHsType GhcPs
y'' = forall (p :: Pass).
PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)
parenthesizeHsType PprPrec
sigPrec GenLocated SrcSpanAnnA (HsType GhcPs)
y'
                     w'' :: HsArrow GhcPs
w'' = LHsType GhcPs -> HsArrow GhcPs
hsTypeToArrow GenLocated SrcSpanAnnA (HsType GhcPs)
w'
                 forall e ann. e -> CvtM (LocatedAn ann e)
returnLA (forall pass.
XFunTy pass
-> HsArrow pass -> LHsType pass -> LHsType pass -> HsType pass
HsFunTy forall a. EpAnn a
noAnn HsArrow GhcPs
w'' GenLocated SrcSpanAnnA (HsType GhcPs)
x'' LHsType GhcPs
y'')
             | Bool
otherwise
             -> do { LocatedN RdrName
fun_tc <- forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ forall thing. NamedThing thing => thing -> RdrName
getRdrName TyCon
fUNTyCon
                   ; HsType GhcPs -> HsTyPats GhcPs -> CvtM (LHsType GhcPs)
mk_apps (forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar forall a. EpAnn a
noAnn PromotionFlag
NotPromoted LocatedN RdrName
fun_tc) [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
tys' }
           Type
ListT
             | Just [GenLocated SrcSpanAnnA (HsType GhcPs)]
normals <- Maybe [GenLocated SrcSpanAnnA (HsType GhcPs)]
m_normals
             , [GenLocated SrcSpanAnnA (HsType GhcPs)
x'] <- [GenLocated SrcSpanAnnA (HsType GhcPs)]
normals ->
                forall e ann. e -> CvtM (LocatedAn ann e)
returnLA (forall pass. XListTy pass -> LHsType pass -> HsType pass
HsListTy forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (HsType GhcPs)
x')
             | Bool
otherwise
             -> do { LocatedN RdrName
list_tc <- forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ forall thing. NamedThing thing => thing -> RdrName
getRdrName TyCon
listTyCon
                   ; HsType GhcPs -> HsTyPats GhcPs -> CvtM (LHsType GhcPs)
mk_apps (forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar forall a. EpAnn a
noAnn PromotionFlag
NotPromoted LocatedN RdrName
list_tc) [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
tys' }

           VarT Name
nm -> do { LocatedN RdrName
nm' <- Name -> CvtM (LocatedN RdrName)
tNameN Name
nm
                         ; HsType GhcPs -> HsTyPats GhcPs -> CvtM (LHsType GhcPs)
mk_apps (forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar forall a. EpAnn a
noAnn PromotionFlag
NotPromoted LocatedN RdrName
nm') [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
tys' }
           ConT Name
nm -> do { RdrName
nm' <- Name -> CvtM RdrName
tconName Name
nm
                         ; let prom :: PromotionFlag
prom = RdrName -> PromotionFlag
name_promotedness RdrName
nm'
                         ; LocatedN RdrName
lnm' <- forall e ann. e -> CvtM (LocatedAn ann e)
returnLA RdrName
nm'
                         ; HsType GhcPs -> HsTyPats GhcPs -> CvtM (LHsType GhcPs)
mk_apps (forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar forall a. EpAnn a
noAnn PromotionFlag
prom LocatedN RdrName
lnm') [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
tys'}

           ForallT [TyVarBndr Specificity]
tvs [Type]
cxt Type
ty
             | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
tys'
             -> do { [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)]
tvs' <- forall flag flag'.
CvtFlag flag flag' =>
[TyVarBndr flag] -> CvtM [LHsTyVarBndr flag' GhcPs]
cvtTvs [TyVarBndr Specificity]
tvs
                   ; GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
cxt' <- PprPrec -> [Type] -> CvtM (LHsContext GhcPs)
cvtContext PprPrec
funPrec [Type]
cxt
                   ; GenLocated SrcSpanAnnA (HsType GhcPs)
ty'  <- Type -> CvtM (LHsType GhcPs)
cvtType Type
ty
                   ; SrcSpan
loc <- CvtM SrcSpan
getL
                   ; let loc' :: SrcSpanAnnA
loc' = forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc
                   ; let tele :: HsForAllTelescope GhcPs
tele   = forall (p :: Pass).
EpAnnForallTy
-> [LHsTyVarBndr Specificity (GhcPass p)]
-> HsForAllTelescope (GhcPass p)
mkHsForAllInvisTele forall a. EpAnn a
noAnn [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)]
tvs'
                         hs_ty :: LHsType GhcPs
hs_ty  = SrcSpanAnnA
-> HsForAllTelescope GhcPs -> LHsType GhcPs -> LHsType GhcPs
mkHsForAllTy SrcSpanAnnA
loc' HsForAllTelescope GhcPs
tele LHsType GhcPs
rho_ty
                         rho_ty :: LHsType GhcPs
rho_ty = [Type]
-> SrcSpanAnnA
-> LHsContext GhcPs
-> LHsType GhcPs
-> LHsType GhcPs
mkHsQualTy [Type]
cxt SrcSpanAnnA
loc' GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
cxt' GenLocated SrcSpanAnnA (HsType GhcPs)
ty'

                   ; forall (m :: * -> *) a. Monad m => a -> m a
return LHsType GhcPs
hs_ty }

           ForallVisT [TyVarBndr ()]
tvs Type
ty
             | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
tys'
             -> do { [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)]
tvs' <- forall flag flag'.
CvtFlag flag flag' =>
[TyVarBndr flag] -> CvtM [LHsTyVarBndr flag' GhcPs]
cvtTvs [TyVarBndr ()]
tvs
                   ; GenLocated SrcSpanAnnA (HsType GhcPs)
ty'  <- Type -> CvtM (LHsType GhcPs)
cvtType Type
ty
                   ; SrcSpan
loc  <- CvtM SrcSpan
getL
                   ; let loc' :: SrcSpanAnnA
loc' = forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc
                   ; let tele :: HsForAllTelescope GhcPs
tele = forall (p :: Pass).
EpAnnForallTy
-> [LHsTyVarBndr () (GhcPass p)] -> HsForAllTelescope (GhcPass p)
mkHsForAllVisTele forall a. EpAnn a
noAnn [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)]
tvs'
                   ; forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA
-> HsForAllTelescope GhcPs -> LHsType GhcPs -> LHsType GhcPs
mkHsForAllTy SrcSpanAnnA
loc' HsForAllTelescope GhcPs
tele GenLocated SrcSpanAnnA (HsType GhcPs)
ty' }

           SigT Type
ty Type
ki
             -> do { GenLocated SrcSpanAnnA (HsType GhcPs)
ty' <- Type -> CvtM (LHsType GhcPs)
cvtType Type
ty
                   ; GenLocated SrcSpanAnnA (HsType GhcPs)
ki' <- Type -> CvtM (LHsType GhcPs)
cvtKind Type
ki
                   ; HsType GhcPs -> HsTyPats GhcPs -> CvtM (LHsType GhcPs)
mk_apps (forall pass.
XKindSig pass -> LHsType pass -> LHsType pass -> HsType pass
HsKindSig forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (HsType GhcPs)
ty' GenLocated SrcSpanAnnA (HsType GhcPs)
ki') [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
tys'
                   }

           LitT TyLit
lit
             -> HsType GhcPs -> HsTyPats GhcPs -> CvtM (LHsType GhcPs)
mk_apps (forall pass. XTyLit pass -> HsTyLit pass -> HsType pass
HsTyLit NoExtField
noExtField (forall (p :: Pass). TyLit -> HsTyLit (GhcPass p)
cvtTyLit TyLit
lit)) [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
tys'

           Type
WildCardT
             -> HsType GhcPs -> HsTyPats GhcPs -> CvtM (LHsType GhcPs)
mk_apps HsType GhcPs
mkAnonWildCardTy [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
tys'

           InfixT Type
t1 Name
s Type
t2
             -> do { RdrName
s'  <- Name -> CvtM RdrName
tconName Name
s
                   ; GenLocated SrcSpanAnnA (HsType GhcPs)
t1' <- Type -> CvtM (LHsType GhcPs)
cvtType Type
t1
                   ; GenLocated SrcSpanAnnA (HsType GhcPs)
t2' <- Type -> CvtM (LHsType GhcPs)
cvtType Type
t2
                   ; let prom :: PromotionFlag
prom = RdrName -> PromotionFlag
name_promotedness RdrName
s'
                   ; LocatedN RdrName
ls' <- forall e ann. e -> CvtM (LocatedAn ann e)
returnLA RdrName
s'
                   ; HsType GhcPs -> HsTyPats GhcPs -> CvtM (LHsType GhcPs)
mk_apps
                      (forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar forall a. EpAnn a
noAnn PromotionFlag
prom LocatedN RdrName
ls')
                      ([forall tm ty. tm -> HsArg tm ty
HsValArg GenLocated SrcSpanAnnA (HsType GhcPs)
t1', forall tm ty. tm -> HsArg tm ty
HsValArg GenLocated SrcSpanAnnA (HsType GhcPs)
t2'] forall a. [a] -> [a] -> [a]
++ [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
tys')
                   }

           UInfixT Type
t1 Name
s Type
t2
             -> do { LocatedN RdrName
s' <- Name -> CvtM (LocatedN RdrName)
tconNameN Name
s
                   ; GenLocated SrcSpanAnnA (HsType GhcPs)
t2' <- Type -> CvtM (LHsType GhcPs)
cvtType Type
t2
                   ; GenLocated SrcSpanAnnA (HsType GhcPs)
t <- PromotionFlag
-> Type
-> LocatedN RdrName
-> LHsType GhcPs
-> CvtM (LHsType GhcPs)
cvtOpAppT PromotionFlag
NotPromoted Type
t1 LocatedN RdrName
s' GenLocated SrcSpanAnnA (HsType GhcPs)
t2'
                   ; HsType GhcPs -> HsTyPats GhcPs -> CvtM (LHsType GhcPs)
mk_apps (forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (HsType GhcPs)
t) [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
tys'
                   } -- Note [Converting UInfix]

           PromotedInfixT Type
t1 Name
s Type
t2
             -> do { LocatedN RdrName
s'  <- Name -> CvtM (LocatedN RdrName)
cNameN Name
s
                   ; GenLocated SrcSpanAnnA (HsType GhcPs)
t1' <- Type -> CvtM (LHsType GhcPs)
cvtType Type
t1
                   ; GenLocated SrcSpanAnnA (HsType GhcPs)
t2' <- Type -> CvtM (LHsType GhcPs)
cvtType Type
t2
                   ; HsType GhcPs -> HsTyPats GhcPs -> CvtM (LHsType GhcPs)
mk_apps
                      (forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar forall a. EpAnn a
noAnn PromotionFlag
IsPromoted LocatedN RdrName
s')
                      ([forall tm ty. tm -> HsArg tm ty
HsValArg GenLocated SrcSpanAnnA (HsType GhcPs)
t1', forall tm ty. tm -> HsArg tm ty
HsValArg GenLocated SrcSpanAnnA (HsType GhcPs)
t2'] forall a. [a] -> [a] -> [a]
++ [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
tys')
                   }

           PromotedUInfixT Type
t1 Name
s Type
t2
             -> do { LocatedN RdrName
s' <- Name -> CvtM (LocatedN RdrName)
cNameN Name
s
                   ; GenLocated SrcSpanAnnA (HsType GhcPs)
t2' <- Type -> CvtM (LHsType GhcPs)
cvtType Type
t2
                   ; GenLocated SrcSpanAnnA (HsType GhcPs)
t <- PromotionFlag
-> Type
-> LocatedN RdrName
-> LHsType GhcPs
-> CvtM (LHsType GhcPs)
cvtOpAppT PromotionFlag
IsPromoted Type
t1 LocatedN RdrName
s' GenLocated SrcSpanAnnA (HsType GhcPs)
t2'
                   ; HsType GhcPs -> HsTyPats GhcPs -> CvtM (LHsType GhcPs)
mk_apps (forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (HsType GhcPs)
t) [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
tys'
                   } -- Note [Converting UInfix]

           ParensT Type
t
             -> do { GenLocated SrcSpanAnnA (HsType GhcPs)
t' <- Type -> CvtM (LHsType GhcPs)
cvtType Type
t
                   ; HsType GhcPs -> HsTyPats GhcPs -> CvtM (LHsType GhcPs)
mk_apps (forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (HsType GhcPs)
t') [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
tys'
                   }

           PromotedT Name
nm -> do { LocatedN RdrName
nm' <- Name -> CvtM (LocatedN RdrName)
cNameN Name
nm
                              ; HsType GhcPs -> HsTyPats GhcPs -> CvtM (LHsType GhcPs)
mk_apps (forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar forall a. EpAnn a
noAnn PromotionFlag
IsPromoted LocatedN RdrName
nm')
                                        [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
tys' }
                 -- Promoted data constructor; hence cName

           PromotedTupleT Int
n
              | Just [GenLocated SrcSpanAnnA (HsType GhcPs)]
normals <- Maybe [GenLocated SrcSpanAnnA (HsType GhcPs)]
m_normals
              , [GenLocated SrcSpanAnnA (HsType GhcPs)]
normals forall a. [a] -> Int -> Bool
`lengthIs` Int
n   -- Saturated
              -> forall e ann. e -> CvtM (LocatedAn ann e)
returnLA (forall pass. XExplicitTupleTy pass -> [LHsType pass] -> HsType pass
HsExplicitTupleTy forall a. EpAnn a
noAnn [GenLocated SrcSpanAnnA (HsType GhcPs)]
normals)
              | Bool
otherwise
              -> do { LocatedN RdrName
tuple_tc <- forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ forall thing. NamedThing thing => thing -> RdrName
getRdrName forall a b. (a -> b) -> a -> b
$ Boxity -> Int -> DataCon
tupleDataCon Boxity
Boxed Int
n
                    ; HsType GhcPs -> HsTyPats GhcPs -> CvtM (LHsType GhcPs)
mk_apps (forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar forall a. EpAnn a
noAnn PromotionFlag
IsPromoted LocatedN RdrName
tuple_tc) [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
tys' }

           Type
PromotedNilT
             -> HsType GhcPs -> HsTyPats GhcPs -> CvtM (LHsType GhcPs)
mk_apps (forall pass.
XExplicitListTy pass
-> PromotionFlag -> [LHsType pass] -> HsType pass
HsExplicitListTy forall a. EpAnn a
noAnn PromotionFlag
IsPromoted []) [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
tys'

           Type
PromotedConsT  -- See Note [Representing concrete syntax in types]
                          -- in Language.Haskell.TH.Syntax
              | Just [GenLocated SrcSpanAnnA (HsType GhcPs)]
normals <- Maybe [GenLocated SrcSpanAnnA (HsType GhcPs)]
m_normals
              , [GenLocated SrcSpanAnnA (HsType GhcPs)
ty1, L SrcSpanAnnA
_ (HsExplicitListTy XExplicitListTy GhcPs
_ PromotionFlag
ip [LHsType GhcPs]
tys2)] <- [GenLocated SrcSpanAnnA (HsType GhcPs)]
normals
              -> forall e ann. e -> CvtM (LocatedAn ann e)
returnLA (forall pass.
XExplicitListTy pass
-> PromotionFlag -> [LHsType pass] -> HsType pass
HsExplicitListTy forall a. EpAnn a
noAnn PromotionFlag
ip (GenLocated SrcSpanAnnA (HsType GhcPs)
ty1forall a. a -> [a] -> [a]
:[LHsType GhcPs]
tys2))
              | Bool
otherwise
              -> do { LocatedN RdrName
cons_tc <- forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
consDataCon
                    ; HsType GhcPs -> HsTyPats GhcPs -> CvtM (LHsType GhcPs)
mk_apps (forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar forall a. EpAnn a
noAnn PromotionFlag
IsPromoted LocatedN RdrName
cons_tc) [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
tys' }

           Type
StarT
             -> do { LocatedN RdrName
type_tc <- forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ forall thing. NamedThing thing => thing -> RdrName
getRdrName TyCon
liftedTypeKindTyCon
                   ; HsType GhcPs -> HsTyPats GhcPs -> CvtM (LHsType GhcPs)
mk_apps (forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar forall a. EpAnn a
noAnn PromotionFlag
NotPromoted LocatedN RdrName
type_tc) [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
tys' }

           Type
ConstraintT
             -> do { LocatedN RdrName
constraint_tc <- forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ forall thing. NamedThing thing => thing -> RdrName
getRdrName TyCon
constraintKindTyCon
                   ; HsType GhcPs -> HsTyPats GhcPs -> CvtM (LHsType GhcPs)
mk_apps (forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar forall a. EpAnn a
noAnn PromotionFlag
NotPromoted LocatedN RdrName
constraint_tc) [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
tys' }

           Type
EqualityT
             | Just [GenLocated SrcSpanAnnA (HsType GhcPs)]
normals <- Maybe [GenLocated SrcSpanAnnA (HsType GhcPs)]
m_normals
             , [GenLocated SrcSpanAnnA (HsType GhcPs)
x',GenLocated SrcSpanAnnA (HsType GhcPs)
y'] <- [GenLocated SrcSpanAnnA (HsType GhcPs)]
normals ->
                   let px :: LHsType GhcPs
px = forall (p :: Pass).
PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)
parenthesizeHsType PprPrec
opPrec GenLocated SrcSpanAnnA (HsType GhcPs)
x'
                       py :: LHsType GhcPs
py = forall (p :: Pass).
PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)
parenthesizeHsType PprPrec
opPrec GenLocated SrcSpanAnnA (HsType GhcPs)
y'
                   in do { LocatedN RdrName
eq_tc <- forall e ann. e -> CvtM (LocatedAn ann e)
returnLA RdrName
eqTyCon_RDR
                         ; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA (forall pass.
XOpTy pass
-> PromotionFlag
-> LHsType pass
-> LIdP pass
-> LHsType pass
-> HsType pass
HsOpTy forall a. EpAnn a
noAnn PromotionFlag
NotPromoted LHsType GhcPs
px LocatedN RdrName
eq_tc LHsType GhcPs
py) }
               -- The long-term goal is to remove the above case entirely and
               -- subsume it under the case for InfixT. See #15815, comment:6,
               -- for more details.

             | Bool
otherwise ->
                   do { LocatedN RdrName
eq_tc <- forall e ann. e -> CvtM (LocatedAn ann e)
returnLA RdrName
eqTyCon_RDR
                      ; HsType GhcPs -> HsTyPats GhcPs -> CvtM (LHsType GhcPs)
mk_apps (forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar forall a. EpAnn a
noAnn PromotionFlag
NotPromoted LocatedN RdrName
eq_tc) [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
tys' }
           ImplicitParamT String
n Type
t
             -> do { Located HsIPName
n' <- forall a. CvtM a -> CvtM (Located a)
wrapL forall a b. (a -> b) -> a -> b
$ String -> CvtM HsIPName
ipName String
n
                   ; GenLocated SrcSpanAnnA (HsType GhcPs)
t' <- Type -> CvtM (LHsType GhcPs)
cvtType Type
t
                   ; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA (forall pass.
XIParamTy pass -> XRec pass HsIPName -> LHsType pass -> HsType pass
HsIParamTy forall a. EpAnn a
noAnn (forall e ann. Located e -> LocatedAn ann e
reLocA Located HsIPName
n') GenLocated SrcSpanAnnA (HsType GhcPs)
t')
                   }

           Type
_ -> forall a. ConversionFailReason -> CvtM a
failWith (TypeOrKind -> Type -> ConversionFailReason
MalformedType TypeOrKind
typeOrKind Type
ty)
    }

hsTypeToArrow :: LHsType GhcPs -> HsArrow GhcPs
hsTypeToArrow :: LHsType GhcPs -> HsArrow GhcPs
hsTypeToArrow LHsType GhcPs
w = case forall l e. GenLocated l e -> e
unLoc LHsType GhcPs
w of
                     HsTyVar XTyVar GhcPs
_ PromotionFlag
_ (L SrcSpanAnnN
_ (RdrName -> Maybe Name
isExact_maybe -> Just Name
n))
                        | Name
n forall a. Eq a => a -> a -> Bool
== Name
oneDataConName -> forall pass. HsLinearArrowTokens pass -> HsArrow pass
HsLinearArrow (forall pass.
LHsToken "%1" pass
-> LHsUniToken "->" "\8594" pass -> HsLinearArrowTokens pass
HsPct1 forall (tok :: Symbol). GenLocated TokenLocation (HsToken tok)
noHsTok forall (tok :: Symbol) (utok :: Symbol).
GenLocated TokenLocation (HsUniToken tok utok)
noHsUniTok)
                        | Name
n forall a. Eq a => a -> a -> Bool
== Name
manyDataConName -> forall pass. LHsUniToken "->" "\8594" pass -> HsArrow pass
HsUnrestrictedArrow forall (tok :: Symbol) (utok :: Symbol).
GenLocated TokenLocation (HsUniToken tok utok)
noHsUniTok
                     HsType GhcPs
_ -> forall pass.
LHsToken "%" pass
-> LHsType pass -> LHsUniToken "->" "\8594" pass -> HsArrow pass
HsExplicitMult forall (tok :: Symbol). GenLocated TokenLocation (HsToken tok)
noHsTok LHsType GhcPs
w forall (tok :: Symbol) (utok :: Symbol).
GenLocated TokenLocation (HsUniToken tok utok)
noHsUniTok

-- ConT/InfixT can contain both data constructor (i.e., promoted) names and
-- other (i.e, unpromoted) names, as opposed to PromotedT, which can only
-- contain data constructor names. See #15572/#17394. We use this function to
-- determine whether to mark a name as promoted/unpromoted when dealing with
-- ConT/InfixT.
name_promotedness :: RdrName -> Hs.PromotionFlag
name_promotedness :: RdrName -> PromotionFlag
name_promotedness RdrName
nm
  | RdrName -> Bool
isRdrDataCon RdrName
nm = PromotionFlag
IsPromoted
  | Bool
otherwise       = PromotionFlag
NotPromoted

-- | Constructs an application of a type to arguments passed in a list.
mk_apps :: HsType GhcPs -> [LHsTypeArg GhcPs] -> CvtM (LHsType GhcPs)
mk_apps :: HsType GhcPs -> HsTyPats GhcPs -> CvtM (LHsType GhcPs)
mk_apps HsType GhcPs
head_ty HsTyPats GhcPs
type_args = do
  GenLocated SrcSpanAnnA (HsType GhcPs)
head_ty' <- forall e ann. e -> CvtM (LocatedAn ann e)
returnLA HsType GhcPs
head_ty
  -- We must parenthesize the function type in case of an explicit
  -- signature. For instance, in `(Maybe :: Type -> Type) Int`, there
  -- _must_ be parentheses around `Maybe :: Type -> Type`.
  let phead_ty :: LHsType GhcPs
      phead_ty :: LHsType GhcPs
phead_ty = forall (p :: Pass).
PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)
parenthesizeHsType PprPrec
sigPrec GenLocated SrcSpanAnnA (HsType GhcPs)
head_ty'

      go :: [LHsTypeArg GhcPs] -> CvtM (LHsType GhcPs)
      go :: HsTyPats GhcPs -> CvtM (LHsType GhcPs)
go [] = forall (f :: * -> *) a. Applicative f => a -> f a
pure GenLocated SrcSpanAnnA (HsType GhcPs)
head_ty'
      go (LHsTypeArg GhcPs
arg:HsTyPats GhcPs
args) =
        case LHsTypeArg GhcPs
arg of
          HsValArg LHsType GhcPs
ty  -> do GenLocated SrcSpanAnnA (HsType GhcPs)
p_ty <- forall {p :: Pass}.
GenLocated SrcSpanAnnA (HsType (GhcPass p))
-> CvtM (GenLocated SrcSpanAnnA (HsType (GhcPass p)))
add_parens LHsType GhcPs
ty
                             HsType GhcPs -> HsTyPats GhcPs -> CvtM (LHsType GhcPs)
mk_apps (forall pass.
XAppTy pass -> LHsType pass -> LHsType pass -> HsType pass
HsAppTy NoExtField
noExtField LHsType GhcPs
phead_ty GenLocated SrcSpanAnnA (HsType GhcPs)
p_ty) HsTyPats GhcPs
args
          HsTypeArg SrcSpan
l LHsType GhcPs
ki -> do GenLocated SrcSpanAnnA (HsType GhcPs)
p_ki <- forall {p :: Pass}.
GenLocated SrcSpanAnnA (HsType (GhcPass p))
-> CvtM (GenLocated SrcSpanAnnA (HsType (GhcPass p)))
add_parens LHsType GhcPs
ki
                               HsType GhcPs -> HsTyPats GhcPs -> CvtM (LHsType GhcPs)
mk_apps (forall pass.
XAppKindTy pass -> LHsType pass -> LHsType pass -> HsType pass
HsAppKindTy SrcSpan
l LHsType GhcPs
phead_ty GenLocated SrcSpanAnnA (HsType GhcPs)
p_ki) HsTyPats GhcPs
args
          HsArgPar SrcSpan
_   -> HsType GhcPs -> HsTyPats GhcPs -> CvtM (LHsType GhcPs)
mk_apps (forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy forall a. EpAnn a
noAnn LHsType GhcPs
phead_ty) HsTyPats GhcPs
args

  HsTyPats GhcPs -> CvtM (LHsType GhcPs)
go HsTyPats GhcPs
type_args
   where
    -- See Note [Adding parens for splices]
    add_parens :: GenLocated SrcSpanAnnA (HsType (GhcPass p))
-> CvtM (GenLocated SrcSpanAnnA (HsType (GhcPass p)))
add_parens lt :: GenLocated SrcSpanAnnA (HsType (GhcPass p))
lt@(L SrcSpanAnnA
_ HsType (GhcPass p)
t)
      | forall (p :: Pass). PprPrec -> HsType (GhcPass p) -> Bool
hsTypeNeedsParens PprPrec
appPrec HsType (GhcPass p)
t = forall e ann. e -> CvtM (LocatedAn ann e)
returnLA (forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (HsType (GhcPass p))
lt)
      | Bool
otherwise                   = forall (m :: * -> *) a. Monad m => a -> m a
return GenLocated SrcSpanAnnA (HsType (GhcPass p))
lt

wrap_tyarg :: LHsTypeArg GhcPs -> LHsTypeArg GhcPs
wrap_tyarg :: LHsTypeArg GhcPs -> LHsTypeArg GhcPs
wrap_tyarg (HsValArg LHsType GhcPs
ty)    = forall tm ty. tm -> HsArg tm ty
HsValArg  forall a b. (a -> b) -> a -> b
$ forall (p :: Pass).
PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)
parenthesizeHsType PprPrec
appPrec LHsType GhcPs
ty
wrap_tyarg (HsTypeArg SrcSpan
l LHsType GhcPs
ki) = forall tm ty. SrcSpan -> ty -> HsArg tm ty
HsTypeArg SrcSpan
l forall a b. (a -> b) -> a -> b
$ forall (p :: Pass).
PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)
parenthesizeHsType PprPrec
appPrec LHsType GhcPs
ki
wrap_tyarg ta :: LHsTypeArg GhcPs
ta@(HsArgPar {}) = LHsTypeArg GhcPs
ta -- Already parenthesized

-- ---------------------------------------------------------------------
{-
Note [Adding parens for splices]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The hsSyn representation of parsed source explicitly contains all the original
parens, as written in the source.

When a Template Haskell (TH) splice is evaluated, the original splice is first
renamed and type checked and then finally converted to core in
GHC.HsToCore.Quote. This core is then run in the TH engine, and the result
comes back as a TH AST.

In the process, all parens are stripped out, as they are not needed.

This Convert module then converts the TH AST back to hsSyn AST.

In order to pretty-print this hsSyn AST, parens need to be adde back at certain
points so that the code is readable with its original meaning.

So scattered through "GHC.ThToHs" are various points where parens are added.

See (among other closed issues) https://gitlab.haskell.org/ghc/ghc/issues/14289
-}
-- ---------------------------------------------------------------------

split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsTypeArg GhcPs])
split_ty_app :: Type -> CvtM (Type, HsTyPats GhcPs)
split_ty_app Type
ty = Type
-> [HsArg
      (GenLocated SrcSpanAnnA (HsType GhcPs))
      (GenLocated SrcSpanAnnA (HsType GhcPs))]
-> CvtM'
     ConversionFailReason
     (Type,
      [HsArg
         (GenLocated SrcSpanAnnA (HsType GhcPs))
         (GenLocated SrcSpanAnnA (HsType GhcPs))])
go Type
ty []
  where
    go :: Type
-> [HsArg
      (GenLocated SrcSpanAnnA (HsType GhcPs))
      (GenLocated SrcSpanAnnA (HsType GhcPs))]
-> CvtM'
     ConversionFailReason
     (Type,
      [HsArg
         (GenLocated SrcSpanAnnA (HsType GhcPs))
         (GenLocated SrcSpanAnnA (HsType GhcPs))])
go (AppT Type
f Type
a) [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
as' = do { GenLocated SrcSpanAnnA (HsType GhcPs)
a' <- Type -> CvtM (LHsType GhcPs)
cvtType Type
a; Type
-> [HsArg
      (GenLocated SrcSpanAnnA (HsType GhcPs))
      (GenLocated SrcSpanAnnA (HsType GhcPs))]
-> CvtM'
     ConversionFailReason
     (Type,
      [HsArg
         (GenLocated SrcSpanAnnA (HsType GhcPs))
         (GenLocated SrcSpanAnnA (HsType GhcPs))])
go Type
f (forall tm ty. tm -> HsArg tm ty
HsValArg GenLocated SrcSpanAnnA (HsType GhcPs)
a'forall a. a -> [a] -> [a]
:[HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
as') }
    go (AppKindT Type
ty Type
ki) [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
as' = do { GenLocated SrcSpanAnnA (HsType GhcPs)
ki' <- Type -> CvtM (LHsType GhcPs)
cvtKind Type
ki
                                 ; Type
-> [HsArg
      (GenLocated SrcSpanAnnA (HsType GhcPs))
      (GenLocated SrcSpanAnnA (HsType GhcPs))]
-> CvtM'
     ConversionFailReason
     (Type,
      [HsArg
         (GenLocated SrcSpanAnnA (HsType GhcPs))
         (GenLocated SrcSpanAnnA (HsType GhcPs))])
go Type
ty (forall tm ty. SrcSpan -> ty -> HsArg tm ty
HsTypeArg SrcSpan
noSrcSpan GenLocated SrcSpanAnnA (HsType GhcPs)
ki'forall a. a -> [a] -> [a]
:[HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
as') }
    go (ParensT Type
t) [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
as' = do { SrcSpan
loc <- CvtM SrcSpan
getL; Type
-> [HsArg
      (GenLocated SrcSpanAnnA (HsType GhcPs))
      (GenLocated SrcSpanAnnA (HsType GhcPs))]
-> CvtM'
     ConversionFailReason
     (Type,
      [HsArg
         (GenLocated SrcSpanAnnA (HsType GhcPs))
         (GenLocated SrcSpanAnnA (HsType GhcPs))])
go Type
t (forall tm ty. SrcSpan -> HsArg tm ty
HsArgPar SrcSpan
locforall a. a -> [a] -> [a]
: [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
as') }
    go Type
f [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
as           = forall (m :: * -> *) a. Monad m => a -> m a
return (Type
f,[HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
as)

cvtTyLit :: TH.TyLit -> HsTyLit (GhcPass p)
cvtTyLit :: forall (p :: Pass). TyLit -> HsTyLit (GhcPass p)
cvtTyLit (TH.NumTyLit Integer
i) = forall pass. XNumTy pass -> Integer -> HsTyLit pass
HsNumTy SourceText
NoSourceText Integer
i
cvtTyLit (TH.StrTyLit String
s) = forall pass. XStrTy pass -> CLabelString -> HsTyLit pass
HsStrTy SourceText
NoSourceText (String -> CLabelString
fsLit String
s)
cvtTyLit (TH.CharTyLit Char
c) = forall pass. XCharTy pass -> Char -> HsTyLit pass
HsCharTy SourceText
NoSourceText Char
c

{- | @cvtOpAppT x op y@ converts @op@ and @y@ and produces the operator
application @x `op` y@. The produced tree of infix types will be right-biased,
provided @y@ is.

See the @cvtOpApp@ documentation for how this function works.
-}
cvtOpAppT :: PromotionFlag -> TH.Type -> LocatedN RdrName -> LHsType GhcPs -> CvtM (LHsType GhcPs)
cvtOpAppT :: PromotionFlag
-> Type
-> LocatedN RdrName
-> LHsType GhcPs
-> CvtM (LHsType GhcPs)
cvtOpAppT PromotionFlag
prom (UInfixT Type
x Name
op2 Type
y) LocatedN RdrName
op1 LHsType GhcPs
z
  = do { LocatedN RdrName
op2' <- Name -> CvtM (LocatedN RdrName)
tconNameN Name
op2
       ; GenLocated SrcSpanAnnA (HsType GhcPs)
l <- PromotionFlag
-> Type
-> LocatedN RdrName
-> LHsType GhcPs
-> CvtM (LHsType GhcPs)
cvtOpAppT PromotionFlag
prom Type
y LocatedN RdrName
op1 LHsType GhcPs
z
       ; PromotionFlag
-> Type
-> LocatedN RdrName
-> LHsType GhcPs
-> CvtM (LHsType GhcPs)
cvtOpAppT PromotionFlag
NotPromoted Type
x LocatedN RdrName
op2' GenLocated SrcSpanAnnA (HsType GhcPs)
l }
cvtOpAppT PromotionFlag
prom (PromotedUInfixT Type
x Name
op2 Type
y) LocatedN RdrName
op1 LHsType GhcPs
z
  = do { LocatedN RdrName
op2' <- Name -> CvtM (LocatedN RdrName)
cNameN Name
op2
       ; GenLocated SrcSpanAnnA (HsType GhcPs)
l <- PromotionFlag
-> Type
-> LocatedN RdrName
-> LHsType GhcPs
-> CvtM (LHsType GhcPs)
cvtOpAppT PromotionFlag
prom Type
y LocatedN RdrName
op1 LHsType GhcPs
z
       ; PromotionFlag
-> Type
-> LocatedN RdrName
-> LHsType GhcPs
-> CvtM (LHsType GhcPs)
cvtOpAppT PromotionFlag
IsPromoted Type
x LocatedN RdrName
op2' GenLocated SrcSpanAnnA (HsType GhcPs)
l }
cvtOpAppT PromotionFlag
prom Type
x LocatedN RdrName
op LHsType GhcPs
y
  = do { GenLocated SrcSpanAnnA (HsType GhcPs)
x' <- Type -> CvtM (LHsType GhcPs)
cvtType Type
x
       ; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA (forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
PromotionFlag
-> LHsType (GhcPass p)
-> LocatedN (IdP (GhcPass p))
-> LHsType (GhcPass p)
-> HsType (GhcPass p)
mkHsOpTy PromotionFlag
prom GenLocated SrcSpanAnnA (HsType GhcPs)
x' LocatedN RdrName
op LHsType GhcPs
y) }

cvtKind :: TH.Kind -> CvtM (LHsKind GhcPs)
cvtKind :: Type -> CvtM (LHsType GhcPs)
cvtKind = TypeOrKind -> Type -> CvtM (LHsType GhcPs)
cvtTypeKind TypeOrKind
KindLevel

cvtSigKind :: TH.Kind -> CvtM (LHsSigType GhcPs)
cvtSigKind :: Type -> CvtM (LHsSigType GhcPs)
cvtSigKind = TypeOrKind -> Type -> CvtM (LHsSigType GhcPs)
cvtSigTypeKind TypeOrKind
KindLevel

-- | Convert Maybe Kind to a type family result signature. Used with data
-- families where naming of the result is not possible (thus only kind or no
-- signature is possible).
cvtMaybeKindToFamilyResultSig :: Maybe TH.Kind
                              -> CvtM (LFamilyResultSig GhcPs)
cvtMaybeKindToFamilyResultSig :: Maybe Type -> CvtM (LFamilyResultSig GhcPs)
cvtMaybeKindToFamilyResultSig Maybe Type
Nothing   = forall e ann. e -> CvtM (LocatedAn ann e)
returnLA (forall pass. XNoSig pass -> FamilyResultSig pass
Hs.NoSig NoExtField
noExtField)
cvtMaybeKindToFamilyResultSig (Just Type
ki) = do { GenLocated SrcSpanAnnA (HsType GhcPs)
ki' <- Type -> CvtM (LHsType GhcPs)
cvtKind Type
ki
                                             ; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA (forall pass. XCKindSig pass -> LHsKind pass -> FamilyResultSig pass
Hs.KindSig NoExtField
noExtField GenLocated SrcSpanAnnA (HsType GhcPs)
ki') }

-- | Convert type family result signature. Used with both open and closed type
-- families.
cvtFamilyResultSig :: TH.FamilyResultSig -> CvtM (Hs.LFamilyResultSig GhcPs)
cvtFamilyResultSig :: FamilyResultSig -> CvtM (LFamilyResultSig GhcPs)
cvtFamilyResultSig FamilyResultSig
TH.NoSig           = forall e ann. e -> CvtM (LocatedAn ann e)
returnLA (forall pass. XNoSig pass -> FamilyResultSig pass
Hs.NoSig NoExtField
noExtField)
cvtFamilyResultSig (TH.KindSig Type
ki)    = do { GenLocated SrcSpanAnnA (HsType GhcPs)
ki' <- Type -> CvtM (LHsType GhcPs)
cvtKind Type
ki
                                           ; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA (forall pass. XCKindSig pass -> LHsKind pass -> FamilyResultSig pass
Hs.KindSig NoExtField
noExtField  GenLocated SrcSpanAnnA (HsType GhcPs)
ki') }
cvtFamilyResultSig (TH.TyVarSig TyVarBndr ()
bndr) = do { GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)
tv <- forall flag flag'.
CvtFlag flag flag' =>
TyVarBndr flag -> CvtM (LHsTyVarBndr flag' GhcPs)
cvt_tv TyVarBndr ()
bndr
                                           ; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA (forall pass.
XTyVarSig pass -> LHsTyVarBndr () pass -> FamilyResultSig pass
Hs.TyVarSig NoExtField
noExtField GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)
tv) }

-- | Convert injectivity annotation of a type family.
cvtInjectivityAnnotation :: TH.InjectivityAnn
                         -> CvtM (Hs.LInjectivityAnn GhcPs)
cvtInjectivityAnnotation :: InjectivityAnn -> CvtM (LInjectivityAnn GhcPs)
cvtInjectivityAnnotation (TH.InjectivityAnn Name
annLHS [Name]
annRHS)
  = do { LocatedN RdrName
annLHS' <- Name -> CvtM (LocatedN RdrName)
tNameN Name
annLHS
       ; [LocatedN RdrName]
annRHS' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> CvtM (LocatedN RdrName)
tNameN [Name]
annRHS
       ; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA (forall pass.
XCInjectivityAnn pass
-> LIdP pass -> [LIdP pass] -> InjectivityAnn pass
Hs.InjectivityAnn forall a. EpAnn a
noAnn LocatedN RdrName
annLHS' [LocatedN RdrName]
annRHS') }

cvtPatSynSigTy :: TH.Type -> CvtM (LHsSigType GhcPs)
-- pattern synonym types are of peculiar shapes, which is why we treat
-- them separately from regular types;
-- see Note [Pattern synonym type signatures and Template Haskell]
cvtPatSynSigTy :: Type -> CvtM (LHsSigType GhcPs)
cvtPatSynSigTy (ForallT [TyVarBndr Specificity]
univs [Type]
reqs (ForallT [TyVarBndr Specificity]
exis [Type]
provs Type
ty))
  | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVarBndr Specificity]
exis, forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
provs = Type -> CvtM (LHsSigType GhcPs)
cvtSigType ([TyVarBndr Specificity] -> [Type] -> Type -> Type
ForallT [TyVarBndr Specificity]
univs [Type]
reqs Type
ty)
  | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVarBndr Specificity]
univs, forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
reqs = do { GenLocated SrcSpanAnnA (HsType GhcPs)
ty' <- Type -> CvtM (LHsType GhcPs)
cvtType ([TyVarBndr Specificity] -> [Type] -> Type -> Type
ForallT [TyVarBndr Specificity]
exis [Type]
provs Type
ty)
                               ; GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
ctxt' <- forall e ann. e -> CvtM (LocatedAn ann e)
returnLA []
                               ; HsSigType GhcPs
cxtTy <- forall ann a b. (LocatedAn ann a -> b) -> a -> CvtM b
wrapParLA LHsType GhcPs -> HsSigType GhcPs
mkHsImplicitSigType forall a b. (a -> b) -> a -> b
$
                                          HsQualTy { hst_ctxt :: LHsContext GhcPs
hst_ctxt = GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
ctxt'
                                                   , hst_xqual :: XQualTy GhcPs
hst_xqual = NoExtField
noExtField
                                                   , hst_body :: LHsType GhcPs
hst_body = GenLocated SrcSpanAnnA (HsType GhcPs)
ty' }
                               ; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA HsSigType GhcPs
cxtTy }
  | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
reqs             = do { [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)]
univs' <- forall flag flag'.
CvtFlag flag flag' =>
[TyVarBndr flag] -> CvtM [LHsTyVarBndr flag' GhcPs]
cvtTvs [TyVarBndr Specificity]
univs
                               ; GenLocated SrcSpanAnnA (HsType GhcPs)
ty'    <- Type -> CvtM (LHsType GhcPs)
cvtType ([TyVarBndr Specificity] -> [Type] -> Type -> Type
ForallT [TyVarBndr Specificity]
exis [Type]
provs Type
ty)
                               ; LocatedAn AnnContext [LHsType GhcPs]
ctxt'  <- forall e ann. e -> CvtM (LocatedAn ann e)
returnLA []
                               ; let cxtTy :: HsType GhcPs
cxtTy = HsQualTy { hst_ctxt :: LHsContext GhcPs
hst_ctxt = LocatedAn AnnContext [LHsType GhcPs]
ctxt'
                                                      , hst_xqual :: XQualTy GhcPs
hst_xqual = NoExtField
noExtField
                                                      , hst_body :: LHsType GhcPs
hst_body = GenLocated SrcSpanAnnA (HsType GhcPs)
ty' }
                               ; HsSigType GhcPs
forTy <- forall ann a b. (LocatedAn ann a -> b) -> a -> CvtM b
wrapParLA (EpAnnForallTy
-> [LHsTyVarBndr Specificity GhcPs]
-> LHsType GhcPs
-> HsSigType GhcPs
mkHsExplicitSigType forall a. EpAnn a
noAnn [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)]
univs') HsType GhcPs
cxtTy
                               ; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA HsSigType GhcPs
forTy }
  | Bool
otherwise             = Type -> CvtM (LHsSigType GhcPs)
cvtSigType ([TyVarBndr Specificity] -> [Type] -> Type -> Type
ForallT [TyVarBndr Specificity]
univs [Type]
reqs ([TyVarBndr Specificity] -> [Type] -> Type -> Type
ForallT [TyVarBndr Specificity]
exis [Type]
provs Type
ty))
cvtPatSynSigTy Type
ty         = Type -> CvtM (LHsSigType GhcPs)
cvtSigType Type
ty

-----------------------------------------------------------
cvtFixity :: TH.Fixity -> Hs.Fixity
cvtFixity :: Fixity -> Fixity
cvtFixity (TH.Fixity Int
prec FixityDirection
dir) = SourceText -> Int -> FixityDirection -> Fixity
Hs.Fixity SourceText
NoSourceText Int
prec (FixityDirection -> FixityDirection
cvt_dir FixityDirection
dir)
   where
     cvt_dir :: FixityDirection -> FixityDirection
cvt_dir FixityDirection
TH.InfixL = FixityDirection
Hs.InfixL
     cvt_dir FixityDirection
TH.InfixR = FixityDirection
Hs.InfixR
     cvt_dir FixityDirection
TH.InfixN = FixityDirection
Hs.InfixN

-----------------------------------------------------------


-----------------------------------------------------------
-- some useful things

overloadedLit :: Lit -> Bool
-- True for literals that Haskell treats as overloaded
overloadedLit :: Lit -> Bool
overloadedLit (IntegerL  Integer
_) = Bool
True
overloadedLit (RationalL Rational
_) = Bool
True
overloadedLit Lit
_             = Bool
False

-- Checks that are performed when converting unboxed sum expressions and
-- patterns alike.
unboxedSumChecks :: TH.SumAlt -> TH.SumArity -> CvtM ()
unboxedSumChecks :: Int -> Int -> CvtM ()
unboxedSumChecks Int
alt Int
arity
    | Int
alt forall a. Ord a => a -> a -> Bool
> Int
arity
    = forall a. ConversionFailReason -> CvtM a
failWith forall a b. (a -> b) -> a -> b
$ Int -> Int -> ConversionFailReason
SumAltArityExceeded Int
alt Int
arity
    | Int
alt forall a. Ord a => a -> a -> Bool
<= Int
0
    = forall a. ConversionFailReason -> CvtM a
failWith forall a b. (a -> b) -> a -> b
$ Int -> ConversionFailReason
IllegalSumAlt Int
alt
    | Int
arity forall a. Ord a => a -> a -> Bool
< Int
2
    = forall a. ConversionFailReason -> CvtM a
failWith forall a b. (a -> b) -> a -> b
$ Int -> ConversionFailReason
IllegalSumArity Int
arity
    | Bool
otherwise
    = forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | If passed an empty list of 'LHsTyVarBndr's, this simply returns the
-- third argument (an 'LHsType'). Otherwise, return an 'HsForAllTy'
-- using the provided 'LHsQTyVars' and 'LHsType'.
mkHsForAllTy :: SrcSpanAnnA
             -- ^ The location of the returned 'LHsType' if it needs an
             --   explicit forall
             -> HsForAllTelescope GhcPs
             -- ^ The converted type variable binders
             -> LHsType GhcPs
             -- ^ The converted rho type
             -> LHsType GhcPs
             -- ^ The complete type, quantified with a forall if necessary
mkHsForAllTy :: SrcSpanAnnA
-> HsForAllTelescope GhcPs -> LHsType GhcPs -> LHsType GhcPs
mkHsForAllTy SrcSpanAnnA
loc HsForAllTelescope GhcPs
tele LHsType GhcPs
rho_ty
  | Bool
no_tvs    = LHsType GhcPs
rho_ty
  | Bool
otherwise = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc forall a b. (a -> b) -> a -> b
$ HsForAllTy { hst_tele :: HsForAllTelescope GhcPs
hst_tele = HsForAllTelescope GhcPs
tele
                                   , hst_xforall :: XForAllTy GhcPs
hst_xforall = NoExtField
noExtField
                                   , hst_body :: LHsType GhcPs
hst_body = LHsType GhcPs
rho_ty }
  where
    no_tvs :: Bool
no_tvs = case HsForAllTelescope GhcPs
tele of
      HsForAllVis   { hsf_vis_bndrs :: forall pass. HsForAllTelescope pass -> [LHsTyVarBndr () pass]
hsf_vis_bndrs   = [LHsTyVarBndr () GhcPs]
bndrs } -> forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LHsTyVarBndr () GhcPs]
bndrs
      HsForAllInvis { hsf_invis_bndrs :: forall pass.
HsForAllTelescope pass -> [LHsTyVarBndr Specificity pass]
hsf_invis_bndrs = [LHsTyVarBndr Specificity GhcPs]
bndrs } -> forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LHsTyVarBndr Specificity GhcPs]
bndrs

-- | If passed an empty 'TH.Cxt', this simply returns the third argument
-- (an 'LHsType'). Otherwise, return an 'HsQualTy' using the provided
-- 'LHsContext' and 'LHsType'.

-- It's important that we don't build an HsQualTy if the context is empty,
-- as the pretty-printer for HsType _always_ prints contexts, even if
-- they're empty. See #13183.
mkHsQualTy :: TH.Cxt
           -- ^ The original Template Haskell context
           -> SrcSpanAnnA
           -- ^ The location of the returned 'LHsType' if it needs an
           --   explicit context
           -> LHsContext GhcPs
           -- ^ The converted context
           -> LHsType GhcPs
           -- ^ The converted tau type
           -> LHsType GhcPs
           -- ^ The complete type, qualified with a context if necessary
mkHsQualTy :: [Type]
-> SrcSpanAnnA
-> LHsContext GhcPs
-> LHsType GhcPs
-> LHsType GhcPs
mkHsQualTy [Type]
ctxt SrcSpanAnnA
loc LHsContext GhcPs
ctxt' LHsType GhcPs
ty
  | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
ctxt = LHsType GhcPs
ty
  | Bool
otherwise = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc forall a b. (a -> b) -> a -> b
$ HsQualTy { hst_xqual :: XQualTy GhcPs
hst_xqual = NoExtField
noExtField
                                 , hst_ctxt :: LHsContext GhcPs
hst_ctxt  = LHsContext GhcPs
ctxt'
                                 , hst_body :: LHsType GhcPs
hst_body  = LHsType GhcPs
ty }

-- | @'mkHsContextMaybe' lc@ returns 'Nothing' if @lc@ is empty and @'Just' lc@
-- otherwise.
--
-- This is much like 'mkHsQualTy', except that it returns a
-- @'Maybe' ('LHsContext' 'GhcPs')@. This is used specifically for constructing
-- superclasses, datatype contexts (#20011), and contexts in GADT constructor
-- types (#20590). We wish to avoid using @'Just' []@ in the case of an empty
-- contexts, as the pretty-printer always prints 'Just' contexts, even if
-- they're empty.
mkHsContextMaybe :: LHsContext GhcPs -> Maybe (LHsContext GhcPs)
mkHsContextMaybe :: LHsContext GhcPs -> Maybe (LHsContext GhcPs)
mkHsContextMaybe lctxt :: LHsContext GhcPs
lctxt@(L SrcSpanAnnC
_ [GenLocated SrcSpanAnnA (HsType GhcPs)]
ctxt)
  | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated SrcSpanAnnA (HsType GhcPs)]
ctxt = forall a. Maybe a
Nothing
  | Bool
otherwise = forall a. a -> Maybe a
Just LHsContext GhcPs
lctxt

mkHsOuterFamEqnTyVarBndrs :: Maybe [LHsTyVarBndr () GhcPs] -> HsOuterFamEqnTyVarBndrs GhcPs
mkHsOuterFamEqnTyVarBndrs :: Maybe [LHsTyVarBndr () GhcPs] -> HsOuterFamEqnTyVarBndrs GhcPs
mkHsOuterFamEqnTyVarBndrs = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall flag. HsOuterTyVarBndrs flag GhcPs
mkHsOuterImplicit (forall flag.
EpAnnForallTy
-> [LHsTyVarBndr flag GhcPs] -> HsOuterTyVarBndrs flag GhcPs
mkHsOuterExplicit forall a. EpAnn a
noAnn)

--------------------------------------------------------------------
--      Turning Name back into RdrName
--------------------------------------------------------------------

-- variable names
vNameN, cNameN, vcNameN, tNameN, tconNameN :: TH.Name -> CvtM (LocatedN RdrName)
vNameL                                     :: TH.Name -> CvtM (LocatedA RdrName)
vName,  cName,  vcName,  tName,  tconName  :: TH.Name -> CvtM RdrName

-- Variable names
vNameN :: Name -> CvtM (LocatedN RdrName)
vNameN Name
n = forall a. CvtM a -> CvtM (LocatedN a)
wrapLN (Name -> CvtM RdrName
vName Name
n)
vNameL :: Name -> CvtM (LocatedA RdrName)
vNameL Name
n = forall a. CvtM a -> CvtM (LocatedA a)
wrapLA (Name -> CvtM RdrName
vName Name
n)
vName :: Name -> CvtM RdrName
vName Name
n = NameSpace -> Name -> CvtM RdrName
cvtName NameSpace
OccName.varName Name
n

-- Constructor function names; this is Haskell source, hence srcDataName
cNameN :: Name -> CvtM (LocatedN RdrName)
cNameN Name
n = forall a. CvtM a -> CvtM (LocatedN a)
wrapLN (Name -> CvtM RdrName
cName Name
n)
cName :: Name -> CvtM RdrName
cName Name
n = NameSpace -> Name -> CvtM RdrName
cvtName NameSpace
OccName.dataName Name
n

-- Variable *or* constructor names; check by looking at the first char
vcNameN :: Name -> CvtM (LocatedN RdrName)
vcNameN Name
n = forall a. CvtM a -> CvtM (LocatedN a)
wrapLN (Name -> CvtM RdrName
vcName Name
n)
vcName :: Name -> CvtM RdrName
vcName Name
n = if Name -> Bool
isVarName Name
n then Name -> CvtM RdrName
vName Name
n else Name -> CvtM RdrName
cName Name
n

-- Type variable names
tNameN :: Name -> CvtM (LocatedN RdrName)
tNameN Name
n = forall a. CvtM a -> CvtM (LocatedN a)
wrapLN (Name -> CvtM RdrName
tName Name
n)
tName :: Name -> CvtM RdrName
tName Name
n = NameSpace -> Name -> CvtM RdrName
cvtName NameSpace
OccName.tvName Name
n

-- Type Constructor names
tconNameN :: Name -> CvtM (LocatedN RdrName)
tconNameN Name
n = forall a. CvtM a -> CvtM (LocatedN a)
wrapLN (Name -> CvtM RdrName
tconName Name
n)
tconName :: Name -> CvtM RdrName
tconName Name
n = NameSpace -> Name -> CvtM RdrName
cvtName NameSpace
OccName.tcClsName Name
n

ipName :: String -> CvtM HsIPName
ipName :: String -> CvtM HsIPName
ipName String
n
  = do { forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String -> Bool
okVarOcc String
n) (forall a. ConversionFailReason -> CvtM a
failWith (NameSpace -> String -> ConversionFailReason
IllegalOccName NameSpace
OccName.varName String
n))
       ; forall (m :: * -> *) a. Monad m => a -> m a
return (CLabelString -> HsIPName
HsIPName (String -> CLabelString
fsLit String
n)) }

cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName
cvtName :: NameSpace -> Name -> CvtM RdrName
cvtName NameSpace
ctxt_ns (TH.Name OccName
occ NameFlavour
flavour)
  | Bool -> Bool
not (NameSpace -> String -> Bool
okOcc NameSpace
ctxt_ns String
occ_str) = forall a. ConversionFailReason -> CvtM a
failWith (NameSpace -> String -> ConversionFailReason
IllegalOccName NameSpace
ctxt_ns String
occ_str)
  | Bool
otherwise
  = do { SrcSpan
loc <- CvtM SrcSpan
getL
       ; let rdr_name :: RdrName
rdr_name = SrcSpan -> NameSpace -> String -> NameFlavour -> RdrName
thRdrName SrcSpan
loc NameSpace
ctxt_ns String
occ_str NameFlavour
flavour
       ; forall a. a -> CvtM ()
force RdrName
rdr_name
       ; forall (m :: * -> *) a. Monad m => a -> m a
return RdrName
rdr_name }
  where
    occ_str :: String
occ_str = OccName -> String
TH.occString OccName
occ

okOcc :: OccName.NameSpace -> String -> Bool
okOcc :: NameSpace -> String -> Bool
okOcc NameSpace
ns String
str
  | NameSpace -> Bool
OccName.isVarNameSpace NameSpace
ns     = String -> Bool
okVarOcc String
str
  | NameSpace -> Bool
OccName.isDataConNameSpace NameSpace
ns = String -> Bool
okConOcc String
str
  | Bool
otherwise                     = String -> Bool
okTcOcc  String
str

-- Determine the name space of a name in a type
--
isVarName :: TH.Name -> Bool
isVarName :: Name -> Bool
isVarName (TH.Name OccName
occ NameFlavour
_)
  = case OccName -> String
TH.occString OccName
occ of
      String
""    -> Bool
False
      (Char
c:String
_) -> Char -> Bool
startsVarId Char
c Bool -> Bool -> Bool
|| Char -> Bool
startsVarSym Char
c

thRdrName :: SrcSpan -> OccName.NameSpace -> String -> TH.NameFlavour -> RdrName
-- This turns a TH Name into a RdrName; used for both binders and occurrences
-- See Note [Binders in Template Haskell]
-- The passed-in name space tells what the context is expecting;
--      use it unless the TH name knows what name-space it comes
--      from, in which case use the latter
--
-- We pass in a SrcSpan (gotten from the monad) because this function
-- is used for *binders* and if we make an Exact Name we want it
-- to have a binding site inside it.  (cf #5434)
--
-- ToDo: we may generate silly RdrNames, by passing a name space
--       that doesn't match the string, like VarName ":+",
--       which will give confusing error messages later
--
-- The strict applications ensure that any buried exceptions get forced
thRdrName :: SrcSpan -> NameSpace -> String -> NameFlavour -> RdrName
thRdrName SrcSpan
loc NameSpace
ctxt_ns String
th_occ NameFlavour
th_name
  = case NameFlavour
th_name of
     TH.NameG NameSpace
th_ns PkgName
pkg ModName
mod -> String -> NameSpace -> PkgName -> ModName -> RdrName
thOrigRdrName String
th_occ NameSpace
th_ns PkgName
pkg ModName
mod
     TH.NameQ ModName
mod  -> (ModuleName -> OccName -> RdrName
mkRdrQual  forall a b. (a -> b) -> a -> b
$! ModName -> ModuleName
mk_mod ModName
mod) forall a b. (a -> b) -> a -> b
$! OccName
occ
     TH.NameL Integer
uniq -> Name -> RdrName
nameRdrName forall a b. (a -> b) -> a -> b
$! (((Unique -> OccName -> SrcSpan -> Name
Name.mkInternalName forall a b. (a -> b) -> a -> b
$! Int -> Unique
mk_uniq (forall a. Num a => Integer -> a
fromInteger Integer
uniq)) forall a b. (a -> b) -> a -> b
$! OccName
occ) SrcSpan
loc)
     TH.NameU Integer
uniq -> Name -> RdrName
nameRdrName forall a b. (a -> b) -> a -> b
$! (((Unique -> OccName -> SrcSpan -> Name
Name.mkSystemNameAt forall a b. (a -> b) -> a -> b
$! Int -> Unique
mk_uniq (forall a. Num a => Integer -> a
fromInteger Integer
uniq)) forall a b. (a -> b) -> a -> b
$! OccName
occ) SrcSpan
loc)
     NameFlavour
TH.NameS | Just Name
name <- OccName -> Maybe Name
isBuiltInOcc_maybe OccName
occ -> Name -> RdrName
nameRdrName forall a b. (a -> b) -> a -> b
$! Name
name
              | Bool
otherwise                           -> OccName -> RdrName
mkRdrUnqual forall a b. (a -> b) -> a -> b
$! OccName
occ
              -- We check for built-in syntax here, because the TH
              -- user might have written a (NameS "(,,)"), for example
  where
    occ :: OccName.OccName
    occ :: OccName
occ = NameSpace -> String -> OccName
mk_occ NameSpace
ctxt_ns String
th_occ

-- Return an unqualified exact RdrName if we're dealing with built-in syntax.
-- See #13776.
thOrigRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName
thOrigRdrName :: String -> NameSpace -> PkgName -> ModName -> RdrName
thOrigRdrName String
occ NameSpace
th_ns PkgName
pkg ModName
mod =
  let occ' :: OccName
occ' = NameSpace -> String -> OccName
mk_occ (NameSpace -> NameSpace
mk_ghc_ns NameSpace
th_ns) String
occ
      mod' :: GenModule Unit
mod' = forall u. u -> ModuleName -> GenModule u
mkModule (PkgName -> Unit
mk_pkg PkgName
pkg) (ModName -> ModuleName
mk_mod ModName
mod)
  in case OccName -> Maybe Name
isBuiltInOcc_maybe OccName
occ' forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> GenModule Unit -> OccName -> Maybe Name
isPunOcc_maybe GenModule Unit
mod' OccName
occ' of
       Just Name
name -> Name -> RdrName
nameRdrName Name
name
       Maybe Name
Nothing   -> (GenModule Unit -> OccName -> RdrName
mkOrig forall a b. (a -> b) -> a -> b
$! GenModule Unit
mod') forall a b. (a -> b) -> a -> b
$! OccName
occ'

thRdrNameGuesses :: TH.Name -> [RdrName]
thRdrNameGuesses :: Name -> [RdrName]
thRdrNameGuesses (TH.Name OccName
occ NameFlavour
flavour)
  -- This special case for NameG ensures that we don't generate duplicates in the output list
  | TH.NameG NameSpace
th_ns PkgName
pkg ModName
mod <- NameFlavour
flavour = [ String -> NameSpace -> PkgName -> ModName -> RdrName
thOrigRdrName String
occ_str NameSpace
th_ns PkgName
pkg ModName
mod]
  | Bool
otherwise                         = [ SrcSpan -> NameSpace -> String -> NameFlavour -> RdrName
thRdrName SrcSpan
noSrcSpan NameSpace
gns String
occ_str NameFlavour
flavour
                                        | NameSpace
gns <- [NameSpace]
guessed_nss]
  where
    -- guessed_ns are the name spaces guessed from looking at the TH name
    guessed_nss :: [NameSpace]
guessed_nss
      | CLabelString -> Bool
isLexCon (String -> CLabelString
mkFastString String
occ_str) = [NameSpace
OccName.tcName,  NameSpace
OccName.dataName]
      | Bool
otherwise                       = [NameSpace
OccName.varName, NameSpace
OccName.tvName]
    occ_str :: String
occ_str = OccName -> String
TH.occString OccName
occ

-- The packing and unpacking is rather turgid :-(
mk_occ :: OccName.NameSpace -> String -> OccName.OccName
mk_occ :: NameSpace -> String -> OccName
mk_occ NameSpace
ns String
occ = NameSpace -> String -> OccName
OccName.mkOccName NameSpace
ns String
occ

mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace
mk_ghc_ns :: NameSpace -> NameSpace
mk_ghc_ns NameSpace
TH.DataName  = NameSpace
OccName.dataName
mk_ghc_ns NameSpace
TH.TcClsName = NameSpace
OccName.tcClsName
mk_ghc_ns NameSpace
TH.VarName   = NameSpace
OccName.varName

mk_mod :: TH.ModName -> ModuleName
mk_mod :: ModName -> ModuleName
mk_mod ModName
mod = String -> ModuleName
mkModuleName (ModName -> String
TH.modString ModName
mod)

mk_pkg :: TH.PkgName -> Unit
mk_pkg :: PkgName -> Unit
mk_pkg PkgName
pkg = String -> Unit
stringToUnit (PkgName -> String
TH.pkgString PkgName
pkg)

mk_uniq :: Int -> Unique
mk_uniq :: Int -> Unique
mk_uniq Int
u = Int -> Unique
mkUniqueGrimily Int
u

{-
Note [Binders in Template Haskell]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this TH term construction:
  do { x1 <- TH.newName "x"   -- newName :: String -> Q TH.Name
     ; x2 <- TH.newName "x"   -- Builds a NameU
     ; x3 <- TH.newName "x"

     ; let x = mkName "x"     -- mkName :: String -> TH.Name
                              -- Builds a NameS

     ; return (LamE (..pattern [x1,x2]..) $
               LamE (VarPat x3) $
               ..tuple (x1,x2,x3,x)) }

It represents the term   \[x1,x2]. \x3. (x1,x2,x3,x)

a) We don't want to complain about "x" being bound twice in
   the pattern [x1,x2]
b) We don't want x3 to shadow the x1,x2
c) We *do* want 'x' (dynamically bound with mkName) to bind
   to the innermost binding of "x", namely x3.
d) When pretty printing, we want to print a unique with x1,x2
   etc, else they'll all print as "x" which isn't very helpful

When we convert all this to HsSyn, the TH.Names are converted with
thRdrName.  To achieve (b) we want the binders to be Exact RdrNames.
Achieving (a) is a bit awkward, because
   - We must check for duplicate and shadowed names on Names,
     not RdrNames, *after* renaming.
     See Note [Collect binders only after renaming] in GHC.Hs.Utils

   - But to achieve (a) we must distinguish between the Exact
     RdrNames arising from TH and the Unqual RdrNames that would
     come from a user writing \[x,x] -> blah

So in Convert.thRdrName we translate
   TH Name                          RdrName
   --------------------------------------------------------
   NameU (arising from newName) --> Exact (Name{ System })
   NameS (arising from mkName)  --> Unqual

Notice that the NameUs generate *System* Names.  Then, when
figuring out shadowing and duplicates, we can filter out
System Names.

This use of System Names fits with other uses of System Names, eg for
temporary variables "a". Since there are lots of things called "a" we
usually want to print the name with the unique, and that is indeed
the way System Names are printed.

There's a small complication of course; see Note [Looking up Exact
RdrNames] in GHC.Rename.Env.
-}

{-
Note [Pattern synonym type signatures and Template Haskell]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

In general, the type signature of a pattern synonym

  pattern P x1 x2 .. xn = <some-pattern>

is of the form

   forall univs. reqs => forall exis. provs => t1 -> t2 -> ... -> tn -> t

with the following parts:

   1) the (possibly empty lists of) universally quantified type
      variables `univs` and required constraints `reqs` on them.
   2) the (possibly empty lists of) existentially quantified type
      variables `exis` and the provided constraints `provs` on them.
   3) the types `t1`, `t2`, .., `tn` of the pattern synonym's arguments x1,
      x2, .., xn, respectively
   4) the type `t` of <some-pattern>, mentioning only universals from `univs`.

Due to the two forall quantifiers and constraint contexts (either of
which might be empty), pattern synonym type signatures are treated
specially in `GHC.HsToCore.Quote`, `GHC.ThToHs`, and
`GHC.Tc.Gen.Splice`:

   (a) When desugaring a pattern synonym from HsSyn to TH.Dec in
       `GHC.HsToCore.Quote`, we represent its *full* type signature in TH, i.e.:

           ForallT univs reqs (ForallT exis provs ty)
              (where ty is the AST representation of t1 -> t2 -> ... -> tn -> t)

   (b) When converting pattern synonyms from TH.Dec to HsSyn in
       `GHC.ThToHs`, we convert their TH type signatures back to an
       appropriate Haskell pattern synonym type of the form

         forall univs. reqs => forall exis. provs => t1 -> t2 -> ... -> tn -> t

       where initial empty `univs` type variables or an empty `reqs`
       constraint context are represented *explicitly* as `() =>`.

   (c) When reifying a pattern synonym in `GHC.Tc.Gen.Splice`, we always
       return its *full* type, i.e.:

           ForallT univs reqs (ForallT exis provs ty)
              (where ty is the AST representation of t1 -> t2 -> ... -> tn -> t)

The key point is to always represent a pattern synonym's *full* type
in cases (a) and (c) to make it clear which of the two forall
quantifiers and/or constraint contexts are specified, and which are
not. See GHC's user's guide on pattern synonyms for more information
about pattern synonym type signatures.

-}