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

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

{-
(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

import GHC.Hs as Hs
import GHC.Builtin.Names
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.Types.Basic as Hs
import GHC.Types.Fixity as Hs
import GHC.Types.ForeignCall
import GHC.Types.Unique
import GHC.Types.SourceText
import GHC.Utils.Error
import GHC.Data.Bag
import GHC.Utils.Lexeme
import GHC.Utils.Misc
import GHC.Data.FastString
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic

import qualified Data.ByteString as BS
import Control.Monad( unless, ap )

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 SDoc [LHsDecl GhcPs]
convertToHsDecls :: Origin -> SrcSpan -> [Dec] -> Either SDoc [LHsDecl GhcPs]
convertToHsDecls Origin
origin SrcSpan
loc [Dec]
ds = forall a. Origin -> SrcSpan -> CvtM a -> Either SDoc a
initCvt Origin
origin SrcSpan
loc (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 (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
cvt_dec [Dec]
ds))
  where
    cvt_dec :: Dec -> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
cvt_dec Dec
d = forall a b. (Show a, Ppr a) => String -> a -> CvtM b -> CvtM b
wrapMsg String
"declaration" Dec
d (Dec -> CvtM (Maybe (LHsDecl GhcPs))
cvtDec Dec
d)

convertToHsExpr :: Origin -> SrcSpan -> TH.Exp -> Either SDoc (LHsExpr GhcPs)
convertToHsExpr :: Origin -> SrcSpan -> Exp -> Either SDoc (LHsExpr GhcPs)
convertToHsExpr Origin
origin SrcSpan
loc Exp
e
  = forall a. Origin -> SrcSpan -> CvtM a -> Either SDoc a
initCvt Origin
origin SrcSpan
loc forall a b. (a -> b) -> a -> b
$ forall a b. (Show a, Ppr a) => String -> a -> CvtM b -> CvtM b
wrapMsg String
"expression" Exp
e forall a b. (a -> b) -> a -> b
$ Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
e

convertToPat :: Origin -> SrcSpan -> TH.Pat -> Either SDoc (LPat GhcPs)
convertToPat :: Origin -> SrcSpan -> Pat -> Either SDoc (LPat GhcPs)
convertToPat Origin
origin SrcSpan
loc Pat
p
  = forall a. Origin -> SrcSpan -> CvtM a -> Either SDoc a
initCvt Origin
origin SrcSpan
loc forall a b. (a -> b) -> a -> b
$ forall a b. (Show a, Ppr a) => String -> a -> CvtM b -> CvtM b
wrapMsg String
"pattern" Pat
p forall a b. (a -> b) -> a -> b
$ Pat -> CvtM (LPat GhcPs)
cvtPat Pat
p

convertToHsType :: Origin -> SrcSpan -> TH.Type -> Either SDoc (LHsType GhcPs)
convertToHsType :: Origin -> SrcSpan -> Type -> Either SDoc (LHsType GhcPs)
convertToHsType Origin
origin SrcSpan
loc Type
t
  = forall a. Origin -> SrcSpan -> CvtM a -> Either SDoc a
initCvt Origin
origin SrcSpan
loc forall a b. (a -> b) -> a -> b
$ forall a b. (Show a, Ppr a) => String -> a -> CvtM b -> CvtM b
wrapMsg String
"type" Type
t forall a b. (a -> b) -> a -> b
$ Type -> CvtM (LHsType GhcPs)
cvtType Type
t

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

-- 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 loc everywhere, for lack of anything better
-- In particular, we want it on binding locations, so that variables bound in
-- the spliced-in declarations get a location that at least relates to the splice point

instance Applicative CvtM where
    pure :: forall a. a -> CvtM a
pure a
x = forall a. (Origin -> SrcSpan -> Either SDoc (SrcSpan, a)) -> CvtM 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 (a -> b) -> CvtM a -> CvtM b
(<*>) = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

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

initCvt :: Origin -> SrcSpan -> CvtM a -> Either SDoc a
initCvt :: forall a. Origin -> SrcSpan -> CvtM a -> Either SDoc a
initCvt Origin
origin SrcSpan
loc (CvtM Origin -> SrcSpan -> Either SDoc (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 SDoc (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 :: SDoc -> CvtM a
failWith :: forall a. SDoc -> CvtM a
failWith SDoc
m = forall a. (Origin -> SrcSpan -> Either SDoc (SrcSpan, a)) -> CvtM a
CvtM (\Origin
_ SrcSpan
_ -> forall a b. a -> Either a b
Left SDoc
m)

getOrigin :: CvtM Origin
getOrigin :: CvtM Origin
getOrigin = forall a. (Origin -> SrcSpan -> Either SDoc (SrcSpan, a)) -> CvtM 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 a. (Origin -> SrcSpan -> Either SDoc (SrcSpan, a)) -> CvtM a
CvtM (\Origin
_ SrcSpan
loc -> forall a b. b -> Either a b
Right (SrcSpan
loc,SrcSpan
loc))

setL :: SrcSpan -> CvtM ()
setL :: SrcSpan -> CvtM ()
setL SrcSpan
loc = forall a. (Origin -> SrcSpan -> Either SDoc (SrcSpan, a)) -> CvtM a
CvtM (\Origin
_ SrcSpan
_ -> forall a b. b -> Either a b
Right (SrcSpan
loc, ()))

returnL :: a -> CvtM (Located a)
returnL :: forall a. a -> CvtM (Located a)
returnL a
x = forall a. (Origin -> SrcSpan -> Either SDoc (SrcSpan, a)) -> CvtM a
CvtM (\Origin
_ SrcSpan
loc -> forall a b. b -> Either a b
Right (SrcSpan
loc, forall l e. l -> e -> GenLocated l e
L SrcSpan
loc a
x))

-- returnLA :: a -> CvtM (LocatedA a)
returnLA :: e -> CvtM (GenLocated (SrcSpanAnn' (EpAnn ann)) e)
returnLA :: forall e ann. e -> CvtM (GenLocated (SrcSpanAnn' (EpAnn ann)) e)
returnLA e
x = forall a. (Origin -> SrcSpan -> Either SDoc (SrcSpan, a)) -> CvtM 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 (GenLocated (SrcSpanAnn' (EpAnn ann)) e)
returnLA

-- wrapParL :: (Located a -> a) -> a -> CvtM a
-- wrapParL add_par x = CvtM (\_ loc -> Right (loc, add_par (L loc x)))

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

wrapMsg :: (Show a, TH.Ppr a) => String -> a -> CvtM b -> CvtM b
-- E.g  wrapMsg "declaration" dec thing
wrapMsg :: forall a b. (Show a, Ppr a) => String -> a -> CvtM b -> CvtM b
wrapMsg String
what a
item (CvtM Origin -> SrcSpan -> Either SDoc (SrcSpan, b)
m)
  = forall a. (Origin -> SrcSpan -> Either SDoc (SrcSpan, a)) -> CvtM a
CvtM forall a b. (a -> b) -> a -> b
$ \Origin
origin SrcSpan
loc -> case Origin -> SrcSpan -> Either SDoc (SrcSpan, b)
m Origin
origin SrcSpan
loc of
      Left SDoc
err -> forall a b. a -> Either a b
Left (SDoc
err SDoc -> SDoc -> SDoc
$$ SDoc
msg)
      Right (SrcSpan, b)
v  -> forall a b. b -> Either a b
Right (SrcSpan, b)
v
  where
        -- Show the item in pretty syntax normally,
        -- but with all its constructors if you say -dppr-debug
    msg :: SDoc
msg = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"When splicing a TH" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
what SDoc -> SDoc -> SDoc
<> SDoc
colon)
                 Int
2 ((Bool -> SDoc) -> SDoc
getPprDebug forall a b. (a -> b) -> a -> b
$ \case
                     Bool
True  -> String -> SDoc
text (forall a. Show a => a -> String
show a
item)
                     Bool
False -> String -> SDoc
text (forall a. Ppr a => a -> String
pprint a
item))

wrapL :: CvtM a -> CvtM (Located a)
wrapL :: forall a. CvtM a -> CvtM (Located a)
wrapL (CvtM Origin -> SrcSpan -> Either SDoc (SrcSpan, a)
m) = forall a. (Origin -> SrcSpan -> Either SDoc (SrcSpan, a)) -> CvtM a
CvtM forall a b. (a -> b) -> a -> b
$ \Origin
origin SrcSpan
loc -> case Origin -> SrcSpan -> Either SDoc (SrcSpan, a)
m Origin
origin SrcSpan
loc of
  Left SDoc
err -> forall a b. a -> Either a b
Left SDoc
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 SDoc (SrcSpan, a)
m) = forall a. (Origin -> SrcSpan -> Either SDoc (SrcSpan, a)) -> CvtM a
CvtM forall a b. (a -> b) -> a -> b
$ \Origin
origin SrcSpan
loc -> case Origin -> SrcSpan -> Either SDoc (SrcSpan, a)
m Origin
origin SrcSpan
loc of
  Left SDoc
err -> forall a b. a -> Either a b
Left SDoc
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 SDoc (SrcSpan, a)
m) = forall a. (Origin -> SrcSpan -> Either SDoc (SrcSpan, a)) -> CvtM a
CvtM forall a b. (a -> b) -> a -> b
$ \Origin
origin SrcSpan
loc -> case Origin -> SrcSpan -> Either SDoc (SrcSpan, a)
m Origin
origin SrcSpan
loc of
  Left SDoc
err -> forall a b. a -> Either a b
Left SDoc
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)

-------------------------------------------------------------------
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 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
   SrcSpan (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
body' <- Body -> CvtM [LGRHS GhcPs (LHsExpr GhcPs)]
cvtGuard Body
body
        ; HsLocalBinds GhcPs
ds' <- SDoc -> [Dec] -> CvtM (HsLocalBinds GhcPs)
cvtLocalDecs (String -> SDoc
text String
"a where clause") [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
   SrcSpan (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
body' HsLocalBinds GhcPs
ds'
                  , pat_ext :: XPatBind GhcPs GhcPs
pat_ext = forall a. EpAnn a
noAnn
                  , pat_ticks :: ([CoreTickish], [[CoreTickish]])
pat_ticks = ([],[]) } }

cvtDec (TH.FunD Name
nm [Clause]
cls)
  | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Clause]
cls
  = forall a. SDoc -> CvtM a
failWith (String -> SDoc
text String
"Function binding for"
                 SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (String -> SDoc
text (forall a. Ppr a => a -> String
TH.pprint Name
nm))
                 SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"has no equations")
  | 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 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 (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') <- Cxt
-> 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 Cxt
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]
_ Cxt
_ 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
        ; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
isGadtDecl Bool -> Bool -> Bool
|| Bool
isH98Decl)
                 (forall a. SDoc -> CvtM a
failWith (String -> SDoc
text String
"Cannot mix GADT constructors with Haskell 98"
                        SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"constructors"))
        ; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall a. Maybe a -> Bool
isNothing Maybe Type
ksig Bool -> Bool -> Bool
|| Bool
isGadtDecl)
                 (forall a. SDoc -> CvtM a
failWith (String -> SDoc
text String
"Kind signatures are only allowed on GADTs"))
        ; (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
ctxt', LocatedN RdrName
tc', LHsQTyVars GhcPs
tvs') <- Cxt
-> Name
-> [TyVarBndr ()]
-> CvtM (LHsContext GhcPs, LocatedN RdrName, LHsQTyVars GhcPs)
cvt_tycl_hdr Cxt
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 Con -> CvtM (LConDecl GhcPs)
cvtConstr [Con]
constrs
        ; [GenLocated SrcSpan (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_ND :: NewOrData
dd_ND = NewOrData
DataType, dd_cType :: Maybe (XRec GhcPs CType)
dd_cType = forall a. Maybe a
Nothing
                                , dd_ctxt :: Maybe (LHsContext GhcPs)
dd_ctxt = forall a. a -> Maybe a
Just GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
ctxt'
                                , dd_kindSig :: Maybe (LHsType GhcPs)
dd_kindSig = Maybe (GenLocated SrcSpanAnnA (HsType GhcPs))
ksig'
                                , dd_cons :: [LConDecl GhcPs]
dd_cons = [GenLocated SrcSpanAnnA (ConDecl GhcPs)]
cons', dd_derivs :: HsDeriving GhcPs
dd_derivs = [GenLocated SrcSpan (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 (NewtypeD Cxt
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') <- Cxt
-> Name
-> [TyVarBndr ()]
-> CvtM (LHsContext GhcPs, LocatedN RdrName, LHsQTyVars GhcPs)
cvt_tycl_hdr Cxt
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' <- Con -> CvtM (LConDecl GhcPs)
cvtConstr Con
constr
        ; [GenLocated SrcSpan (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_ND :: NewOrData
dd_ND = NewOrData
NewType, dd_cType :: Maybe (XRec GhcPs CType)
dd_cType = forall a. Maybe a
Nothing
                                , dd_ctxt :: Maybe (LHsContext GhcPs)
dd_ctxt = forall a. a -> Maybe a
Just GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
ctxt'
                                , dd_kindSig :: Maybe (LHsType GhcPs)
dd_kindSig = Maybe (GenLocated SrcSpanAnnA (HsType GhcPs))
ksig'
                                , dd_cons :: [LConDecl GhcPs]
dd_cons = [GenLocated SrcSpanAnnA (ConDecl GhcPs)
con']
                                , dd_derivs :: HsDeriving GhcPs
dd_derivs = [GenLocated SrcSpan (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 (ClassD Cxt
ctxt Name
cl [TyVarBndr ()]
tvs [FunDep]
fds [Dec]
decs)
  = do  { (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
cxt', LocatedN RdrName
tc', LHsQTyVars GhcPs
tvs') <- Cxt
-> Name
-> [TyVarBndr ()]
-> CvtM (LHsContext GhcPs, LocatedN RdrName, LHsQTyVars GhcPs)
cvt_tycl_hdr Cxt
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') <- SDoc
-> [Dec]
-> CvtM
     (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],
      [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs])
cvt_ci_decs (String -> SDoc
text String
"a class declaration") [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. SDoc -> CvtM a
failWith forall a b. (a -> b) -> a -> b
$ (String -> SDoc
text String
"Default data instance declarations"
                     SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"are not allowed:")
                   SDoc -> SDoc -> SDoc
$$ (forall a. Outputable a => a -> SDoc
Outputable.ppr [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, LayoutInfo
NoLayoutInfo)
                    , tcdCtxt :: Maybe (LHsContext GhcPs)
tcdCtxt = forall a. a -> Maybe a
Just 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 Cxt
ctxt Type
ty [Dec]
decs)
  = do  { let doc :: SDoc
doc = String -> SDoc
text String
"an instance declaration"
        ; (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') <- SDoc
-> [Dec]
-> CvtM
     (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],
      [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs])
cvt_ci_decs SDoc
doc [Dec]
decs
        ; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated SrcSpanAnnA (FamilyDecl GhcPs)]
fams') (forall a. SDoc -> CvtM a
failWith (forall a. Outputable a => SDoc -> [a] -> SDoc
mkBadDecMsg SDoc
doc [GenLocated SrcSpanAnnA (FamilyDecl GhcPs)]
fams'))
        ; GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
ctxt' <- PprPrec -> Cxt -> CvtM (LHsContext GhcPs)
cvtContext PprPrec
funPrec Cxt
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
$
                         Cxt
-> SrcSpanAnnA
-> LHsContext GhcPs
-> LHsType GhcPs
-> LHsType GhcPs
mkHsQualTy Cxt
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') <- Cxt
-> Name
-> [TyVarBndr ()]
-> CvtM (LHsContext GhcPs, LocatedN RdrName, LHsQTyVars GhcPs)
cvt_tycl_hdr [] Name
tc [TyVarBndr ()]
tvs
       ; GenLocated SrcSpan (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 SrcSpan (FamilyResultSig GhcPs)
result forall a. Maybe a
Nothing }

cvtDec (DataInstD Cxt
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') <- Cxt
-> Maybe [TyVarBndr ()]
-> Type
-> CvtM
     (LHsContext GhcPs, LocatedN RdrName, HsOuterFamEqnTyVarBndrs GhcPs,
      HsTyPats GhcPs)
cvt_datainst_hdr Cxt
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 Con -> CvtM (LConDecl GhcPs)
cvtConstr [Con]
constrs
       ; [GenLocated SrcSpan (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_ND :: NewOrData
dd_ND = NewOrData
DataType, dd_cType :: Maybe (XRec GhcPs CType)
dd_cType = forall a. Maybe a
Nothing
                               , dd_ctxt :: Maybe (LHsContext GhcPs)
dd_ctxt = forall a. a -> Maybe a
Just GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
ctxt'
                               , dd_kindSig :: Maybe (LHsType GhcPs)
dd_kindSig = Maybe (GenLocated SrcSpanAnnA (HsType GhcPs))
ksig'
                               , dd_cons :: [LConDecl GhcPs]
dd_cons = [GenLocated SrcSpanAnnA (ConDecl GhcPs)]
cons', dd_derivs :: HsDeriving GhcPs
dd_derivs = [GenLocated SrcSpan (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 = forall a. EpAnn a
noAnn
           , 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 Cxt
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') <- Cxt
-> Maybe [TyVarBndr ()]
-> Type
-> CvtM
     (LHsContext GhcPs, LocatedN RdrName, HsOuterFamEqnTyVarBndrs GhcPs,
      HsTyPats GhcPs)
cvt_datainst_hdr Cxt
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' <- Con -> CvtM (LConDecl GhcPs)
cvtConstr Con
constr
       ; [GenLocated SrcSpan (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_ND :: NewOrData
dd_ND = NewOrData
NewType, dd_cType :: Maybe (XRec GhcPs CType)
dd_cType = forall a. Maybe a
Nothing
                               , dd_ctxt :: Maybe (LHsContext GhcPs)
dd_ctxt = forall a. a -> Maybe a
Just GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
ctxt'
                               , dd_kindSig :: Maybe (LHsType GhcPs)
dd_kindSig = Maybe (GenLocated SrcSpanAnnA (HsType GhcPs))
ksig'
                               , dd_cons :: [LConDecl GhcPs]
dd_cons = [GenLocated SrcSpanAnnA (ConDecl GhcPs)
con'], dd_derivs :: HsDeriving GhcPs
dd_derivs = [GenLocated SrcSpan (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 = forall a. EpAnn a
noAnn
           , 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 SrcSpan (FamilyResultSig GhcPs)
result', Maybe (GenLocated SrcSpan (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 SrcSpan (FamilyResultSig GhcPs)
result' Maybe (GenLocated SrcSpan (InjectivityAnn GhcPs))
injectivity'
       }

cvtDec (ClosedTypeFamilyD TypeFamilyHead
head [TySynEqn]
eqns)
  = do { (LocatedN RdrName
tc', LHsQTyVars GhcPs
tyvars', GenLocated SrcSpan (FamilyResultSig GhcPs)
result', Maybe (GenLocated SrcSpan (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 SrcSpan (FamilyResultSig GhcPs)
result' Maybe (GenLocated SrcSpan (InjectivityAnn GhcPs))
injectivity' }

cvtDec (TH.RoleAnnotD Name
tc [Role]
roles)
  = do { LocatedN RdrName
tc' <- Name -> CvtM (LocatedN RdrName)
tconNameN Name
tc
       ; let roles' :: [Located (Maybe Role)]
roles' = forall a b. (a -> b) -> [a] -> [b]
map (forall e. e -> Located e
noLoc 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' [Located (Maybe Role)]
roles') }

cvtDec (TH.StandaloneDerivD Maybe DerivStrategy
ds Cxt
cxt Type
ty)
  = do { GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
cxt' <- PprPrec -> Cxt -> CvtM (LHsContext GhcPs)
cvtContext PprPrec
funPrec Cxt
cxt
       ; Maybe (GenLocated SrcSpan (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
$
                        Cxt
-> SrcSpanAnnA
-> LHsContext GhcPs
-> LHsType GhcPs
-> LHsType GhcPs
mkHsQualTy Cxt
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 SrcSpan (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) =>
PatSynArgs
-> CvtM
     (HsConDetails Void (LocatedN RdrName) [RecordPatSynField pass])
cvtArgs PatSynArgs
args
       ; HsPatSynDir GhcPs
dir'  <- LocatedN RdrName -> PatSynDir -> CvtM (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
     (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 -> LocatedN 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 (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 p -> HsMatchContext p
mkPrefixFunRhs LocatedN RdrName
n)) [Clause]
cls
         ; Origin
th_origin <- CvtM Origin
getOrigin
         ; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall id. MatchGroup id (LHsExpr id) -> HsPatSynDir id
ExplicitBidirectional forall a b. (a -> b) -> a -> b
$ 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 a an. a -> LocatedAn an a
noLocA [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. SDoc -> CvtM a
failWith (String -> SDoc
text String
"Implicit parameter binding only allowed in let or where")

----------------
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 (GenLocated (SrcSpanAnn' (EpAnn 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 (GenLocated (SrcSpanAnn' (EpAnn 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. SDoc -> CvtM a
failWith forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"Invalid type family instance LHS:"
                          SDoc -> SDoc -> SDoc
<+> String -> SDoc
text (forall a. Show a => a -> String
show Type
lhs)
        }

----------------
cvt_ci_decs :: SDoc -> [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 :: SDoc
-> [Dec]
-> CvtM
     (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],
      [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs])
cvt_ci_decs SDoc
doc [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 (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
bads) (forall a. SDoc -> CvtM a
failWith (forall a. Outputable a => SDoc -> [a] -> SDoc
mkBadDecMsg SDoc
doc [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
bads))
        ; 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 :: Cxt
-> Name
-> [TyVarBndr ()]
-> CvtM (LHsContext GhcPs, LocatedN RdrName, LHsQTyVars GhcPs)
cvt_tycl_hdr Cxt
cxt Name
tc [TyVarBndr ()]
tvs
  = do { GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
cxt' <- PprPrec -> Cxt -> CvtM (LHsContext GhcPs)
cvtContext PprPrec
funPrec Cxt
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 :: Cxt
-> Maybe [TyVarBndr ()]
-> Type
-> CvtM
     (LHsContext GhcPs, LocatedN RdrName, HsOuterFamEqnTyVarBndrs GhcPs,
      HsTyPats GhcPs)
cvt_datainst_hdr Cxt
cxt Maybe [TyVarBndr ()]
bndrs Type
tys
  = do { GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
cxt' <- PprPrec -> Cxt -> CvtM (LHsContext GhcPs)
cvtContext PprPrec
funPrec Cxt
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. SDoc -> CvtM a
failWith forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"Invalid type instance header:"
                          SDoc -> SDoc -> SDoc
<+> String -> SDoc
text (forall a. Show a => a -> String
show 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') <- Cxt
-> Name
-> [TyVarBndr ()]
-> CvtM (LHsContext GhcPs, LocatedN RdrName, LHsQTyVars GhcPs)
cvt_tycl_hdr [] Name
tc [TyVarBndr ()]
tyvars
       ; GenLocated SrcSpan (FamilyResultSig GhcPs)
result' <- FamilyResultSig -> CvtM (LFamilyResultSig GhcPs)
cvtFamilyResultSig FamilyResultSig
result
       ; Maybe (GenLocated SrcSpan (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 SrcSpan (FamilyResultSig GhcPs)
result', Maybe (GenLocated SrcSpan (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

mkBadDecMsg :: Outputable a => SDoc -> [a] -> SDoc
mkBadDecMsg :: forall a. Outputable a => SDoc -> [a] -> SDoc
mkBadDecMsg SDoc
doc [a]
bads
  = [SDoc] -> SDoc
sep [ String -> SDoc
text String
"Illegal declaration(s) in" SDoc -> SDoc -> SDoc
<+> SDoc
doc SDoc -> SDoc -> SDoc
<> SDoc
colon
        , Int -> SDoc -> SDoc
nest Int
2 ([SDoc] -> SDoc
vcat (forall a b. (a -> b) -> [a] -> [b]
map forall a. Outputable a => a -> SDoc
Outputable.ppr [a]
bads)) ]

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

cvtConstr :: TH.Con -> CvtM (LConDecl GhcPs)

cvtConstr :: Con -> CvtM (LConDecl GhcPs)
cvtConstr (NormalC Name
c [BangType]
strtys)
  = do  { LocatedN RdrName
c'   <- Name -> CvtM (LocatedN RdrName)
cNameN 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 (GenLocated (SrcSpanAnn' (EpAnn 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 pass. a -> HsScaled pass a
hsLinear [GenLocated SrcSpanAnnA (HsType GhcPs)]
tys')) }

cvtConstr (RecC Name
c [VarBangType]
varstrtys)
  = do  { LocatedN RdrName
c'    <- Name -> CvtM (LocatedN RdrName)
cNameN 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
        ; forall e ann. e -> CvtM (GenLocated (SrcSpanAnn' (EpAnn 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. rec -> HsConDetails tyarg arg rec
RecCon (forall a an. a -> LocatedAn an a
noLocA [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
args')) }

cvtConstr (InfixC BangType
st1 Name
c BangType
st2)
  = do  { LocatedN RdrName
c'   <- Name -> CvtM (LocatedN RdrName)
cNameN 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 (GenLocated (SrcSpanAnn' (EpAnn 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 pass. a -> HsScaled pass a
hsLinear GenLocated SrcSpanAnnA (HsType GhcPs)
st1') (forall a pass. a -> HsScaled pass a
hsLinear GenLocated SrcSpanAnnA (HsType GhcPs)
st2')) }

cvtConstr (ForallC [TyVarBndr Specificity]
tvs Cxt
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 -> Cxt -> CvtM (LHsContext GhcPs)
cvtContext PprPrec
funPrec Cxt
ctxt
        ; L SrcSpanAnnA
_ ConDecl GhcPs
con'  <- Con -> CvtM (LConDecl GhcPs)
cvtConstr Con
con
        ; forall e ann. e -> CvtM (GenLocated (SrcSpanAnn' (EpAnn 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 l [a]
-> Maybe (GenLocated l [a]) -> Maybe (GenLocated l [a])
add_cxt GenLocated l [a]
lcxt         Maybe (GenLocated l [a])
Nothing           = forall a. a -> Maybe a
Just GenLocated l [a]
lcxt
    add_cxt (L l
loc [a]
cxt1) (Just (L l
_ [a]
cxt2))
      = forall a. a -> Maybe a
Just (forall l e. l -> e -> GenLocated l e
L l
loc ([a]
cxt1 forall a. [a] -> [a] -> [a]
++ [a]
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} {a} {l}.
GenLocated l [a]
-> Maybe (GenLocated l [a]) -> Maybe (GenLocated l [a])
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} {a} {l}.
GenLocated l [a]
-> Maybe (GenLocated l [a]) -> Maybe (GenLocated l [a])
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 (GadtC [] [BangType]
_strtys Type
_ty)
  = forall a. SDoc -> CvtM a
failWith (String -> SDoc
text String
"GadtC must have at least one constructor name")

cvtConstr (GadtC [Name]
c [BangType]
strtys Type
ty)
  = do  { [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)
cNameN [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
        ; forall e ann. e -> CvtM (GenLocated (SrcSpanAnn' (EpAnn ann)) e)
returnLA forall a b. (a -> b) -> a -> b
$ [LocatedN RdrName]
-> HsConDeclGADTDetails GhcPs -> LHsType GhcPs -> ConDecl GhcPs
mk_gadt_decl [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 pass. a -> HsScaled pass a
hsLinear [GenLocated SrcSpanAnnA (HsType GhcPs)]
args) GenLocated SrcSpanAnnA (HsType GhcPs)
ty'}

cvtConstr (RecGadtC [] [VarBangType]
_varstrtys Type
_ty)
  = forall a. SDoc -> CvtM a
failWith (String -> SDoc
text String
"RecGadtC must have at least one constructor name")

cvtConstr (RecGadtC [Name]
c [VarBangType]
varstrtys Type
ty)
  = do  { [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)
cNameN [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
        ; forall e ann. e -> CvtM (GenLocated (SrcSpanAnn' (EpAnn ann)) e)
returnLA forall a b. (a -> b) -> a -> b
$ [LocatedN RdrName]
-> HsConDeclGADTDetails GhcPs -> LHsType GhcPs -> ConDecl GhcPs
mk_gadt_decl [LocatedN RdrName]
c' (forall pass.
XRec pass [LConDeclField pass] -> HsConDeclGADTDetails pass
RecConGADT forall a b. (a -> b) -> a -> b
$ forall a an. a -> LocatedAn an a
noLocA [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
rec_flds) GenLocated SrcSpanAnnA (HsType GhcPs)
ty' }

mk_gadt_decl :: [LocatedN RdrName] -> HsConDeclGADTDetails GhcPs -> LHsType GhcPs
             -> ConDecl GhcPs
mk_gadt_decl :: [LocatedN RdrName]
-> HsConDeclGADTDetails GhcPs -> LHsType GhcPs -> ConDecl GhcPs
mk_gadt_decl [LocatedN RdrName]
names HsConDeclGADTDetails GhcPs
args LHsType GhcPs
res_ty
  = ConDeclGADT { con_g_ext :: XConDeclGADT GhcPs
con_g_ext  = forall a. EpAnn a
noAnn
                , con_names :: [XRec GhcPs (IdP GhcPs)]
con_names  = [LocatedN RdrName]
names
                , con_bndrs :: XRec GhcPs (HsOuterTyVarBndrs Specificity GhcPs)
con_bndrs  = forall a an. a -> LocatedAn an a
noLocA forall flag. HsOuterTyVarBndrs flag GhcPs
mkHsOuterImplicit
                , 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 LHsDocString
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 (GenLocated (SrcSpanAnn' (EpAnn 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 (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a an. a -> LocatedAn an a
noLocA (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. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnN
li) forall a b. (a -> b) -> a -> b
$ forall pass. XCFieldOcc pass -> LocatedN 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 LHsDocString
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 (GenLocated (SrcSpanAnn' (EpAnn 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)
  -- 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 -> CvtM (ForeignDecl GhcPs)
mk_imp (Located CCallConv
-> Located Safety
-> Maybe Header
-> CImportSpec
-> Located SourceText
-> ForeignImport
CImport (forall e. e -> Located e
noLoc (Callconv -> CCallConv
cvt_conv Callconv
callconv)) (forall e. e -> Located e
noLoc 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))
                    (forall e. e -> Located e
noLoc forall a b. (a -> b) -> a -> b
$ String -> SourceText
quotedSourceText String
from))
  | Just ForeignImport
impspec <- Located CCallConv
-> Located Safety
-> CLabelString
-> String
-> Located SourceText
-> Maybe ForeignImport
parseCImport (forall e. e -> Located e
noLoc (Callconv -> CCallConv
cvt_conv Callconv
callconv)) (forall e. e -> Located e
noLoc Safety
safety')
                                 (String -> CLabelString
mkFastString (Name -> String
TH.nameBase Name
nm))
                                 String
from (forall e. e -> Located e
noLoc forall a b. (a -> b) -> a -> b
$ String -> SourceText
quotedSourceText String
from)
  = ForeignImport -> CvtM (ForeignDecl GhcPs)
mk_imp ForeignImport
impspec
  | Bool
otherwise
  = forall a. SDoc -> CvtM a
failWith forall a b. (a -> b) -> a -> b
$ String -> SDoc
text (forall a. Show a => a -> String
show String
from) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is not a valid ccall impent"
  where
    mk_imp :: ForeignImport -> CvtM (ForeignDecl GhcPs)
mk_imp ForeignImport
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
fd_fi = ForeignImport
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
        ; let e :: ForeignExport
e = Located CExportSpec -> Located SourceText -> ForeignExport
CExport (forall e. e -> Located e
noLoc (SourceText -> CLabelString -> CCallConv -> CExportSpec
CExportStatic (String -> SourceText
SourceText String
as)
                                                (String -> CLabelString
mkFastString String
as)
                                                (Callconv -> CCallConv
cvt_conv Callconv
callconv)))
                                                (forall e. e -> Located e
noLoc (String -> SourceText
SourceText String
as))
        ; 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
fd_fe = ForeignExport
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    = String -> SourceText
SourceText forall a b. (a -> b) -> a -> b
$ Inline -> String
src Inline
inline
                                 , inl_inline :: InlineSpec
inl_inline = Inline -> InlineSpec
cvtInline 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 }
       ; 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,String
srcText) = case Maybe Inline
inline of
               Just Inline
inline1 -> (Inline -> InlineSpec
cvtInline Inline
inline1, Inline -> Activation
dfltActivation Inline
inline1,
                                Inline -> String
src Inline
inline1)
               Maybe Inline
Nothing      -> (InlineSpec
NoUserInlinePrag,   Activation
AlwaysActive,
                                String
"{-# SPECIALISE")
       ; let ip :: InlinePragma
ip = InlinePragma { inl_src :: SourceText
inl_src    = String -> SourceText
SourceText String
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 -> SourceText -> 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
       ; 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 SrcSpan (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
       ; 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
                      , rds_src :: SourceText
rds_src = String -> SourceText
SourceText String
"{-# RULES"
                      , rds_rules :: [LRuleDecl GhcPs]
rds_rules = [forall a an. a -> LocatedAn an a
noLocA forall a b. (a -> b) -> a -> b
$
                          HsRule { rd_ext :: XHsRule GhcPs
rd_ext  = forall a. EpAnn a
noAnn
                                 , rd_name :: XRec GhcPs (SourceText, CLabelString)
rd_name = (forall e. e -> Located e
noLoc (String -> SourceText
quotedSourceText String
nm,CLabelString
nm'))
                                 , 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 SrcSpan (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' }] }

          }

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 (m :: * -> *) a. Monad m => a -> m a
return (forall pass. LIdP pass -> AnnProvenance pass
TypeAnnProvenance  (forall a an. a -> LocatedAn an a
noLocA RdrName
n'))
         ValueAnnotation Name
n -> do
           RdrName
n' <- Name -> CvtM RdrName
vcName Name
n
           forall (m :: * -> *) a. Monad m => a -> m a
return (forall pass. LIdP pass -> AnnProvenance pass
ValueAnnProvenance (forall a an. a -> LocatedAn an a
noLocA 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
-> SourceText
-> 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'
       }

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 e. e -> Located e
noLoc 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)
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
-> SourceText
-> 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 -> Hs.InlineSpec
cvtInline :: Inline -> InlineSpec
cvtInline Inline
TH.NoInline  = InlineSpec
Hs.NoInline
cvtInline Inline
TH.Inline    = InlineSpec
Hs.Inline
cvtInline Inline
TH.Inlinable = InlineSpec
Hs.Inlinable

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 (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall e. e -> Located e
noLoc 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 (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall e. e -> Located e
noLoc 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
$ EpAnn EpaLocation -> LHsType GhcPs -> HsPatSigType GhcPs
mkHsPatSigType forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (HsType GhcPs)
ty' }

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

cvtLocalDecs :: SDoc -> [TH.Dec] -> CvtM (HsLocalBinds GhcPs)
cvtLocalDecs :: SDoc -> [Dec] -> CvtM (HsLocalBinds GhcPs)
cvtLocalDecs SDoc
doc [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 (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
bads) (forall a. SDoc -> CvtM a
failWith (forall a. Outputable a => SDoc -> [a] -> SDoc
mkBadDecMsg SDoc
doc [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
bads))
        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. SDoc -> CvtM a
failWith (String -> SDoc
text String
"Implicit parameters mixed with other bindings")

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
   SrcSpan (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
g'  <- Body -> CvtM [LGRHS GhcPs (LHsExpr GhcPs)]
cvtGuard Body
body
        ; HsLocalBinds GhcPs
ds' <- SDoc -> [Dec] -> CvtM (HsLocalBinds GhcPs)
cvtLocalDecs (String -> SDoc
text String
"a where clause") [Dec]
wheres
        ; forall e ann. e -> CvtM (GenLocated (SrcSpanAnn' (EpAnn ann)) e)
returnLA forall a b. (a -> b) -> a -> b
$ forall p body.
XCMatch p body
-> HsMatchContext (NoGhcTc 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
   SrcSpan (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 (GenLocated (SrcSpanAnn' (EpAnn ann)) e)
returnLA (forall id.
XCIPBind id
-> Either (XRec id HsIPName) (IdP id) -> LHsExpr id -> IPBind id
IPBind forall a. EpAnn a
noAnn (forall a b. a -> Either a b
Left 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 (HsExpr GhcPs)
cvt Exp
e)
  where
    cvt :: Exp -> CvtM (HsExpr GhcPs)
cvt (VarE Name
s)   = do { RdrName
s' <- Name -> CvtM RdrName
vName Name
s; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
noExtField (forall a an. a -> LocatedAn an a
noLocA RdrName
s') }
    cvt (ConE Name
s)   = do { RdrName
s' <- Name -> CvtM RdrName
cName Name
s; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
noExtField (forall a an. a -> LocatedAn an a
noLocA 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 (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 (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 (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'
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if l GhcPs -> Bool
is_compound_lit l GhcPs
l' then forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar forall a. EpAnn a
noAnn (forall a an. a -> LocatedAn an a
noLocA HsExpr GhcPs
e') else HsExpr GhcPs
e'
    cvt (AppE x :: Exp
x@(LamE [Pat]
_ Exp
_) 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 p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp EpAnnCO
noComments (forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkLHsPar GenLocated SrcSpanAnnA (HsExpr GhcPs)
x')
                                                          (forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkLHsPar GenLocated SrcSpanAnnA (HsExpr GhcPs)
y')}
    cvt (AppE 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 p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp EpAnnCO
noComments (forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkLHsPar GenLocated SrcSpanAnnA (HsExpr GhcPs)
x')
                                                          (forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkLHsPar GenLocated SrcSpanAnnA (HsExpr GhcPs)
y')}
    cvt (AppTypeE Exp
e Type
t) = do { GenLocated SrcSpanAnnA (HsExpr GhcPs)
e' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
e
                            ; GenLocated SrcSpanAnnA (HsType GhcPs)
t' <- Type -> CvtM (LHsType GhcPs)
cvtType Type
t
                            ; let tp :: LHsType GhcPs
tp = forall (p :: Pass).
PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)
parenthesizeHsType PprPrec
appPrec GenLocated SrcSpanAnnA (HsType GhcPs)
t'
                            ; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p.
XAppTypeE p -> LHsExpr p -> LHsWcType (NoGhcTc p) -> HsExpr p
HsAppType SrcSpan
noSrcSpan GenLocated SrcSpanAnnA (HsExpr GhcPs)
e'
                                     forall a b. (a -> b) -> a -> b
$ forall thing. thing -> HsWildCardBndrs GhcPs thing
mkHsWildCardBndrs LHsType GhcPs
tp }
    cvt (LamE [] Exp
e)    = Exp -> CvtM (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 (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p. XLam p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLam NoExtField
noExtField (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 a an. a -> LocatedAn an a
noLocA [forall (p :: Pass) (body :: * -> *).
(Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcSpanAnnA,
 Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpan) =>
HsMatchContext (NoGhcTc (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 p. HsMatchContext p
CaseAlt) [Match]
ms
                            ; Origin
th_origin <- CvtM Origin
getOrigin
                            ; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p. XLamCase p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLamCase forall a. EpAnn a
noAnn
                                                   (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 a an. a -> LocatedAn an a
noLocA [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
ms'))
                            }
    cvt (TupE [Maybe Exp]
es)        = [Maybe Exp] -> Boxity -> CvtM (HsExpr GhcPs)
cvt_tup [Maybe Exp]
es Boxity
Boxed
    cvt (UnboxedTupE [Maybe Exp]
es) = [Maybe Exp] -> Boxity -> CvtM (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. SDoc -> CvtM a
failWith (String -> SDoc
text String
"Multi-way if-expression with no alternatives")
      | Bool
otherwise      = do { [GenLocated
   SrcSpan (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
   SrcSpan (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
alts' }
    cvt (LetE [Dec]
ds Exp
e)    = do { HsLocalBinds GhcPs
ds' <- SDoc -> [Dec] -> CvtM (HsLocalBinds GhcPs)
cvtLocalDecs (String -> SDoc
text String
"a let expression") [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 -> HsLocalBinds p -> LHsExpr p -> HsExpr p
HsLet forall a. EpAnn a
noAnn HsLocalBinds GhcPs
ds' 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 (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p.
XCase p -> LHsExpr p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsCase forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (HsExpr GhcPs)
e'
                                                 (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 a an. a -> LocatedAn an a
noLocA [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
ms')) }
    cvt (DoE Maybe ModName
m [Stmt]
ss)     = HsStmtContext GhcRn -> [Stmt] -> CvtM (HsExpr GhcPs)
cvtHsDo (forall p. Maybe ModuleName -> HsStmtContext p
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)    = HsStmtContext GhcRn -> [Stmt] -> CvtM (HsExpr GhcPs)
cvtHsDo (forall p. Maybe ModuleName -> HsStmtContext p
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)     = HsStmtContext GhcRn -> [Stmt] -> CvtM (HsExpr GhcPs)
cvtHsDo forall p. HsStmtContext p
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 a. (LocatedA a -> a) -> a -> CvtM a
wrapParLA (forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar forall a. EpAnn a
noAnn)
           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 a. (LocatedA a -> a) -> a -> CvtM a
wrapParLA (forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar forall a. EpAnn a
noAnn) 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 a. (LocatedA a -> a) -> a -> CvtM a
wrapParLA (forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar forall a. EpAnn a
noAnn) 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 p. XPar p -> LHsExpr p -> HsExpr p
HsPar forall a. EpAnn a
noAnn 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 (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 p. XPar p -> LHsExpr p -> HsExpr p
HsPar forall a. EpAnn a
noAnn 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
   (HsRecField'
      (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 -> t)
-> FieldExp -> CvtM (LHsRecField' GhcPs t (LHsExpr GhcPs))
cvtFld (LocatedN RdrName -> FieldOcc GhcPs
mkFieldOcc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a an. a -> LocatedAn an a
noLocA)) [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 (Located Int) -> HsRecFields p arg
HsRecFields [GenLocated
   SrcSpanAnnA
   (HsRecField'
      (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
   (HsRecField'
      (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 -> t)
-> FieldExp -> CvtM (LHsRecField' GhcPs t (LHsExpr GhcPs))
cvtFld (LocatedN RdrName -> AmbiguousFieldOcc GhcPs
mkAmbiguousFieldOcc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a an. a -> LocatedAn an a
noLocA))
                                           [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
   (HsRecField'
      (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 (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
noExtField (forall a an. a -> LocatedAn an a
noLocA 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 -> CLabelString -> HsExpr p
HsOverLabel EpAnnCO
noComments (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 -> Located (HsFieldLabel p) -> HsExpr p
HsGetField EpAnnCO
noComments GenLocated SrcSpanAnnA (HsExpr GhcPs)
e' (forall l e. l -> e -> GenLocated l e
L SrcSpan
noSrcSpan (forall p.
XCHsFieldLabel p -> Located CLabelString -> HsFieldLabel p
HsFieldLabel forall a. EpAnn a
noAnn (forall l e. l -> e -> GenLocated l e
L SrcSpan
noSrcSpan (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 (Located (HsFieldLabel 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 SrcSpan
noSrcSpan forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p.
XCHsFieldLabel p -> Located CLabelString -> HsFieldLabel p
HsFieldLabel forall a. EpAnn a
noAnn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. l -> e -> GenLocated l e
L SrcSpan
noSrcSpan 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. SDoc -> CvtM a
failWith (String -> SDoc
text String
"Non-variable expression is not allowed in an infix expression")

{- 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 -> t) -> (TH.Name, TH.Exp)
       -> CvtM (LHsRecField' GhcPs t (LHsExpr GhcPs))
cvtFld :: forall t.
(RdrName -> t)
-> FieldExp -> CvtM (LHsRecField' GhcPs t (LHsExpr GhcPs))
cvtFld RdrName -> t
f (Name
v,Exp
e)
  = do  { LocatedA RdrName
v' <- Name -> CvtM (LocatedA RdrName)
vNameL Name
v; GenLocated SrcSpanAnnA (HsExpr GhcPs)
e' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
e
        ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a an. a -> LocatedAn an a
noLocA forall a b. (a -> b) -> a -> b
$ HsRecField { hsRecFieldAnn :: XHsRecField t
hsRecFieldAnn = forall a. EpAnn a
noAnn
                                      , hsRecFieldLbl :: Located t
hsRecFieldLbl = forall a e. LocatedAn a e -> Located e
reLoc forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RdrName -> t
f LocatedA RdrName
v'
                                      , hsRecFieldArg :: GenLocated SrcSpanAnnA (HsExpr GhcPs)
hsRecFieldArg = GenLocated SrcSpanAnnA (HsExpr GhcPs)
e'
                                      , hsRecPun :: Bool
hsRecPun      = 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 (HsExpr GhcPs)
cvt_tup [Maybe Exp]
es Boxity
boxity = do { let cvtl_maybe :: Maybe Exp -> CvtM (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 (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@, and @UInfixT@ 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@.

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 (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 (HsExpr GhcPs)
cvtOpApp LHsExpr GhcPs
x Exp
op1 Exp
y
       ; LHsExpr GhcPs -> Exp -> Exp -> CvtM (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 :: HsStmtContext GhcRn -> [TH.Stmt] -> CvtM (HsExpr GhcPs)
cvtHsDo :: HsStmtContext GhcRn -> [Stmt] -> CvtM (HsExpr GhcPs)
cvtHsDo HsStmtContext GhcRn
do_or_lc [Stmt]
stmts
  | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Stmt]
stmts = forall a. SDoc -> CvtM a
failWith (String -> SDoc
text String
"Empty stmt list in do-block")
  | Bool
otherwise
  = do  { [GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
stmts' <- [Stmt] -> CvtM [LStmt GhcPs (LHsExpr GhcPs)]
cvtStmts [Stmt]
stmts
        ; let Just ([GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
stmts'', GenLocated
  SrcSpanAnnA
  (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
last') = forall a. [a] -> Maybe ([a], a)
snocView [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. SDoc -> CvtM a
failWith (GenLocated
  SrcSpanAnnA
  (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> SDoc
bad_last GenLocated
  SrcSpanAnnA
  (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
last')

        ; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p.
XDo p
-> HsStmtContext (HsDoRn p) -> XRec p [ExprLStmt p] -> HsExpr p
HsDo forall a. EpAnn a
noAnn HsStmtContext GhcRn
do_or_lc (forall a an. a -> LocatedAn an a
noLocA ([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)))
-> SDoc
bad_last GenLocated
  SrcSpanAnnA
  (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
stmt = [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Illegal last statement of" SDoc -> SDoc -> SDoc
<+> forall p. (Outputable (IdP p), UnXRec p) => HsStmtContext p -> SDoc
pprAStmtContext HsStmtContext GhcRn
do_or_lc SDoc -> SDoc -> SDoc
<> SDoc
colon
                         , Int -> SDoc -> SDoc
nest Int
2 forall a b. (a -> b) -> a -> b
$ forall a. Outputable a => a -> SDoc
Outputable.ppr GenLocated
  SrcSpanAnnA
  (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
stmt
                         , String -> SDoc
text String
"(It should be an expression.)" ]

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 (GenLocated (SrcSpanAnn' (EpAnn 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 (GenLocated (SrcSpanAnn' (EpAnn 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' <- SDoc -> [Dec] -> CvtM (HsLocalBinds GhcPs)
cvtLocalDecs (String -> SDoc
text String
"a let binding") [Dec]
ds
                            ; forall e ann. e -> CvtM (GenLocated (SrcSpanAnn' (EpAnn 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 (ParStmtBlock GhcPs idR)
cvt_one [[Stmt]]
dss
                            ; forall e ann. e -> CvtM (GenLocated (SrcSpanAnn' (EpAnn 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 (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; forall e ann. e -> CvtM (GenLocated (SrcSpanAnn' (EpAnn ann)) e)
returnLA (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 (forall a an. a -> LocatedAn an a
noLocA [GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
ss')) }

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 p. XParPat p -> LPat p -> Pat p
ParPat forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (Pat GhcPs)
p') -- #14875
                     GenLocated SrcSpanAnnA (Pat GhcPs)
_                -> GenLocated SrcSpanAnnA (Pat GhcPs)
p'
        ; [GenLocated
   SrcSpan (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
g' <- Body -> CvtM [LGRHS GhcPs (LHsExpr GhcPs)]
cvtGuard Body
body
        ; HsLocalBinds GhcPs
decs' <- SDoc -> [Dec] -> CvtM (HsLocalBinds GhcPs)
cvtLocalDecs (String -> SDoc
text String
"a where clause") [Dec]
decs
        ; forall e ann. e -> CvtM (GenLocated (SrcSpanAnn' (EpAnn ann)) e)
returnLA forall a b. (a -> b) -> a -> b
$ forall p body.
XCMatch p body
-> HsMatchContext (NoGhcTc 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
   SrcSpan (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
  SrcSpan (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
g' <- forall a. a -> CvtM (Located a)
returnL 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
  SrcSpan (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 (GenLocated (SrcSpanAnn' (EpAnn 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 a. a -> CvtM (Located a)
returnL 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 a. a -> CvtM (Located a)
returnL 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. 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. 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 ::