{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ConstrainedClassMethods #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
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
convertToHsDecls :: Origin -> SrcSpan -> [TH.Dec] -> Either SDoc [LHsDecl GhcPs]
convertToHsDecls :: Origin
-> SrcSpan -> [Dec] -> Either SDoc [LHsDecl (GhcPass 'Parsed)]
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 (GhcPass 'Parsed))))
cvt_dec [Dec]
ds))
where
cvt_dec :: Dec
-> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl (GhcPass 'Parsed))))
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 (GhcPass 'Parsed)))
cvtDec Dec
d)
convertToHsExpr :: Origin -> SrcSpan -> TH.Exp -> Either SDoc (LHsExpr GhcPs)
convertToHsExpr :: Origin -> SrcSpan -> Exp -> Either SDoc (LHsExpr (GhcPass 'Parsed))
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 (GhcPass 'Parsed))
cvtl Exp
e
convertToPat :: Origin -> SrcSpan -> TH.Pat -> Either SDoc (LPat GhcPs)
convertToPat :: Origin -> SrcSpan -> Pat -> Either SDoc (LPat (GhcPass 'Parsed))
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 (GhcPass 'Parsed))
cvtPat Pat
p
convertToHsType :: Origin -> SrcSpan -> TH.Type -> Either SDoc (LHsType GhcPs)
convertToHsType :: Origin
-> SrcSpan -> Type -> Either SDoc (LHsType (GhcPass 'Parsed))
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 (GhcPass 'Parsed))
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)
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, ()))
returnLA :: e -> CvtM (LocatedAn ann e)
returnLA :: forall e ann. e -> CvtM (LocatedAn 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 (LocatedAn ann e)
returnLA
wrapParLA :: (LocatedAn ann a -> b) -> a -> CvtM b
wrapParLA :: forall ann a b. (LocatedAn ann a -> b) -> a -> CvtM b
wrapParLA LocatedAn ann a -> b
add_par a
x = forall a. (Origin -> SrcSpan -> Either SDoc (SrcSpan, a)) -> CvtM a
CvtM (\Origin
_ SrcSpan
loc -> forall a b. b -> Either a b
Right (SrcSpan
loc, LocatedAn ann a -> b
add_par (forall l e. l -> e -> GenLocated l e
L (forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) a
x)))
wrapMsg :: (Show a, TH.Ppr a) => String -> a -> CvtM b -> CvtM b
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
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 (GhcPass 'Parsed)]
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 (GhcPass 'Parsed)))
cvtDec
cvtDec :: TH.Dec -> CvtM (Maybe (LHsDecl GhcPs))
cvtDec :: Dec -> CvtM (Maybe (LHsDecl (GhcPass 'Parsed)))
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 (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))
cl' <- HsMatchContext (GhcPass 'Parsed)
-> Clause
-> CvtM (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
cvtClause (forall p. LIdP (NoGhcTc p) -> HsMatchContext p
mkPrefixFunRhs LocatedN RdrName
s') ([Pat] -> Body -> [Dec] -> Clause
Clause [] Body
body [Dec]
ds)
; Origin
th_origin <- CvtM Origin
getOrigin
; forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA forall a b. (a -> b) -> a -> b
$ forall p. XValD p -> HsBind p -> HsDecl p
Hs.ValD NoExtField
noExtField forall a b. (a -> b) -> a -> b
$ Origin
-> LocatedN RdrName
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> HsBind (GhcPass 'Parsed)
mkFunBind Origin
th_origin LocatedN RdrName
s' [GenLocated
SrcSpanAnnA
(Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))
cl'] }
| Bool
otherwise
= do { GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
pat' <- Pat -> CvtM (LPat (GhcPass 'Parsed))
cvtPat Pat
pat
; [GenLocated
(SrcAnn NoEpAnns)
(GRHS (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
body' <- Body -> CvtM [LGRHS (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
cvtGuard Body
body
; HsLocalBinds (GhcPass 'Parsed)
ds' <- SDoc -> [Dec] -> CvtM (HsLocalBinds (GhcPass 'Parsed))
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 (GhcPass 'Parsed)
pat_lhs = GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
pat'
, pat_rhs :: GRHSs (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
pat_rhs = forall p body.
XCGRHSs p body -> [LGRHS p body] -> HsLocalBinds p -> GRHSs p body
GRHSs EpAnnComments
emptyComments [GenLocated
(SrcAnn NoEpAnns)
(GRHS (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
body' HsLocalBinds (GhcPass 'Parsed)
ds'
, pat_ext :: XPatBind (GhcPass 'Parsed) (GhcPass 'Parsed)
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 (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
cls' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (HsMatchContext (GhcPass 'Parsed)
-> Clause
-> CvtM (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
cvtClause (forall p. LIdP (NoGhcTc p) -> HsMatchContext p
mkPrefixFunRhs LocatedN RdrName
nm')) [Clause]
cls
; Origin
th_origin <- CvtM Origin
getOrigin
; forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA forall a b. (a -> b) -> a -> b
$ forall p. XValD p -> HsBind p -> HsDecl p
Hs.ValD NoExtField
noExtField forall a b. (a -> b) -> a -> b
$ Origin
-> LocatedN RdrName
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> HsBind (GhcPass 'Parsed)
mkFunBind Origin
th_origin LocatedN RdrName
nm' [GenLocated
SrcSpanAnnA
(Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
cls' }
cvtDec (TH.SigD Name
nm Type
typ)
= do { LocatedN RdrName
nm' <- Name -> CvtM (LocatedN RdrName)
vNameN Name
nm
; GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Parsed))
ty' <- Type -> CvtM (LHsSigType (GhcPass 'Parsed))
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 (GhcPass 'Parsed) thing
mkHsWildCardBndrs GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Parsed))
ty')) }
cvtDec (TH.KiSigD Name
nm Type
ki)
= do { LocatedN RdrName
nm' <- Name -> CvtM (LocatedN RdrName)
tconNameN Name
nm
; GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Parsed))
ki' <- Type -> CvtM (LHsSigType (GhcPass 'Parsed))
cvtSigKind Type
ki
; let sig' :: StandaloneKindSig (GhcPass 'Parsed)
sig' = forall pass.
XStandaloneKindSig pass
-> LIdP pass -> LHsSigType pass -> StandaloneKindSig pass
StandaloneKindSig forall a. EpAnn a
noAnn LocatedN RdrName
nm' GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Parsed))
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 (GhcPass 'Parsed)
sig' }
cvtDec (TH.InfixD Fixity
fx Name
nm)
= do { LocatedN RdrName
nm' <- Name -> CvtM (LocatedN RdrName)
vcNameN Name
nm
; forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA (forall p. XSigD p -> Sig p -> HsDecl p
Hs.SigD NoExtField
noExtField (forall pass. XFixSig pass -> FixitySig pass -> Sig pass
FixSig forall a. EpAnn a
noAnn
(forall pass.
XFixitySig pass -> [LIdP pass] -> Fixity -> FixitySig pass
FixitySig NoExtField
noExtField [LocatedN RdrName
nm'] (Fixity -> Fixity
cvtFixity Fixity
fx)))) }
cvtDec (TH.DefaultD [Type]
tys)
= do { [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
tys' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Type -> CvtM (LHsType (GhcPass 'Parsed))
cvtType [Type]
tys
; forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA (forall p. XDefD p -> DefaultDecl p -> HsDecl p
Hs.DefD NoExtField
noExtField forall a b. (a -> b) -> a -> b
$ forall pass.
XCDefaultDecl pass -> [LHsType pass] -> DefaultDecl pass
DefaultDecl forall a. EpAnn a
noAnn [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
tys') }
cvtDec (PragmaD Pragma
prag)
= Pragma -> CvtM (Maybe (LHsDecl (GhcPass 'Parsed)))
cvtPragmaD Pragma
prag
cvtDec (TySynD Name
tc [TyVarBndr ()]
tvs Type
rhs)
= do { (GenLocated
SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
_, LocatedN RdrName
tc', LHsQTyVars (GhcPass 'Parsed)
tvs') <- [Type]
-> Name
-> [TyVarBndr ()]
-> CvtM
(LHsContext (GhcPass 'Parsed), LocatedN RdrName,
LHsQTyVars (GhcPass 'Parsed))
cvt_tycl_hdr [] Name
tc [TyVarBndr ()]
tvs
; GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
rhs' <- Type -> CvtM (LHsType (GhcPass 'Parsed))
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 (GhcPass 'Parsed)
tcdSExt = forall a. EpAnn a
noAnn, tcdLName :: XRec (GhcPass 'Parsed) (IdP (GhcPass 'Parsed))
tcdLName = LocatedN RdrName
tc', tcdTyVars :: LHsQTyVars (GhcPass 'Parsed)
tcdTyVars = LHsQTyVars (GhcPass 'Parsed)
tvs'
, tcdFixity :: LexicalFixity
tcdFixity = LexicalFixity
Prefix
, tcdRhs :: LHsType (GhcPass 'Parsed)
tcdRhs = GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
rhs' } }
cvtDec (DataD [Type]
ctxt Name
tc [TyVarBndr ()]
tvs Maybe Type
ksig [Con]
constrs [DerivClause]
derivs)
= do { let isGadtCon :: Con -> Bool
isGadtCon (GadtC [Name]
_ [BangType]
_ Type
_) = Bool
True
isGadtCon (RecGadtC [Name]
_ [VarBangType]
_ Type
_) = Bool
True
isGadtCon (ForallC [TyVarBndr Specificity]
_ [Type]
_ Con
c) = Con -> Bool
isGadtCon Con
c
isGadtCon Con
_ = Bool
False
isGadtDecl :: Bool
isGadtDecl = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Con -> Bool
isGadtCon [Con]
constrs
isH98Decl :: Bool
isH98Decl = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Con -> Bool
isGadtCon) [Con]
constrs
; 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 (GhcPass 'Parsed))]
ctxt', LocatedN RdrName
tc', LHsQTyVars (GhcPass 'Parsed)
tvs') <- [Type]
-> Name
-> [TyVarBndr ()]
-> CvtM
(LHsContext (GhcPass 'Parsed), LocatedN RdrName,
LHsQTyVars (GhcPass 'Parsed))
cvt_tycl_hdr [Type]
ctxt Name
tc [TyVarBndr ()]
tvs
; Maybe (GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
ksig' <- Type -> CvtM (LHsType (GhcPass 'Parsed))
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 (GhcPass 'Parsed))]
cons' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Con -> CvtM (LConDecl (GhcPass 'Parsed))
cvtConstr [Con]
constrs
; [GenLocated (SrcAnn NoEpAnns) (HsDerivingClause (GhcPass 'Parsed))]
derivs' <- [DerivClause] -> CvtM (HsDeriving (GhcPass 'Parsed))
cvtDerivs [DerivClause]
derivs
; let defn :: HsDataDefn (GhcPass 'Parsed)
defn = HsDataDefn { dd_ext :: XCHsDataDefn (GhcPass 'Parsed)
dd_ext = NoExtField
noExtField
, dd_ND :: NewOrData
dd_ND = NewOrData
DataType, dd_cType :: Maybe (XRec (GhcPass 'Parsed) CType)
dd_cType = forall a. Maybe a
Nothing
, dd_ctxt :: Maybe (LHsContext (GhcPass 'Parsed))
dd_ctxt = LHsContext (GhcPass 'Parsed)
-> Maybe (LHsContext (GhcPass 'Parsed))
mkHsContextMaybe GenLocated
SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
ctxt'
, dd_kindSig :: Maybe (LHsType (GhcPass 'Parsed))
dd_kindSig = Maybe (GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
ksig'
, dd_cons :: [LConDecl (GhcPass 'Parsed)]
dd_cons = [GenLocated SrcSpanAnnA (ConDecl (GhcPass 'Parsed))]
cons', dd_derivs :: HsDeriving (GhcPass 'Parsed)
dd_derivs = [GenLocated (SrcAnn NoEpAnns) (HsDerivingClause (GhcPass 'Parsed))]
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 (GhcPass 'Parsed)
tcdDExt = forall a. EpAnn a
noAnn
, tcdLName :: XRec (GhcPass 'Parsed) (IdP (GhcPass 'Parsed))
tcdLName = LocatedN RdrName
tc', tcdTyVars :: LHsQTyVars (GhcPass 'Parsed)
tcdTyVars = LHsQTyVars (GhcPass 'Parsed)
tvs'
, tcdFixity :: LexicalFixity
tcdFixity = LexicalFixity
Prefix
, tcdDataDefn :: HsDataDefn (GhcPass 'Parsed)
tcdDataDefn = HsDataDefn (GhcPass 'Parsed)
defn } }
cvtDec (NewtypeD [Type]
ctxt Name
tc [TyVarBndr ()]
tvs Maybe Type
ksig Con
constr [DerivClause]
derivs)
= do { (GenLocated
SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
ctxt', LocatedN RdrName
tc', LHsQTyVars (GhcPass 'Parsed)
tvs') <- [Type]
-> Name
-> [TyVarBndr ()]
-> CvtM
(LHsContext (GhcPass 'Parsed), LocatedN RdrName,
LHsQTyVars (GhcPass 'Parsed))
cvt_tycl_hdr [Type]
ctxt Name
tc [TyVarBndr ()]
tvs
; Maybe (GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
ksig' <- Type -> CvtM (LHsType (GhcPass 'Parsed))
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 (GhcPass 'Parsed))
con' <- Con -> CvtM (LConDecl (GhcPass 'Parsed))
cvtConstr Con
constr
; [GenLocated (SrcAnn NoEpAnns) (HsDerivingClause (GhcPass 'Parsed))]
derivs' <- [DerivClause] -> CvtM (HsDeriving (GhcPass 'Parsed))
cvtDerivs [DerivClause]
derivs
; let defn :: HsDataDefn (GhcPass 'Parsed)
defn = HsDataDefn { dd_ext :: XCHsDataDefn (GhcPass 'Parsed)
dd_ext = NoExtField
noExtField
, dd_ND :: NewOrData
dd_ND = NewOrData
NewType, dd_cType :: Maybe (XRec (GhcPass 'Parsed) CType)
dd_cType = forall a. Maybe a
Nothing
, dd_ctxt :: Maybe (LHsContext (GhcPass 'Parsed))
dd_ctxt = LHsContext (GhcPass 'Parsed)
-> Maybe (LHsContext (GhcPass 'Parsed))
mkHsContextMaybe GenLocated
SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
ctxt'
, dd_kindSig :: Maybe (LHsType (GhcPass 'Parsed))
dd_kindSig = Maybe (GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
ksig'
, dd_cons :: [LConDecl (GhcPass 'Parsed)]
dd_cons = [GenLocated SrcSpanAnnA (ConDecl (GhcPass 'Parsed))
con']
, dd_derivs :: HsDeriving (GhcPass 'Parsed)
dd_derivs = [GenLocated (SrcAnn NoEpAnns) (HsDerivingClause (GhcPass 'Parsed))]
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 (GhcPass 'Parsed)
tcdDExt = forall a. EpAnn a
noAnn
, tcdLName :: XRec (GhcPass 'Parsed) (IdP (GhcPass 'Parsed))
tcdLName = LocatedN RdrName
tc', tcdTyVars :: LHsQTyVars (GhcPass 'Parsed)
tcdTyVars = LHsQTyVars (GhcPass 'Parsed)
tvs'
, tcdFixity :: LexicalFixity
tcdFixity = LexicalFixity
Prefix
, tcdDataDefn :: HsDataDefn (GhcPass 'Parsed)
tcdDataDefn = HsDataDefn (GhcPass 'Parsed)
defn } }
cvtDec (ClassD [Type]
ctxt Name
cl [TyVarBndr ()]
tvs [FunDep]
fds [Dec]
decs)
= do { (GenLocated
SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
cxt', LocatedN RdrName
tc', LHsQTyVars (GhcPass 'Parsed)
tvs') <- [Type]
-> Name
-> [TyVarBndr ()]
-> CvtM
(LHsContext (GhcPass 'Parsed), LocatedN RdrName,
LHsQTyVars (GhcPass 'Parsed))
cvt_tycl_hdr [Type]
ctxt Name
cl [TyVarBndr ()]
tvs
; [GenLocated SrcSpanAnnA (FunDep (GhcPass 'Parsed))]
fds' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FunDep -> CvtM (LHsFunDep (GhcPass 'Parsed))
cvt_fundep [FunDep]
fds
; (Bag (GenLocated SrcSpanAnnA (HsBind (GhcPass 'Parsed)))
binds', [GenLocated SrcSpanAnnA (Sig (GhcPass 'Parsed))]
sigs', [GenLocated SrcSpanAnnA (FamilyDecl (GhcPass 'Parsed))]
fams', [GenLocated SrcSpanAnnA (TyFamInstDecl (GhcPass 'Parsed))]
at_defs', [GenLocated SrcSpanAnnA (DataFamInstDecl (GhcPass 'Parsed))]
adts') <- SDoc
-> [Dec]
-> CvtM
(LHsBinds (GhcPass 'Parsed), [LSig (GhcPass 'Parsed)],
[LFamilyDecl (GhcPass 'Parsed)],
[LTyFamInstDecl (GhcPass 'Parsed)],
[LDataFamInstDecl (GhcPass 'Parsed)])
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 (GhcPass 'Parsed))]
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 (GhcPass 'Parsed))]
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 (GhcPass 'Parsed)
tcdCExt = (forall a. EpAnn a
noAnn, AnnSortKey
NoAnnSortKey, LayoutInfo
NoLayoutInfo)
, tcdCtxt :: Maybe (LHsContext (GhcPass 'Parsed))
tcdCtxt = LHsContext (GhcPass 'Parsed)
-> Maybe (LHsContext (GhcPass 'Parsed))
mkHsContextMaybe GenLocated
SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
cxt', tcdLName :: XRec (GhcPass 'Parsed) (IdP (GhcPass 'Parsed))
tcdLName = LocatedN RdrName
tc', tcdTyVars :: LHsQTyVars (GhcPass 'Parsed)
tcdTyVars = LHsQTyVars (GhcPass 'Parsed)
tvs'
, tcdFixity :: LexicalFixity
tcdFixity = LexicalFixity
Prefix
, tcdFDs :: [LHsFunDep (GhcPass 'Parsed)]
tcdFDs = [GenLocated SrcSpanAnnA (FunDep (GhcPass 'Parsed))]
fds', tcdSigs :: [LSig (GhcPass 'Parsed)]
tcdSigs = [LSig (GhcPass 'Parsed)] -> [LSig (GhcPass 'Parsed)]
Hs.mkClassOpSigs [GenLocated SrcSpanAnnA (Sig (GhcPass 'Parsed))]
sigs'
, tcdMeths :: LHsBinds (GhcPass 'Parsed)
tcdMeths = Bag (GenLocated SrcSpanAnnA (HsBind (GhcPass 'Parsed)))
binds'
, tcdATs :: [LFamilyDecl (GhcPass 'Parsed)]
tcdATs = [GenLocated SrcSpanAnnA (FamilyDecl (GhcPass 'Parsed))]
fams', tcdATDefs :: [LTyFamInstDecl (GhcPass 'Parsed)]
tcdATDefs = [GenLocated SrcSpanAnnA (TyFamInstDecl (GhcPass 'Parsed))]
at_defs', tcdDocs :: [LDocDecl (GhcPass 'Parsed)]
tcdDocs = [] }
}
cvtDec (InstanceD Maybe Overlap
o [Type]
ctxt Type
ty [Dec]
decs)
= do { let doc :: SDoc
doc = String -> SDoc
text String
"an instance declaration"
; (Bag (GenLocated SrcSpanAnnA (HsBind (GhcPass 'Parsed)))
binds', [GenLocated SrcSpanAnnA (Sig (GhcPass 'Parsed))]
sigs', [GenLocated SrcSpanAnnA (FamilyDecl (GhcPass 'Parsed))]
fams', [GenLocated SrcSpanAnnA (TyFamInstDecl (GhcPass 'Parsed))]
ats', [GenLocated SrcSpanAnnA (DataFamInstDecl (GhcPass 'Parsed))]
adts') <- SDoc
-> [Dec]
-> CvtM
(LHsBinds (GhcPass 'Parsed), [LSig (GhcPass 'Parsed)],
[LFamilyDecl (GhcPass 'Parsed)],
[LTyFamInstDecl (GhcPass 'Parsed)],
[LDataFamInstDecl (GhcPass 'Parsed)])
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 (GhcPass 'Parsed))]
fams') (forall a. SDoc -> CvtM a
failWith (forall a. Outputable a => SDoc -> [a] -> SDoc
mkBadDecMsg SDoc
doc [GenLocated SrcSpanAnnA (FamilyDecl (GhcPass 'Parsed))]
fams'))
; GenLocated
SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
ctxt' <- PprPrec -> [Type] -> CvtM (LHsContext (GhcPass 'Parsed))
cvtContext PprPrec
funPrec [Type]
ctxt
; (L SrcSpanAnnA
loc HsType (GhcPass 'Parsed)
ty') <- Type -> CvtM (LHsType (GhcPass 'Parsed))
cvtType Type
ty
; let inst_ty' :: GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Parsed))
inst_ty' = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc forall a b. (a -> b) -> a -> b
$ LHsType (GhcPass 'Parsed) -> HsSigType (GhcPass 'Parsed)
mkHsImplicitSigType forall a b. (a -> b) -> a -> b
$
[Type]
-> SrcSpanAnnA
-> LHsContext (GhcPass 'Parsed)
-> LHsType (GhcPass 'Parsed)
-> LHsType (GhcPass 'Parsed)
mkHsQualTy [Type]
ctxt SrcSpanAnnA
loc GenLocated
SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
ctxt' forall a b. (a -> b) -> a -> b
$ forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc HsType (GhcPass 'Parsed)
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 (GhcPass 'Parsed)
cid_ext = (forall a. EpAnn a
noAnn, AnnSortKey
NoAnnSortKey), cid_poly_ty :: LHsSigType (GhcPass 'Parsed)
cid_poly_ty = GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Parsed))
inst_ty'
, cid_binds :: LHsBinds (GhcPass 'Parsed)
cid_binds = Bag (GenLocated SrcSpanAnnA (HsBind (GhcPass 'Parsed)))
binds'
, cid_sigs :: [LSig (GhcPass 'Parsed)]
cid_sigs = [LSig (GhcPass 'Parsed)] -> [LSig (GhcPass 'Parsed)]
Hs.mkClassOpSigs [GenLocated SrcSpanAnnA (Sig (GhcPass 'Parsed))]
sigs'
, cid_tyfam_insts :: [LTyFamInstDecl (GhcPass 'Parsed)]
cid_tyfam_insts = [GenLocated SrcSpanAnnA (TyFamInstDecl (GhcPass 'Parsed))]
ats', cid_datafam_insts :: [LDataFamInstDecl (GhcPass 'Parsed)]
cid_datafam_insts = [GenLocated SrcSpanAnnA (DataFamInstDecl (GhcPass 'Parsed))]
adts'
, cid_overlap_mode :: Maybe (XRec (GhcPass 'Parsed) 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 (GhcPass 'Parsed)
ford' <- Foreign -> CvtM (ForeignDecl (GhcPass 'Parsed))
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 (GhcPass 'Parsed)
ford' }
cvtDec (DataFamilyD Name
tc [TyVarBndr ()]
tvs Maybe Type
kind)
= do { (GenLocated
SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
_, LocatedN RdrName
tc', LHsQTyVars (GhcPass 'Parsed)
tvs') <- [Type]
-> Name
-> [TyVarBndr ()]
-> CvtM
(LHsContext (GhcPass 'Parsed), LocatedN RdrName,
LHsQTyVars (GhcPass 'Parsed))
cvt_tycl_hdr [] Name
tc [TyVarBndr ()]
tvs
; GenLocated (SrcAnn NoEpAnns) (FamilyResultSig (GhcPass 'Parsed))
result <- Maybe Type -> CvtM (LFamilyResultSig (GhcPass 'Parsed))
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 (GhcPass 'Parsed)
tvs' LexicalFixity
Prefix GenLocated (SrcAnn NoEpAnns) (FamilyResultSig (GhcPass 'Parsed))
result forall a. Maybe a
Nothing }
cvtDec (DataInstD [Type]
ctxt Maybe [TyVarBndr ()]
bndrs Type
tys Maybe Type
ksig [Con]
constrs [DerivClause]
derivs)
= do { (GenLocated
SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
ctxt', LocatedN RdrName
tc', HsOuterFamEqnTyVarBndrs (GhcPass 'Parsed)
bndrs', [HsArg
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))]
typats') <- [Type]
-> Maybe [TyVarBndr ()]
-> Type
-> CvtM
(LHsContext (GhcPass 'Parsed), LocatedN RdrName,
HsOuterFamEqnTyVarBndrs (GhcPass 'Parsed),
HsTyPats (GhcPass 'Parsed))
cvt_datainst_hdr [Type]
ctxt Maybe [TyVarBndr ()]
bndrs Type
tys
; Maybe (GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
ksig' <- Type -> CvtM (LHsType (GhcPass 'Parsed))
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 (GhcPass 'Parsed))]
cons' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Con -> CvtM (LConDecl (GhcPass 'Parsed))
cvtConstr [Con]
constrs
; [GenLocated (SrcAnn NoEpAnns) (HsDerivingClause (GhcPass 'Parsed))]
derivs' <- [DerivClause] -> CvtM (HsDeriving (GhcPass 'Parsed))
cvtDerivs [DerivClause]
derivs
; let defn :: HsDataDefn (GhcPass 'Parsed)
defn = HsDataDefn { dd_ext :: XCHsDataDefn (GhcPass 'Parsed)
dd_ext = NoExtField
noExtField
, dd_ND :: NewOrData
dd_ND = NewOrData
DataType, dd_cType :: Maybe (XRec (GhcPass 'Parsed) CType)
dd_cType = forall a. Maybe a
Nothing
, dd_ctxt :: Maybe (LHsContext (GhcPass 'Parsed))
dd_ctxt = LHsContext (GhcPass 'Parsed)
-> Maybe (LHsContext (GhcPass 'Parsed))
mkHsContextMaybe GenLocated
SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
ctxt'
, dd_kindSig :: Maybe (LHsType (GhcPass 'Parsed))
dd_kindSig = Maybe (GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
ksig'
, dd_cons :: [LConDecl (GhcPass 'Parsed)]
dd_cons = [GenLocated SrcSpanAnnA (ConDecl (GhcPass 'Parsed))]
cons', dd_derivs :: HsDeriving (GhcPass 'Parsed)
dd_derivs = [GenLocated (SrcAnn NoEpAnns) (HsDerivingClause (GhcPass 'Parsed))]
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 (GhcPass 'Parsed)
dfid_ext = NoExtField
noExtField
, dfid_inst :: DataFamInstDecl (GhcPass 'Parsed)
dfid_inst = DataFamInstDecl { dfid_eqn :: FamEqn (GhcPass 'Parsed) (HsDataDefn (GhcPass 'Parsed))
dfid_eqn =
FamEqn { feqn_ext :: XCFamEqn (GhcPass 'Parsed) (HsDataDefn (GhcPass 'Parsed))
feqn_ext = forall a. EpAnn a
noAnn
, feqn_tycon :: XRec (GhcPass 'Parsed) (IdP (GhcPass 'Parsed))
feqn_tycon = LocatedN RdrName
tc'
, feqn_bndrs :: HsOuterFamEqnTyVarBndrs (GhcPass 'Parsed)
feqn_bndrs = HsOuterFamEqnTyVarBndrs (GhcPass 'Parsed)
bndrs'
, feqn_pats :: HsTyPats (GhcPass 'Parsed)
feqn_pats = [HsArg
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))]
typats'
, feqn_rhs :: HsDataDefn (GhcPass 'Parsed)
feqn_rhs = HsDataDefn (GhcPass 'Parsed)
defn
, feqn_fixity :: LexicalFixity
feqn_fixity = LexicalFixity
Prefix } }}}
cvtDec (NewtypeInstD [Type]
ctxt Maybe [TyVarBndr ()]
bndrs Type
tys Maybe Type
ksig Con
constr [DerivClause]
derivs)
= do { (GenLocated
SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
ctxt', LocatedN RdrName
tc', HsOuterFamEqnTyVarBndrs (GhcPass 'Parsed)
bndrs', [HsArg
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))]
typats') <- [Type]
-> Maybe [TyVarBndr ()]
-> Type
-> CvtM
(LHsContext (GhcPass 'Parsed), LocatedN RdrName,
HsOuterFamEqnTyVarBndrs (GhcPass 'Parsed),
HsTyPats (GhcPass 'Parsed))
cvt_datainst_hdr [Type]
ctxt Maybe [TyVarBndr ()]
bndrs Type
tys
; Maybe (GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
ksig' <- Type -> CvtM (LHsType (GhcPass 'Parsed))
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 (GhcPass 'Parsed))
con' <- Con -> CvtM (LConDecl (GhcPass 'Parsed))
cvtConstr Con
constr
; [GenLocated (SrcAnn NoEpAnns) (HsDerivingClause (GhcPass 'Parsed))]
derivs' <- [DerivClause] -> CvtM (HsDeriving (GhcPass 'Parsed))
cvtDerivs [DerivClause]
derivs
; let defn :: HsDataDefn (GhcPass 'Parsed)
defn = HsDataDefn { dd_ext :: XCHsDataDefn (GhcPass 'Parsed)
dd_ext = NoExtField
noExtField
, dd_ND :: NewOrData
dd_ND = NewOrData
NewType, dd_cType :: Maybe (XRec (GhcPass 'Parsed) CType)
dd_cType = forall a. Maybe a
Nothing
, dd_ctxt :: Maybe (LHsContext (GhcPass 'Parsed))
dd_ctxt = LHsContext (GhcPass 'Parsed)
-> Maybe (LHsContext (GhcPass 'Parsed))
mkHsContextMaybe GenLocated
SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
ctxt'
, dd_kindSig :: Maybe (LHsType (GhcPass 'Parsed))
dd_kindSig = Maybe (GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
ksig'
, dd_cons :: [LConDecl (GhcPass 'Parsed)]
dd_cons = [GenLocated SrcSpanAnnA (ConDecl (GhcPass 'Parsed))
con'], dd_derivs :: HsDeriving (GhcPass 'Parsed)
dd_derivs = [GenLocated (SrcAnn NoEpAnns) (HsDerivingClause (GhcPass 'Parsed))]
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 (GhcPass 'Parsed)
dfid_ext = NoExtField
noExtField
, dfid_inst :: DataFamInstDecl (GhcPass 'Parsed)
dfid_inst = DataFamInstDecl { dfid_eqn :: FamEqn (GhcPass 'Parsed) (HsDataDefn (GhcPass 'Parsed))
dfid_eqn =
FamEqn { feqn_ext :: XCFamEqn (GhcPass 'Parsed) (HsDataDefn (GhcPass 'Parsed))
feqn_ext = forall a. EpAnn a
noAnn
, feqn_tycon :: XRec (GhcPass 'Parsed) (IdP (GhcPass 'Parsed))
feqn_tycon = LocatedN RdrName
tc'
, feqn_bndrs :: HsOuterFamEqnTyVarBndrs (GhcPass 'Parsed)
feqn_bndrs = HsOuterFamEqnTyVarBndrs (GhcPass 'Parsed)
bndrs'
, feqn_pats :: HsTyPats (GhcPass 'Parsed)
feqn_pats = [HsArg
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))]
typats'
, feqn_rhs :: HsDataDefn (GhcPass 'Parsed)
feqn_rhs = HsDataDefn (GhcPass 'Parsed)
defn
, feqn_fixity :: LexicalFixity
feqn_fixity = LexicalFixity
Prefix } }}}
cvtDec (TySynInstD TySynEqn
eqn)
= do { (L SrcSpanAnnA
_ FamEqn
(GhcPass 'Parsed)
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
eqn') <- TySynEqn -> CvtM (LTyFamInstEqn (GhcPass 'Parsed))
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 (GhcPass 'Parsed)
tfid_ext = NoExtField
noExtField
, tfid_inst :: TyFamInstDecl (GhcPass 'Parsed)
tfid_inst = TyFamInstDecl { tfid_xtn :: XCTyFamInstDecl (GhcPass 'Parsed)
tfid_xtn = forall a. EpAnn a
noAnn, tfid_eqn :: TyFamInstEqn (GhcPass 'Parsed)
tfid_eqn = FamEqn
(GhcPass 'Parsed)
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
eqn' } }}
cvtDec (OpenTypeFamilyD TypeFamilyHead
head)
= do { (LocatedN RdrName
tc', LHsQTyVars (GhcPass 'Parsed)
tyvars', GenLocated (SrcAnn NoEpAnns) (FamilyResultSig (GhcPass 'Parsed))
result', Maybe
(GenLocated (SrcAnn NoEpAnns) (InjectivityAnn (GhcPass 'Parsed)))
injectivity') <- TypeFamilyHead
-> CvtM
(LocatedN RdrName, LHsQTyVars (GhcPass 'Parsed),
LFamilyResultSig (GhcPass 'Parsed),
Maybe (LInjectivityAnn (GhcPass 'Parsed)))
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 (GhcPass 'Parsed)
tyvars' LexicalFixity
Prefix GenLocated (SrcAnn NoEpAnns) (FamilyResultSig (GhcPass 'Parsed))
result' Maybe
(GenLocated (SrcAnn NoEpAnns) (InjectivityAnn (GhcPass 'Parsed)))
injectivity'
}
cvtDec (ClosedTypeFamilyD TypeFamilyHead
head [TySynEqn]
eqns)
= do { (LocatedN RdrName
tc', LHsQTyVars (GhcPass 'Parsed)
tyvars', GenLocated (SrcAnn NoEpAnns) (FamilyResultSig (GhcPass 'Parsed))
result', Maybe
(GenLocated (SrcAnn NoEpAnns) (InjectivityAnn (GhcPass 'Parsed)))
injectivity') <- TypeFamilyHead
-> CvtM
(LocatedN RdrName, LHsQTyVars (GhcPass 'Parsed),
LFamilyResultSig (GhcPass 'Parsed),
Maybe (LInjectivityAnn (GhcPass 'Parsed)))
cvt_tyfam_head TypeFamilyHead
head
; [GenLocated
SrcSpanAnnA
(FamEqn
(GhcPass 'Parsed)
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))))]
eqns' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TySynEqn -> CvtM (LTyFamInstEqn (GhcPass 'Parsed))
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
(GhcPass 'Parsed)
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))))]
eqns')) TopLevelFlag
TopLevel LocatedN RdrName
tc' LHsQTyVars (GhcPass 'Parsed)
tyvars' LexicalFixity
Prefix
GenLocated (SrcAnn NoEpAnns) (FamilyResultSig (GhcPass 'Parsed))
result' Maybe
(GenLocated (SrcAnn NoEpAnns) (InjectivityAnn (GhcPass 'Parsed)))
injectivity' }
cvtDec (TH.RoleAnnotD Name
tc [Role]
roles)
= do { LocatedN RdrName
tc' <- Name -> CvtM (LocatedN RdrName)
tconNameN Name
tc
; [LocatedAn NoEpAnns (Maybe Role)]
roles' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall b c a. (b -> c) -> (a -> b) -> a -> c
. Role -> Maybe Role
cvtRole) [Role]
roles
; forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA
forall a b. (a -> b) -> a -> b
$ forall p. XRoleAnnotD p -> RoleAnnotDecl p -> HsDecl p
Hs.RoleAnnotD NoExtField
noExtField (forall pass.
XCRoleAnnotDecl pass
-> LIdP pass -> [XRec pass (Maybe Role)] -> RoleAnnotDecl pass
RoleAnnotDecl forall a. EpAnn a
noAnn LocatedN RdrName
tc' [LocatedAn NoEpAnns (Maybe Role)]
roles') }
cvtDec (TH.StandaloneDerivD Maybe DerivStrategy
ds [Type]
cxt Type
ty)
= do { GenLocated
SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
cxt' <- PprPrec -> [Type] -> CvtM (LHsContext (GhcPass 'Parsed))
cvtContext PprPrec
funPrec [Type]
cxt
; Maybe
(GenLocated (SrcAnn NoEpAnns) (DerivStrategy (GhcPass 'Parsed)))
ds' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse DerivStrategy -> CvtM (LDerivStrategy (GhcPass 'Parsed))
cvtDerivStrategy Maybe DerivStrategy
ds
; (L SrcSpanAnnA
loc HsType (GhcPass 'Parsed)
ty') <- Type -> CvtM (LHsType (GhcPass 'Parsed))
cvtType Type
ty
; let inst_ty' :: GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Parsed))
inst_ty' = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc forall a b. (a -> b) -> a -> b
$ LHsType (GhcPass 'Parsed) -> HsSigType (GhcPass 'Parsed)
mkHsImplicitSigType forall a b. (a -> b) -> a -> b
$
[Type]
-> SrcSpanAnnA
-> LHsContext (GhcPass 'Parsed)
-> LHsType (GhcPass 'Parsed)
-> LHsType (GhcPass 'Parsed)
mkHsQualTy [Type]
cxt SrcSpanAnnA
loc GenLocated
SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
cxt' forall a b. (a -> b) -> a -> b
$ forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc HsType (GhcPass 'Parsed)
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 (GhcPass 'Parsed)
deriv_ext = forall a. EpAnn a
noAnn
, deriv_strategy :: Maybe (LDerivStrategy (GhcPass 'Parsed))
deriv_strategy = Maybe
(GenLocated (SrcAnn NoEpAnns) (DerivStrategy (GhcPass 'Parsed)))
ds'
, deriv_type :: LHsSigWcType (GhcPass 'Parsed)
deriv_type = forall thing. thing -> HsWildCardBndrs (GhcPass 'Parsed) thing
mkHsWildCardBndrs GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Parsed))
inst_ty'
, deriv_overlap_mode :: Maybe (XRec (GhcPass 'Parsed) 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 (GhcPass 'Parsed))
ty' <- Type -> CvtM (LHsSigType (GhcPass 'Parsed))
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 (GhcPass 'Parsed))
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 (GhcPass 'Parsed)]
args' <- forall {pass}.
(XCFieldOcc pass ~ NoExtField,
XRec pass (IdP pass) ~ LocatedN RdrName,
XRec pass RdrName ~ LocatedN RdrName) =>
PatSynArgs
-> CvtM
(HsConDetails Void (LocatedN RdrName) [RecordPatSynField pass])
cvtArgs PatSynArgs
args
; HsPatSynDir (GhcPass 'Parsed)
dir' <- LocatedN RdrName
-> PatSynDir -> CvtM (HsPatSynDir (GhcPass 'Parsed))
cvtDir LocatedN RdrName
nm' PatSynDir
dir
; GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
pat' <- Pat -> CvtM (LPat (GhcPass 'Parsed))
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 (GhcPass 'Parsed)]
args' GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
pat' HsPatSynDir (GhcPass 'Parsed)
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 -> XRec pass RdrName -> FieldOcc pass
FieldOcc NoExtField
noExtField (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
li RdrName
i)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> CvtM (LocatedN RdrName)
vNameN) [Name]
sels
; [LocatedN RdrName]
vars' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Name -> CvtM (LocatedN RdrName)
vNameN forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkNameS forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase) [Name]
sels
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall tyarg arg rec. rec -> HsConDetails tyarg arg rec
Hs.RecCon forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall pass. FieldOcc pass -> LIdP pass -> RecordPatSynField pass
RecordPatSynField [FieldOcc pass]
sels' [LocatedN RdrName]
vars' }
cvtDir :: LocatedN RdrName
-> PatSynDir -> CvtM (HsPatSynDir (GhcPass 'Parsed))
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 (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
ms <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (HsMatchContext (GhcPass 'Parsed)
-> Clause
-> CvtM (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
cvtClause (forall p. LIdP (NoGhcTc p) -> HsMatchContext p
mkPrefixFunRhs LocatedN RdrName
n)) [Clause]
cls
; Origin
th_origin <- CvtM Origin
getOrigin
; forall ann a b. (LocatedAn ann a -> b) -> a -> CvtM b
wrapParLA (forall id. MatchGroup id (LHsExpr id) -> HsPatSynDir id
ExplicitBidirectional forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: Pass) (body :: * -> *).
AnnoBody p body =>
Origin
-> LocatedL
[LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]
-> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))
mkMatchGroup Origin
th_origin) [GenLocated
SrcSpanAnnA
(Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
ms }
cvtDec (TH.PatSynSigD Name
nm Type
ty)
= do { LocatedN RdrName
nm' <- Name -> CvtM (LocatedN RdrName)
cNameN Name
nm
; GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Parsed))
ty' <- Type -> CvtM (LHsSigType (GhcPass 'Parsed))
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 (GhcPass 'Parsed))
ty'}
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 (GhcPass 'Parsed))
cvtTySynEqn (TySynEqn Maybe [TyVarBndr ()]
mb_bndrs Type
lhs Type
rhs)
= do { Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr () (GhcPass 'Parsed))]
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' (GhcPass 'Parsed))
cvt_tv) Maybe [TyVarBndr ()]
mb_bndrs
; let outer_bndrs :: HsOuterFamEqnTyVarBndrs (GhcPass 'Parsed)
outer_bndrs = Maybe [LHsTyVarBndr () (GhcPass 'Parsed)]
-> HsOuterFamEqnTyVarBndrs (GhcPass 'Parsed)
mkHsOuterFamEqnTyVarBndrs Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr () (GhcPass 'Parsed))]
mb_bndrs'
; (Type
head_ty, [HsArg
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))]
args) <- Type -> CvtM (Type, HsTyPats (GhcPass 'Parsed))
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 (GhcPass 'Parsed))
rhs' <- Type -> CvtM (LHsType (GhcPass 'Parsed))
cvtType Type
rhs
; let args' :: [HsArg
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))]
args' = forall a b. (a -> b) -> [a] -> [b]
map LHsTypeArg (GhcPass 'Parsed) -> LHsTypeArg (GhcPass 'Parsed)
wrap_tyarg [HsArg
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))]
args
; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA
forall a b. (a -> b) -> a -> b
$ FamEqn { feqn_ext :: XCFamEqn
(GhcPass 'Parsed)
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
feqn_ext = forall a. EpAnn a
noAnn
, feqn_tycon :: XRec (GhcPass 'Parsed) (IdP (GhcPass 'Parsed))
feqn_tycon = LocatedN RdrName
nm'
, feqn_bndrs :: HsOuterFamEqnTyVarBndrs (GhcPass 'Parsed)
feqn_bndrs = HsOuterFamEqnTyVarBndrs (GhcPass 'Parsed)
outer_bndrs
, feqn_pats :: HsTyPats (GhcPass 'Parsed)
feqn_pats = [HsArg
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))]
args'
, feqn_fixity :: LexicalFixity
feqn_fixity = LexicalFixity
Prefix
, feqn_rhs :: GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
feqn_rhs = GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
rhs' } }
InfixT Type
t1 Name
nm Type
t2 -> do { LocatedN RdrName
nm' <- Name -> CvtM (LocatedN RdrName)
tconNameN Name
nm
; [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
args' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> CvtM (LHsType (GhcPass 'Parsed))
cvtType [Type
t1,Type
t2]
; GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
rhs' <- Type -> CvtM (LHsType (GhcPass 'Parsed))
cvtType Type
rhs
; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA
forall a b. (a -> b) -> a -> b
$ FamEqn { feqn_ext :: XCFamEqn
(GhcPass 'Parsed)
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
feqn_ext = forall a. EpAnn a
noAnn
, feqn_tycon :: XRec (GhcPass 'Parsed) (IdP (GhcPass 'Parsed))
feqn_tycon = LocatedN RdrName
nm'
, feqn_bndrs :: HsOuterFamEqnTyVarBndrs (GhcPass 'Parsed)
feqn_bndrs = HsOuterFamEqnTyVarBndrs (GhcPass 'Parsed)
outer_bndrs
, feqn_pats :: HsTyPats (GhcPass 'Parsed)
feqn_pats =
(forall a b. (a -> b) -> [a] -> [b]
map forall tm ty. tm -> HsArg tm ty
HsValArg [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
args') forall a. [a] -> [a] -> [a]
++ [HsArg
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))]
args
, feqn_fixity :: LexicalFixity
feqn_fixity = LexicalFixity
Hs.Infix
, feqn_rhs :: GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
feqn_rhs = GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
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])
cvt_ci_decs :: SDoc
-> [Dec]
-> CvtM
(LHsBinds (GhcPass 'Parsed), [LSig (GhcPass 'Parsed)],
[LFamilyDecl (GhcPass 'Parsed)],
[LTyFamInstDecl (GhcPass 'Parsed)],
[LDataFamInstDecl (GhcPass 'Parsed)])
cvt_ci_decs SDoc
doc [Dec]
decs
= do { [GenLocated SrcSpanAnnA (HsDecl (GhcPass 'Parsed))]
decs' <- [Dec] -> CvtM [LHsDecl (GhcPass 'Parsed)]
cvtDecs [Dec]
decs
; let ([GenLocated SrcSpanAnnA (TyFamInstDecl (GhcPass 'Parsed))]
ats', [GenLocated SrcSpanAnnA (HsDecl (GhcPass 'Parsed))]
bind_sig_decs') = forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
partitionWith LHsDecl (GhcPass 'Parsed)
-> Either
(LTyFamInstDecl (GhcPass 'Parsed)) (LHsDecl (GhcPass 'Parsed))
is_tyfam_inst [GenLocated SrcSpanAnnA (HsDecl (GhcPass 'Parsed))]
decs'
; let ([GenLocated SrcSpanAnnA (DataFamInstDecl (GhcPass 'Parsed))]
adts', [GenLocated SrcSpanAnnA (HsDecl (GhcPass 'Parsed))]
no_ats') = forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
partitionWith LHsDecl (GhcPass 'Parsed)
-> Either
(LDataFamInstDecl (GhcPass 'Parsed)) (LHsDecl (GhcPass 'Parsed))
is_datafam_inst [GenLocated SrcSpanAnnA (HsDecl (GhcPass 'Parsed))]
bind_sig_decs'
; let ([GenLocated SrcSpanAnnA (Sig (GhcPass 'Parsed))]
sigs', [GenLocated SrcSpanAnnA (HsDecl (GhcPass 'Parsed))]
prob_binds') = forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
partitionWith LHsDecl (GhcPass 'Parsed)
-> Either (LSig (GhcPass 'Parsed)) (LHsDecl (GhcPass 'Parsed))
is_sig [GenLocated SrcSpanAnnA (HsDecl (GhcPass 'Parsed))]
no_ats'
; let ([GenLocated SrcSpanAnnA (HsBind (GhcPass 'Parsed))]
binds', [GenLocated SrcSpanAnnA (HsDecl (GhcPass 'Parsed))]
prob_fams') = forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
partitionWith LHsDecl (GhcPass 'Parsed)
-> Either (LHsBind (GhcPass 'Parsed)) (LHsDecl (GhcPass 'Parsed))
is_bind [GenLocated SrcSpanAnnA (HsDecl (GhcPass 'Parsed))]
prob_binds'
; let ([GenLocated SrcSpanAnnA (FamilyDecl (GhcPass 'Parsed))]
fams', [GenLocated SrcSpanAnnA (HsDecl (GhcPass 'Parsed))]
bads) = forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
partitionWith LHsDecl (GhcPass 'Parsed)
-> Either
(LFamilyDecl (GhcPass 'Parsed)) (LHsDecl (GhcPass 'Parsed))
is_fam_decl [GenLocated SrcSpanAnnA (HsDecl (GhcPass 'Parsed))]
prob_fams'
; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated SrcSpanAnnA (HsDecl (GhcPass 'Parsed))]
bads) (forall a. SDoc -> CvtM a
failWith (forall a. Outputable a => SDoc -> [a] -> SDoc
mkBadDecMsg SDoc
doc [GenLocated SrcSpanAnnA (HsDecl (GhcPass 'Parsed))]
bads))
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> Bag a
listToBag [GenLocated SrcSpanAnnA (HsBind (GhcPass 'Parsed))]
binds', [GenLocated SrcSpanAnnA (Sig (GhcPass 'Parsed))]
sigs', [GenLocated SrcSpanAnnA (FamilyDecl (GhcPass 'Parsed))]
fams', [GenLocated SrcSpanAnnA (TyFamInstDecl (GhcPass 'Parsed))]
ats', [GenLocated SrcSpanAnnA (DataFamInstDecl (GhcPass 'Parsed))]
adts') }
cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr ()]
-> CvtM ( LHsContext GhcPs
, LocatedN RdrName
, LHsQTyVars GhcPs)
cvt_tycl_hdr :: [Type]
-> Name
-> [TyVarBndr ()]
-> CvtM
(LHsContext (GhcPass 'Parsed), LocatedN RdrName,
LHsQTyVars (GhcPass 'Parsed))
cvt_tycl_hdr [Type]
cxt Name
tc [TyVarBndr ()]
tvs
= do { GenLocated
SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
cxt' <- PprPrec -> [Type] -> CvtM (LHsContext (GhcPass 'Parsed))
cvtContext PprPrec
funPrec [Type]
cxt
; LocatedN RdrName
tc' <- Name -> CvtM (LocatedN RdrName)
tconNameN Name
tc
; [GenLocated SrcSpanAnnA (HsTyVarBndr () (GhcPass 'Parsed))]
tvs' <- forall flag flag'.
CvtFlag flag flag' =>
[TyVarBndr flag] -> CvtM [LHsTyVarBndr flag' (GhcPass 'Parsed)]
cvtTvs [TyVarBndr ()]
tvs
; forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated
SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
cxt', LocatedN RdrName
tc', [LHsTyVarBndr () (GhcPass 'Parsed)] -> LHsQTyVars (GhcPass 'Parsed)
mkHsQTvs [GenLocated SrcSpanAnnA (HsTyVarBndr () (GhcPass 'Parsed))]
tvs')
}
cvt_datainst_hdr :: TH.Cxt -> Maybe [TH.TyVarBndr ()] -> TH.Type
-> CvtM ( LHsContext GhcPs
, LocatedN RdrName
, HsOuterFamEqnTyVarBndrs GhcPs
, HsTyPats GhcPs)
cvt_datainst_hdr :: [Type]
-> Maybe [TyVarBndr ()]
-> Type
-> CvtM
(LHsContext (GhcPass 'Parsed), LocatedN RdrName,
HsOuterFamEqnTyVarBndrs (GhcPass 'Parsed),
HsTyPats (GhcPass 'Parsed))
cvt_datainst_hdr [Type]
cxt Maybe [TyVarBndr ()]
bndrs Type
tys
= do { GenLocated
SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
cxt' <- PprPrec -> [Type] -> CvtM (LHsContext (GhcPass 'Parsed))
cvtContext PprPrec
funPrec [Type]
cxt
; Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr () (GhcPass 'Parsed))]
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' (GhcPass 'Parsed))
cvt_tv) Maybe [TyVarBndr ()]
bndrs
; let outer_bndrs :: HsOuterFamEqnTyVarBndrs (GhcPass 'Parsed)
outer_bndrs = Maybe [LHsTyVarBndr () (GhcPass 'Parsed)]
-> HsOuterFamEqnTyVarBndrs (GhcPass 'Parsed)
mkHsOuterFamEqnTyVarBndrs Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr () (GhcPass 'Parsed))]
bndrs'
; (Type
head_ty, [HsArg
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))]
args) <- Type -> CvtM (Type, HsTyPats (GhcPass 'Parsed))
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 (GhcPass 'Parsed)))
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))]
args' = forall a b. (a -> b) -> [a] -> [b]
map LHsTypeArg (GhcPass 'Parsed) -> LHsTypeArg (GhcPass 'Parsed)
wrap_tyarg [HsArg
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))]
args
; forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated
SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
cxt', LocatedN RdrName
nm', HsOuterFamEqnTyVarBndrs (GhcPass 'Parsed)
outer_bndrs, [HsArg
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))]
args') }
InfixT Type
t1 Name
nm Type
t2 -> do { LocatedN RdrName
nm' <- Name -> CvtM (LocatedN RdrName)
tconNameN Name
nm
; [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
args' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> CvtM (LHsType (GhcPass 'Parsed))
cvtType [Type
t1,Type
t2]
; forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated
SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
cxt', LocatedN RdrName
nm', HsOuterFamEqnTyVarBndrs (GhcPass 'Parsed)
outer_bndrs,
((forall a b. (a -> b) -> [a] -> [b]
map forall tm ty. tm -> HsArg tm ty
HsValArg [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
args') forall a. [a] -> [a] -> [a]
++ [HsArg
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))]
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 (GhcPass 'Parsed),
LFamilyResultSig (GhcPass 'Parsed),
Maybe (LInjectivityAnn (GhcPass 'Parsed)))
cvt_tyfam_head (TypeFamilyHead Name
tc [TyVarBndr ()]
tyvars FamilyResultSig
result Maybe InjectivityAnn
injectivity)
= do {(GenLocated
SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
_, LocatedN RdrName
tc', LHsQTyVars (GhcPass 'Parsed)
tyvars') <- [Type]
-> Name
-> [TyVarBndr ()]
-> CvtM
(LHsContext (GhcPass 'Parsed), LocatedN RdrName,
LHsQTyVars (GhcPass 'Parsed))
cvt_tycl_hdr [] Name
tc [TyVarBndr ()]
tyvars
; GenLocated (SrcAnn NoEpAnns) (FamilyResultSig (GhcPass 'Parsed))
result' <- FamilyResultSig -> CvtM (LFamilyResultSig (GhcPass 'Parsed))
cvtFamilyResultSig FamilyResultSig
result
; Maybe
(GenLocated (SrcAnn NoEpAnns) (InjectivityAnn (GhcPass 'Parsed)))
injectivity' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse InjectivityAnn -> CvtM (LInjectivityAnn (GhcPass 'Parsed))
cvtInjectivityAnnotation Maybe InjectivityAnn
injectivity
; forall (m :: * -> *) a. Monad m => a -> m a
return (LocatedN RdrName
tc', LHsQTyVars (GhcPass 'Parsed)
tyvars', GenLocated (SrcAnn NoEpAnns) (FamilyResultSig (GhcPass 'Parsed))
result', Maybe
(GenLocated (SrcAnn NoEpAnns) (InjectivityAnn (GhcPass 'Parsed)))
injectivity') }
is_fam_decl :: LHsDecl GhcPs -> Either (LFamilyDecl GhcPs) (LHsDecl GhcPs)
is_fam_decl :: LHsDecl (GhcPass 'Parsed)
-> Either
(LFamilyDecl (GhcPass 'Parsed)) (LHsDecl (GhcPass 'Parsed))
is_fam_decl (L SrcSpanAnnA
loc (TyClD XTyClD (GhcPass 'Parsed)
_ (FamDecl { tcdFam :: forall pass. TyClDecl pass -> FamilyDecl pass
tcdFam = FamilyDecl (GhcPass 'Parsed)
d }))) = forall a b. a -> Either a b
Left (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc FamilyDecl (GhcPass 'Parsed)
d)
is_fam_decl LHsDecl (GhcPass 'Parsed)
decl = forall a b. b -> Either a b
Right LHsDecl (GhcPass 'Parsed)
decl
is_tyfam_inst :: LHsDecl GhcPs -> Either (LTyFamInstDecl GhcPs) (LHsDecl GhcPs)
is_tyfam_inst :: LHsDecl (GhcPass 'Parsed)
-> Either
(LTyFamInstDecl (GhcPass 'Parsed)) (LHsDecl (GhcPass 'Parsed))
is_tyfam_inst (L SrcSpanAnnA
loc (Hs.InstD XInstD (GhcPass 'Parsed)
_ (TyFamInstD { tfid_inst :: forall pass. InstDecl pass -> TyFamInstDecl pass
tfid_inst = TyFamInstDecl (GhcPass 'Parsed)
d })))
= forall a b. a -> Either a b
Left (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc TyFamInstDecl (GhcPass 'Parsed)
d)
is_tyfam_inst LHsDecl (GhcPass 'Parsed)
decl
= forall a b. b -> Either a b
Right LHsDecl (GhcPass 'Parsed)
decl
is_datafam_inst :: LHsDecl GhcPs
-> Either (LDataFamInstDecl GhcPs) (LHsDecl GhcPs)
is_datafam_inst :: LHsDecl (GhcPass 'Parsed)
-> Either
(LDataFamInstDecl (GhcPass 'Parsed)) (LHsDecl (GhcPass 'Parsed))
is_datafam_inst (L SrcSpanAnnA
loc (Hs.InstD XInstD (GhcPass 'Parsed)
_ (DataFamInstD { dfid_inst :: forall pass. InstDecl pass -> DataFamInstDecl pass
dfid_inst = DataFamInstDecl (GhcPass 'Parsed)
d })))
= forall a b. a -> Either a b
Left (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc DataFamInstDecl (GhcPass 'Parsed)
d)
is_datafam_inst LHsDecl (GhcPass 'Parsed)
decl
= forall a b. b -> Either a b
Right LHsDecl (GhcPass 'Parsed)
decl
is_sig :: LHsDecl GhcPs -> Either (LSig GhcPs) (LHsDecl GhcPs)
is_sig :: LHsDecl (GhcPass 'Parsed)
-> Either (LSig (GhcPass 'Parsed)) (LHsDecl (GhcPass 'Parsed))
is_sig (L SrcSpanAnnA
loc (Hs.SigD XSigD (GhcPass 'Parsed)
_ Sig (GhcPass 'Parsed)
sig)) = forall a b. a -> Either a b
Left (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc Sig (GhcPass 'Parsed)
sig)
is_sig LHsDecl (GhcPass 'Parsed)
decl = forall a b. b -> Either a b
Right LHsDecl (GhcPass 'Parsed)
decl
is_bind :: LHsDecl GhcPs -> Either (LHsBind GhcPs) (LHsDecl GhcPs)
is_bind :: LHsDecl (GhcPass 'Parsed)
-> Either (LHsBind (GhcPass 'Parsed)) (LHsDecl (GhcPass 'Parsed))
is_bind (L SrcSpanAnnA
loc (Hs.ValD XValD (GhcPass 'Parsed)
_ HsBind (GhcPass 'Parsed)
bind)) = forall a b. a -> Either a b
Left (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc HsBind (GhcPass 'Parsed)
bind)
is_bind LHsDecl (GhcPass 'Parsed)
decl = forall a b. b -> Either a b
Right LHsDecl (GhcPass 'Parsed)
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)) ]
cvtConstr :: TH.Con -> CvtM (LConDecl GhcPs)
cvtConstr :: Con -> CvtM (LConDecl (GhcPass 'Parsed))
cvtConstr (NormalC Name
c [BangType]
strtys)
= do { LocatedN RdrName
c' <- Name -> CvtM (LocatedN RdrName)
cNameN Name
c
; [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
tys' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM BangType -> CvtM (LHsType (GhcPass 'Parsed))
cvt_arg [BangType]
strtys
; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ EpAnn [AddEpAnn]
-> LocatedN RdrName
-> Maybe [LHsTyVarBndr Specificity (GhcPass 'Parsed)]
-> Maybe (LHsContext (GhcPass 'Parsed))
-> HsConDeclH98Details (GhcPass 'Parsed)
-> ConDecl (GhcPass 'Parsed)
mkConDeclH98 forall a. EpAnn a
noAnn LocatedN RdrName
c' forall a. Maybe a
Nothing forall a. Maybe a
Nothing (forall tyarg arg rec.
[tyarg] -> [arg] -> HsConDetails tyarg arg rec
PrefixCon [Void]
noTypeArgs (forall a b. (a -> b) -> [a] -> [b]
map forall a (p :: Pass). a -> HsScaled (GhcPass p) a
hsLinear [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
tys')) }
cvtConstr (RecC Name
c [VarBangType]
varstrtys)
= do { LocatedN RdrName
c' <- Name -> CvtM (LocatedN RdrName)
cNameN Name
c
; [GenLocated SrcSpanAnnA (ConDeclField (GhcPass 'Parsed))]
args' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM VarBangType -> CvtM (LConDeclField (GhcPass 'Parsed))
cvt_id_arg [VarBangType]
varstrtys
; ConDecl (GhcPass 'Parsed)
con_decl <- forall ann a b. (LocatedAn ann a -> b) -> a -> CvtM b
wrapParLA (EpAnn [AddEpAnn]
-> LocatedN RdrName
-> Maybe [LHsTyVarBndr Specificity (GhcPass 'Parsed)]
-> Maybe (LHsContext (GhcPass 'Parsed))
-> HsConDeclH98Details (GhcPass 'Parsed)
-> ConDecl (GhcPass 'Parsed)
mkConDeclH98 forall a. EpAnn a
noAnn LocatedN RdrName
c' forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall tyarg arg rec. rec -> HsConDetails tyarg arg rec
RecCon) [GenLocated SrcSpanAnnA (ConDeclField (GhcPass 'Parsed))]
args'
; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA ConDecl (GhcPass 'Parsed)
con_decl }
cvtConstr (InfixC BangType
st1 Name
c BangType
st2)
= do { LocatedN RdrName
c' <- Name -> CvtM (LocatedN RdrName)
cNameN Name
c
; GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
st1' <- BangType -> CvtM (LHsType (GhcPass 'Parsed))
cvt_arg BangType
st1
; GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
st2' <- BangType -> CvtM (LHsType (GhcPass 'Parsed))
cvt_arg BangType
st2
; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ EpAnn [AddEpAnn]
-> LocatedN RdrName
-> Maybe [LHsTyVarBndr Specificity (GhcPass 'Parsed)]
-> Maybe (LHsContext (GhcPass 'Parsed))
-> HsConDeclH98Details (GhcPass 'Parsed)
-> ConDecl (GhcPass 'Parsed)
mkConDeclH98 forall a. EpAnn a
noAnn LocatedN RdrName
c' forall a. Maybe a
Nothing forall a. Maybe a
Nothing
(forall tyarg arg rec. arg -> arg -> HsConDetails tyarg arg rec
InfixCon (forall a (p :: Pass). a -> HsScaled (GhcPass p) a
hsLinear GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
st1') (forall a (p :: Pass). a -> HsScaled (GhcPass p) a
hsLinear GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
st2')) }
cvtConstr (ForallC [TyVarBndr Specificity]
tvs [Type]
ctxt Con
con)
= do { [GenLocated
SrcSpanAnnA (HsTyVarBndr Specificity (GhcPass 'Parsed))]
tvs' <- forall flag flag'.
CvtFlag flag flag' =>
[TyVarBndr flag] -> CvtM [LHsTyVarBndr flag' (GhcPass 'Parsed)]
cvtTvs [TyVarBndr Specificity]
tvs
; GenLocated
SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
ctxt' <- PprPrec -> [Type] -> CvtM (LHsContext (GhcPass 'Parsed))
cvtContext PprPrec
funPrec [Type]
ctxt
; L SrcSpanAnnA
_ ConDecl (GhcPass 'Parsed)
con' <- Con -> CvtM (LConDecl (GhcPass 'Parsed))
cvtConstr Con
con
; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ [LHsTyVarBndr Specificity (GhcPass 'Parsed)]
-> LHsContext (GhcPass 'Parsed)
-> ConDecl (GhcPass 'Parsed)
-> ConDecl (GhcPass 'Parsed)
add_forall [GenLocated
SrcSpanAnnA (HsTyVarBndr Specificity (GhcPass 'Parsed))]
tvs' GenLocated
SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
ctxt' ConDecl (GhcPass 'Parsed)
con' }
where
add_cxt :: GenLocated
SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
-> Maybe
(GenLocated l [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))])
-> Maybe (LHsContext (GhcPass 'Parsed))
add_cxt GenLocated
SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
lcxt Maybe
(GenLocated l [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))])
Nothing = LHsContext (GhcPass 'Parsed)
-> Maybe (LHsContext (GhcPass 'Parsed))
mkHsContextMaybe GenLocated
SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
lcxt
add_cxt (L SrcSpanAnnC
loc [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
cxt1) (Just (L l
_ [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
cxt2))
= forall a. a -> Maybe a
Just (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnC
loc ([GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
cxt1 forall a. [a] -> [a] -> [a]
++ [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
cxt2))
add_forall :: [LHsTyVarBndr Hs.Specificity GhcPs] -> LHsContext GhcPs
-> ConDecl GhcPs -> ConDecl GhcPs
add_forall :: [LHsTyVarBndr Specificity (GhcPass 'Parsed)]
-> LHsContext (GhcPass 'Parsed)
-> ConDecl (GhcPass 'Parsed)
-> ConDecl (GhcPass 'Parsed)
add_forall [LHsTyVarBndr Specificity (GhcPass 'Parsed)]
tvs' LHsContext (GhcPass 'Parsed)
cxt' con :: ConDecl (GhcPass 'Parsed)
con@(ConDeclGADT { con_bndrs :: forall pass. ConDecl pass -> XRec pass (HsOuterSigTyVarBndrs pass)
con_bndrs = L SrcSpanAnnA
l HsOuterSigTyVarBndrs (GhcPass 'Parsed)
outer_bndrs, con_mb_cxt :: forall pass. ConDecl pass -> Maybe (LHsContext pass)
con_mb_cxt = Maybe (LHsContext (GhcPass 'Parsed))
cxt })
= ConDecl (GhcPass 'Parsed)
con { con_bndrs :: XRec (GhcPass 'Parsed) (HsOuterSigTyVarBndrs (GhcPass 'Parsed))
con_bndrs = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l HsOuterSigTyVarBndrs (GhcPass 'Parsed)
outer_bndrs'
, con_mb_cxt :: Maybe (LHsContext (GhcPass 'Parsed))
con_mb_cxt = forall {l}.
GenLocated
SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
-> Maybe
(GenLocated l [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))])
-> Maybe
(GenLocated
SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))])
add_cxt LHsContext (GhcPass 'Parsed)
cxt' Maybe (LHsContext (GhcPass 'Parsed))
cxt }
where
outer_bndrs' :: HsOuterSigTyVarBndrs (GhcPass 'Parsed)
outer_bndrs'
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated
SrcSpanAnnA (HsTyVarBndr Specificity (GhcPass 'Parsed))]
all_tvs = forall flag. HsOuterTyVarBndrs flag (GhcPass 'Parsed)
mkHsOuterImplicit
| Bool
otherwise = forall flag.
EpAnnForallTy
-> [LHsTyVarBndr flag (GhcPass 'Parsed)]
-> HsOuterTyVarBndrs flag (GhcPass 'Parsed)
mkHsOuterExplicit forall a. EpAnn a
noAnn [GenLocated
SrcSpanAnnA (HsTyVarBndr Specificity (GhcPass 'Parsed))]
all_tvs
all_tvs :: [GenLocated
SrcSpanAnnA (HsTyVarBndr Specificity (GhcPass 'Parsed))]
all_tvs = [LHsTyVarBndr Specificity (GhcPass 'Parsed)]
tvs' forall a. [a] -> [a] -> [a]
++ [LHsTyVarBndr Specificity (NoGhcTc (GhcPass 'Parsed))]
outer_exp_tvs
outer_exp_tvs :: [LHsTyVarBndr Specificity (NoGhcTc (GhcPass 'Parsed))]
outer_exp_tvs = forall flag (p :: Pass).
HsOuterTyVarBndrs flag (GhcPass p)
-> [LHsTyVarBndr flag (NoGhcTc (GhcPass p))]
hsOuterExplicitBndrs HsOuterSigTyVarBndrs (GhcPass 'Parsed)
outer_bndrs
add_forall [LHsTyVarBndr Specificity (GhcPass 'Parsed)]
tvs' LHsContext (GhcPass 'Parsed)
cxt' con :: ConDecl (GhcPass 'Parsed)
con@(ConDeclH98 { con_ex_tvs :: forall pass. ConDecl pass -> [LHsTyVarBndr Specificity pass]
con_ex_tvs = [LHsTyVarBndr Specificity (GhcPass 'Parsed)]
ex_tvs, con_mb_cxt :: forall pass. ConDecl pass -> Maybe (LHsContext pass)
con_mb_cxt = Maybe (LHsContext (GhcPass 'Parsed))
cxt })
= ConDecl (GhcPass 'Parsed)
con { con_forall :: Bool
con_forall = Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated
SrcSpanAnnA (HsTyVarBndr Specificity (GhcPass 'Parsed))]
all_tvs)
, con_ex_tvs :: [LHsTyVarBndr Specificity (GhcPass 'Parsed)]
con_ex_tvs = [GenLocated
SrcSpanAnnA (HsTyVarBndr Specificity (GhcPass 'Parsed))]
all_tvs
, con_mb_cxt :: Maybe (LHsContext (GhcPass 'Parsed))
con_mb_cxt = forall {l}.
GenLocated
SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
-> Maybe
(GenLocated l [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))])
-> Maybe
(GenLocated
SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))])
add_cxt LHsContext (GhcPass 'Parsed)
cxt' Maybe (LHsContext (GhcPass 'Parsed))
cxt }
where
all_tvs :: [GenLocated
SrcSpanAnnA (HsTyVarBndr Specificity (GhcPass 'Parsed))]
all_tvs = [LHsTyVarBndr Specificity (GhcPass 'Parsed)]
tvs' forall a. [a] -> [a] -> [a]
++ [LHsTyVarBndr Specificity (GhcPass 'Parsed)]
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 (GhcPass 'Parsed))]
args <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM BangType -> CvtM (LHsType (GhcPass 'Parsed))
cvt_arg [BangType]
strtys
; GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
ty' <- Type -> CvtM (LHsType (GhcPass 'Parsed))
cvtType Type
ty
; [LocatedN RdrName]
-> HsConDeclGADTDetails (GhcPass 'Parsed)
-> LHsType (GhcPass 'Parsed)
-> CvtM (LConDecl (GhcPass 'Parsed))
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 (p :: Pass). a -> HsScaled (GhcPass p) a
hsLinear [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
args) GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
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 (GhcPass 'Parsed))
ty' <- Type -> CvtM (LHsType (GhcPass 'Parsed))
cvtType Type
ty
; [GenLocated SrcSpanAnnA (ConDeclField (GhcPass 'Parsed))]
rec_flds <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM VarBangType -> CvtM (LConDeclField (GhcPass 'Parsed))
cvt_id_arg [VarBangType]
varstrtys
; LocatedAn
AnnList [GenLocated SrcSpanAnnA (ConDeclField (GhcPass 'Parsed))]
lrec_flds <- forall e ann. e -> CvtM (LocatedAn ann e)
returnLA [GenLocated SrcSpanAnnA (ConDeclField (GhcPass 'Parsed))]
rec_flds
; [LocatedN RdrName]
-> HsConDeclGADTDetails (GhcPass 'Parsed)
-> LHsType (GhcPass 'Parsed)
-> CvtM (LConDecl (GhcPass 'Parsed))
mk_gadt_decl [LocatedN RdrName]
c' (forall pass.
XRec pass [LConDeclField pass]
-> LHsUniToken "->" "\8594" pass -> HsConDeclGADTDetails pass
RecConGADT LocatedAn
AnnList [GenLocated SrcSpanAnnA (ConDeclField (GhcPass 'Parsed))]
lrec_flds forall (tok :: Symbol) (utok :: Symbol).
GenLocated TokenLocation (HsUniToken tok utok)
noHsUniTok) GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
ty' }
mk_gadt_decl :: [LocatedN RdrName] -> HsConDeclGADTDetails GhcPs -> LHsType GhcPs
-> CvtM (LConDecl GhcPs)
mk_gadt_decl :: [LocatedN RdrName]
-> HsConDeclGADTDetails (GhcPass 'Parsed)
-> LHsType (GhcPass 'Parsed)
-> CvtM (LConDecl (GhcPass 'Parsed))
mk_gadt_decl [LocatedN RdrName]
names HsConDeclGADTDetails (GhcPass 'Parsed)
args LHsType (GhcPass 'Parsed)
res_ty
= do GenLocated SrcSpanAnnA (HsOuterSigTyVarBndrs (GhcPass 'Parsed))
bndrs <- forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall flag. HsOuterTyVarBndrs flag (GhcPass 'Parsed)
mkHsOuterImplicit
forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ ConDeclGADT
{ con_g_ext :: XConDeclGADT (GhcPass 'Parsed)
con_g_ext = forall a. EpAnn a
noAnn
, con_names :: [XRec (GhcPass 'Parsed) (IdP (GhcPass 'Parsed))]
con_names = [LocatedN RdrName]
names
, con_bndrs :: XRec (GhcPass 'Parsed) (HsOuterSigTyVarBndrs (GhcPass 'Parsed))
con_bndrs = GenLocated SrcSpanAnnA (HsOuterSigTyVarBndrs (GhcPass 'Parsed))
bndrs
, con_mb_cxt :: Maybe (LHsContext (GhcPass 'Parsed))
con_mb_cxt = forall a. Maybe a
Nothing
, con_g_args :: HsConDeclGADTDetails (GhcPass 'Parsed)
con_g_args = HsConDeclGADTDetails (GhcPass 'Parsed)
args
, con_res_ty :: LHsType (GhcPass 'Parsed)
con_res_ty = LHsType (GhcPass 'Parsed)
res_ty
, con_doc :: Maybe (LHsDoc (GhcPass 'Parsed))
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 (GhcPass 'Parsed))
cvt_arg (Bang SourceUnpackedness
su SourceStrictness
ss, Type
ty)
= do { GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
ty'' <- Type -> CvtM (LHsType (GhcPass 'Parsed))
cvtType Type
ty
; let ty' :: LHsType (GhcPass 'Parsed)
ty' = forall (p :: Pass).
PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)
parenthesizeHsType PprPrec
appPrec GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
ty''
su' :: SrcUnpackedness
su' = SourceUnpackedness -> SrcUnpackedness
cvtSrcUnpackedness SourceUnpackedness
su
ss' :: SrcStrictness
ss' = SourceStrictness -> SrcStrictness
cvtSrcStrictness SourceStrictness
ss
; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ forall pass.
XBangTy pass -> HsSrcBang -> LHsType pass -> HsType pass
HsBangTy forall a. EpAnn a
noAnn (SourceText -> SrcUnpackedness -> SrcStrictness -> HsSrcBang
HsSrcBang SourceText
NoSourceText SrcUnpackedness
su' SrcStrictness
ss') LHsType (GhcPass 'Parsed)
ty' }
cvt_id_arg :: (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField GhcPs)
cvt_id_arg :: VarBangType -> CvtM (LConDeclField (GhcPass 'Parsed))
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 (GhcPass 'Parsed))
ty' <- BangType -> CvtM (LHsType (GhcPass 'Parsed))
cvt_arg (Bang
str,Type
ty)
; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ ConDeclField
{ cd_fld_ext :: XConDeclField (GhcPass 'Parsed)
cd_fld_ext = forall a. EpAnn a
noAnn
, cd_fld_names :: [LFieldOcc (GhcPass 'Parsed)]
cd_fld_names
= [forall l e. l -> e -> GenLocated l e
L (forall a ann. SrcSpanAnn' a -> SrcAnn ann
l2l SrcSpanAnnN
li) forall a b. (a -> b) -> a -> b
$ forall pass. XCFieldOcc pass -> XRec pass RdrName -> FieldOcc pass
FieldOcc NoExtField
noExtField (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
li RdrName
i')]
, cd_fld_type :: LHsType (GhcPass 'Parsed)
cd_fld_type = GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
ty'
, cd_fld_doc :: Maybe (LHsDoc (GhcPass 'Parsed))
cd_fld_doc = forall a. Maybe a
Nothing} }
cvtDerivs :: [TH.DerivClause] -> CvtM (HsDeriving GhcPs)
cvtDerivs :: [DerivClause] -> CvtM (HsDeriving (GhcPass 'Parsed))
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 (GhcPass 'Parsed))
cvtDerivClause [DerivClause]
cs }
cvt_fundep :: TH.FunDep -> CvtM (LHsFunDep GhcPs)
cvt_fundep :: FunDep -> CvtM (LHsFunDep (GhcPass 'Parsed))
cvt_fundep (TH.FunDep [Name]
xs [Name]
ys) = do { [LocatedN RdrName]
xs' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> CvtM (LocatedN RdrName)
tNameN [Name]
xs
; [LocatedN RdrName]
ys' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> CvtM (LocatedN RdrName)
tNameN [Name]
ys
; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA (forall pass.
XCFunDep pass -> [LIdP pass] -> [LIdP pass] -> FunDep pass
Hs.FunDep forall a. EpAnn a
noAnn [LocatedN RdrName]
xs' [LocatedN RdrName]
ys') }
cvtForD :: Foreign -> CvtM (ForeignDecl GhcPs)
cvtForD :: Foreign -> CvtM (ForeignDecl (GhcPass 'Parsed))
cvtForD (ImportF Callconv
callconv Safety
safety String
from Name
nm Type
ty) =
do { SrcSpan
l <- CvtM SrcSpan
getL
; if
| 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 (GhcPass 'Parsed))
mk_imp (Located CCallConv
-> Located Safety
-> Maybe Header
-> CImportSpec
-> Located SourceText
-> ForeignImport
CImport (forall l e. l -> e -> GenLocated l e
L SrcSpan
l (Callconv -> CCallConv
cvt_conv Callconv
callconv)) (forall l e. l -> e -> GenLocated l e
L SrcSpan
l Safety
safety') forall a. Maybe a
Nothing
(CCallTarget -> CImportSpec
CFunction (SourceText -> CLabelString -> Maybe Unit -> Bool -> CCallTarget
StaticTarget (String -> SourceText
SourceText String
from)
(String -> CLabelString
mkFastString String
from) forall a. Maybe a
Nothing
Bool
True))
(forall l e. l -> e -> GenLocated l e
L SrcSpan
l 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 l e. l -> e -> GenLocated l e
L SrcSpan
l (Callconv -> CCallConv
cvt_conv Callconv
callconv)) (forall l e. l -> e -> GenLocated l e
L SrcSpan
l Safety
safety')
(String -> CLabelString
mkFastString (Name -> String
TH.nameBase Name
nm))
String
from (forall l e. l -> e -> GenLocated l e
L SrcSpan
l forall a b. (a -> b) -> a -> b
$ String -> SourceText
quotedSourceText String
from)
-> ForeignImport -> CvtM (ForeignDecl (GhcPass 'Parsed))
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 (GhcPass 'Parsed))
mk_imp ForeignImport
impspec
= do { LocatedN RdrName
nm' <- Name -> CvtM (LocatedN RdrName)
vNameN Name
nm
; GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Parsed))
ty' <- Type -> CvtM (LHsSigType (GhcPass 'Parsed))
cvtSigType Type
ty
; forall (m :: * -> *) a. Monad m => a -> m a
return (ForeignImport { fd_i_ext :: XForeignImport (GhcPass 'Parsed)
fd_i_ext = forall a. EpAnn a
noAnn
, fd_name :: XRec (GhcPass 'Parsed) (IdP (GhcPass 'Parsed))
fd_name = LocatedN RdrName
nm'
, fd_sig_ty :: LHsSigType (GhcPass 'Parsed)
fd_sig_ty = GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Parsed))
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 (GhcPass 'Parsed))
ty' <- Type -> CvtM (LHsSigType (GhcPass 'Parsed))
cvtSigType Type
ty
; SrcSpan
l <- CvtM SrcSpan
getL
; let e :: ForeignExport
e = Located CExportSpec -> Located SourceText -> ForeignExport
CExport (forall l e. l -> e -> GenLocated l e
L SrcSpan
l (SourceText -> CLabelString -> CCallConv -> CExportSpec
CExportStatic (String -> SourceText
SourceText String
as)
(String -> CLabelString
mkFastString String
as)
(Callconv -> CCallConv
cvt_conv Callconv
callconv)))
(forall l e. l -> e -> GenLocated l e
L SrcSpan
l (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 (GhcPass 'Parsed)
fd_e_ext = forall a. EpAnn a
noAnn
, fd_name :: XRec (GhcPass 'Parsed) (IdP (GhcPass 'Parsed))
fd_name = LocatedN RdrName
nm'
, fd_sig_ty :: LHsSigType (GhcPass 'Parsed)
fd_sig_ty = GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Parsed))
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
cvtPragmaD :: Pragma -> CvtM (Maybe (LHsDecl GhcPs))
cvtPragmaD :: Pragma -> CvtM (Maybe (LHsDecl (GhcPass 'Parsed)))
cvtPragmaD (InlineP Name
nm Inline
inline RuleMatch
rm Phases
phases)
= do { LocatedN RdrName
nm' <- Name -> CvtM (LocatedN RdrName)
vNameN Name
nm
; let dflt :: Activation
dflt = Inline -> Activation
dfltActivation Inline
inline
; let src :: Inline -> String
src Inline
TH.NoInline = String
"{-# NOINLINE"
src Inline
TH.Inline = String
"{-# INLINE"
src Inline
TH.Inlinable = String
"{-# INLINABLE"
; let ip :: InlinePragma
ip = InlinePragma { inl_src :: SourceText
inl_src = Inline -> SourceText
toSrcTxt Inline
inline
, inl_inline :: InlineSpec
inl_inline = Inline -> SourceText -> InlineSpec
cvtInline Inline
inline (Inline -> SourceText
toSrcTxt Inline
inline)
, inl_rule :: RuleMatchInfo
inl_rule = RuleMatch -> RuleMatchInfo
cvtRuleMatch RuleMatch
rm
, inl_act :: Activation
inl_act = Phases -> Activation -> Activation
cvtPhases Phases
phases Activation
dflt
, inl_sat :: Maybe Int
inl_sat = forall a. Maybe a
Nothing }
where
toSrcTxt :: Inline -> SourceText
toSrcTxt Inline
a = String -> SourceText
SourceText forall a b. (a -> b) -> a -> b
$ Inline -> String
src Inline
a
; forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA forall a b. (a -> b) -> a -> b
$ forall p. XSigD p -> Sig p -> HsDecl p
Hs.SigD NoExtField
noExtField forall a b. (a -> b) -> a -> b
$ forall pass.
XInlineSig pass -> LIdP pass -> InlinePragma -> Sig pass
InlineSig forall a. EpAnn a
noAnn LocatedN RdrName
nm' InlinePragma
ip }
cvtPragmaD (OpaqueP Name
nm)
= do { LocatedN RdrName
nm' <- Name -> CvtM (LocatedN RdrName)
vNameN Name
nm
; let ip :: InlinePragma
ip = InlinePragma { inl_src :: SourceText
inl_src = SourceText
srcTxt
, inl_inline :: InlineSpec
inl_inline = SourceText -> InlineSpec
Opaque SourceText
srcTxt
, inl_rule :: RuleMatchInfo
inl_rule = RuleMatchInfo
Hs.FunLike
, inl_act :: Activation
inl_act = Activation
NeverActive
, inl_sat :: Maybe Int
inl_sat = forall a. Maybe a
Nothing }
where
srcTxt :: SourceText
srcTxt = String -> SourceText
SourceText String
"{-# OPAQUE"
; forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA forall a b. (a -> b) -> a -> b
$ forall p. XSigD p -> Sig p -> HsDecl p
Hs.SigD NoExtField
noExtField forall a b. (a -> b) -> a -> b
$ forall pass.
XInlineSig pass -> LIdP pass -> InlinePragma -> Sig pass
InlineSig forall a. EpAnn a
noAnn LocatedN RdrName
nm' InlinePragma
ip }
cvtPragmaD (SpecialiseP Name
nm Type
ty Maybe Inline
inline Phases
phases)
= do { LocatedN RdrName
nm' <- Name -> CvtM (LocatedN RdrName)
vNameN Name
nm
; GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Parsed))
ty' <- Type -> CvtM (LHsSigType (GhcPass 'Parsed))
cvtSigType Type
ty
; let src :: Inline -> String
src Inline
TH.NoInline = String
"{-# SPECIALISE NOINLINE"
src Inline
TH.Inline = String
"{-# SPECIALISE INLINE"
src Inline
TH.Inlinable = String
"{-# SPECIALISE INLINE"
; let (InlineSpec
inline', Activation
dflt, SourceText
srcText) = case Maybe Inline
inline of
Just Inline
inline1 -> (Inline -> SourceText -> InlineSpec
cvtInline Inline
inline1 (Inline -> SourceText
toSrcTxt Inline
inline1), Inline -> Activation
dfltActivation Inline
inline1,
Inline -> SourceText
toSrcTxt Inline
inline1)
Maybe Inline
Nothing -> (InlineSpec
NoUserInlinePrag, Activation
AlwaysActive,
String -> SourceText
SourceText String
"{-# SPECIALISE")
where
toSrcTxt :: Inline -> SourceText
toSrcTxt Inline
a = String -> SourceText
SourceText forall a b. (a -> b) -> a -> b
$ Inline -> String
src Inline
a
; let ip :: InlinePragma
ip = InlinePragma { inl_src :: SourceText
inl_src = SourceText
srcText
, inl_inline :: InlineSpec
inl_inline = InlineSpec
inline'
, inl_rule :: RuleMatchInfo
inl_rule = RuleMatchInfo
Hs.FunLike
, inl_act :: Activation
inl_act = Phases -> Activation -> Activation
cvtPhases Phases
phases Activation
dflt
, inl_sat :: Maybe Int
inl_sat = forall a. Maybe a
Nothing }
; forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA forall a b. (a -> b) -> a -> b
$ forall p. XSigD p -> Sig p -> HsDecl p
Hs.SigD NoExtField
noExtField forall a b. (a -> b) -> a -> b
$ forall pass.
XSpecSig pass
-> LIdP pass -> [LHsSigType pass] -> InlinePragma -> Sig pass
SpecSig forall a. EpAnn a
noAnn LocatedN RdrName
nm' [GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Parsed))
ty'] InlinePragma
ip }
cvtPragmaD (SpecialiseInstP Type
ty)
= do { GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Parsed))
ty' <- Type -> CvtM (LHsSigType (GhcPass 'Parsed))
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 (GhcPass 'Parsed))
ty' }
cvtPragmaD (RuleP String
nm Maybe [TyVarBndr ()]
ty_bndrs [RuleBndr]
tm_bndrs Exp
lhs Exp
rhs Phases
phases)
= do { let nm' :: CLabelString
nm' = String -> CLabelString
mkFastString String
nm
; LocatedAn NoEpAnns (SourceText, CLabelString)
rd_name' <- forall e ann. e -> CvtM (LocatedAn ann e)
returnLA (String -> SourceText
quotedSourceText String
nm,CLabelString
nm')
; let act :: Activation
act = Phases -> Activation -> Activation
cvtPhases Phases
phases Activation
AlwaysActive
; Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr () (GhcPass 'Parsed))]
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' (GhcPass 'Parsed)]
cvtTvs Maybe [TyVarBndr ()]
ty_bndrs
; [GenLocated (SrcAnn NoEpAnns) (RuleBndr (GhcPass 'Parsed))]
tm_bndrs' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM RuleBndr -> CvtM (LRuleBndr (GhcPass 'Parsed))
cvtRuleBndr [RuleBndr]
tm_bndrs
; LocatedA (HsExpr (GhcPass 'Parsed))
lhs' <- Exp -> CvtM (LHsExpr (GhcPass 'Parsed))
cvtl Exp
lhs
; LocatedA (HsExpr (GhcPass 'Parsed))
rhs' <- Exp -> CvtM (LHsExpr (GhcPass 'Parsed))
cvtl Exp
rhs
; LocatedAn AnnListItem (RuleDecl (GhcPass 'Parsed))
rule <- forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$
HsRule { rd_ext :: XHsRule (GhcPass 'Parsed)
rd_ext = forall a. EpAnn a
noAnn
, rd_name :: XRec (GhcPass 'Parsed) (SourceText, CLabelString)
rd_name = LocatedAn NoEpAnns (SourceText, CLabelString)
rd_name'
, rd_act :: Activation
rd_act = Activation
act
, rd_tyvs :: Maybe [LHsTyVarBndr () (NoGhcTc (GhcPass 'Parsed))]
rd_tyvs = Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr () (GhcPass 'Parsed))]
ty_bndrs'
, rd_tmvs :: [LRuleBndr (GhcPass 'Parsed)]
rd_tmvs = [GenLocated (SrcAnn NoEpAnns) (RuleBndr (GhcPass 'Parsed))]
tm_bndrs'
, rd_lhs :: LHsExpr (GhcPass 'Parsed)
rd_lhs = LocatedA (HsExpr (GhcPass 'Parsed))
lhs'
, rd_rhs :: LHsExpr (GhcPass 'Parsed)
rd_rhs = LocatedA (HsExpr (GhcPass 'Parsed))
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 (GhcPass 'Parsed)
rds_ext = forall a. EpAnn a
noAnn
, rds_src :: SourceText
rds_src = String -> SourceText
SourceText String
"{-# RULES"
, rds_rules :: [LRuleDecl (GhcPass 'Parsed)]
rds_rules = [LocatedAn AnnListItem (RuleDecl (GhcPass 'Parsed))
rule] }
}
cvtPragmaD (AnnP AnnTarget
target Exp
exp)
= do { LocatedA (HsExpr (GhcPass 'Parsed))
exp' <- Exp -> CvtM (LHsExpr (GhcPass 'Parsed))
cvtl Exp
exp
; AnnProvenance (GhcPass 'Parsed)
target' <- case AnnTarget
target of
AnnTarget
ModuleAnnotation -> forall (m :: * -> *) a. Monad m => a -> m a
return forall pass. AnnProvenance pass
ModuleAnnProvenance
TypeAnnotation Name
n -> do
RdrName
n' <- Name -> CvtM RdrName
tconName Name
n
forall ann a b. (LocatedAn ann a -> b) -> a -> CvtM b
wrapParLA forall pass. LIdP pass -> AnnProvenance pass
TypeAnnProvenance RdrName
n'
ValueAnnotation Name
n -> do
RdrName
n' <- Name -> CvtM RdrName
vcName Name
n
forall ann a b. (LocatedAn ann a -> b) -> a -> CvtM b
wrapParLA forall pass. LIdP pass -> AnnProvenance pass
ValueAnnProvenance RdrName
n'
; forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA forall a b. (a -> b) -> a -> b
$ forall p. XAnnD p -> AnnDecl p -> HsDecl p
Hs.AnnD NoExtField
noExtField
forall a b. (a -> b) -> a -> b
$ forall pass.
XHsAnnotation pass
-> SourceText
-> AnnProvenance pass
-> XRec pass (HsExpr pass)
-> AnnDecl pass
HsAnnotation forall a. EpAnn a
noAnn (String -> SourceText
SourceText String
"{-# ANN") AnnProvenance (GhcPass 'Parsed)
target' LocatedA (HsExpr (GhcPass 'Parsed))
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 a. CvtM a -> CvtM (Located a)
wrapL forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> CvtM (LocatedN RdrName)
cNameN [Name]
cls
; Maybe (LocatedN RdrName)
mty' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Name -> CvtM (LocatedN RdrName)
tconNameN Maybe Name
mty
; forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA forall a b. (a -> b) -> a -> b
$ forall p. XSigD p -> Sig p -> HsDecl p
Hs.SigD NoExtField
noExtField
forall a b. (a -> b) -> a -> b
$ forall pass.
XCompleteMatchSig pass
-> 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 -> SourceText -> Hs.InlineSpec
cvtInline :: Inline -> SourceText -> InlineSpec
cvtInline Inline
TH.NoInline SourceText
srcText = SourceText -> InlineSpec
Hs.NoInline SourceText
srcText
cvtInline Inline
TH.Inline SourceText
srcText = SourceText -> InlineSpec
Hs.Inline SourceText
srcText
cvtInline Inline
TH.Inlinable SourceText
srcText = SourceText -> InlineSpec
Hs.Inlinable SourceText
srcText
cvtRuleMatch :: TH.RuleMatch -> RuleMatchInfo
cvtRuleMatch :: RuleMatch -> RuleMatchInfo
cvtRuleMatch RuleMatch
TH.ConLike = RuleMatchInfo
Hs.ConLike
cvtRuleMatch RuleMatch
TH.FunLike = RuleMatchInfo
Hs.FunLike
cvtPhases :: TH.Phases -> Activation -> Activation
cvtPhases :: Phases -> Activation -> Activation
cvtPhases Phases
AllPhases Activation
dflt = Activation
dflt
cvtPhases (FromPhase Int
i) Activation
_ = SourceText -> Int -> Activation
ActiveAfter SourceText
NoSourceText Int
i
cvtPhases (BeforePhase Int
i) Activation
_ = SourceText -> Int -> Activation
ActiveBefore SourceText
NoSourceText Int
i
cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.LRuleBndr GhcPs)
cvtRuleBndr :: RuleBndr -> CvtM (LRuleBndr (GhcPass 'Parsed))
cvtRuleBndr (RuleVar Name
n)
= do { LocatedN RdrName
n' <- Name -> CvtM (LocatedN RdrName)
vNameN Name
n
; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ forall pass. XCRuleBndr pass -> LIdP pass -> RuleBndr pass
Hs.RuleBndr forall a. EpAnn a
noAnn LocatedN RdrName
n' }
cvtRuleBndr (TypedRuleVar Name
n Type
ty)
= do { LocatedN RdrName
n' <- Name -> CvtM (LocatedN RdrName)
vNameN Name
n
; GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
ty' <- Type -> CvtM (LHsType (GhcPass 'Parsed))
cvtType Type
ty
; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ forall pass.
XRuleBndrSig pass
-> LIdP pass -> HsPatSigType pass -> RuleBndr pass
Hs.RuleBndrSig forall a. EpAnn a
noAnn LocatedN RdrName
n' forall a b. (a -> b) -> a -> b
$ EpAnn EpaLocation
-> LHsType (GhcPass 'Parsed) -> HsPatSigType (GhcPass 'Parsed)
mkHsPatSigType forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
ty' }
cvtLocalDecs :: SDoc -> [TH.Dec] -> CvtM (HsLocalBinds GhcPs)
cvtLocalDecs :: SDoc -> [Dec] -> CvtM (HsLocalBinds (GhcPass 'Parsed))
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 (GhcPass 'Parsed))]
ds' <- [Dec] -> CvtM [LHsDecl (GhcPass 'Parsed)]
cvtDecs [Dec]
ds
let ([GenLocated SrcSpanAnnA (HsBind (GhcPass 'Parsed))]
binds, [GenLocated SrcSpanAnnA (HsDecl (GhcPass 'Parsed))]
prob_sigs) = forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
partitionWith LHsDecl (GhcPass 'Parsed)
-> Either (LHsBind (GhcPass 'Parsed)) (LHsDecl (GhcPass 'Parsed))
is_bind [GenLocated SrcSpanAnnA (HsDecl (GhcPass 'Parsed))]
ds'
let ([GenLocated SrcSpanAnnA (Sig (GhcPass 'Parsed))]
sigs, [GenLocated SrcSpanAnnA (HsDecl (GhcPass 'Parsed))]
bads) = forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
partitionWith LHsDecl (GhcPass 'Parsed)
-> Either (LSig (GhcPass 'Parsed)) (LHsDecl (GhcPass 'Parsed))
is_sig [GenLocated SrcSpanAnnA (HsDecl (GhcPass 'Parsed))]
prob_sigs
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated SrcSpanAnnA (HsDecl (GhcPass 'Parsed))]
bads) (forall a. SDoc -> CvtM a
failWith (forall a. Outputable a => SDoc -> [a] -> SDoc
mkBadDecMsg SDoc
doc [GenLocated SrcSpanAnnA (HsDecl (GhcPass 'Parsed))]
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 (GhcPass 'Parsed))]
binds) [GenLocated SrcSpanAnnA (Sig (GhcPass 'Parsed))]
sigs))
([(String, Exp)]
ip_binds, []) -> do
[GenLocated SrcSpanAnnA (IPBind (GhcPass 'Parsed))]
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 (GhcPass 'Parsed))
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 (GhcPass 'Parsed))]
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 (GhcPass 'Parsed)
-> Clause
-> CvtM (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
cvtClause HsMatchContext (GhcPass 'Parsed)
ctxt (Clause [Pat]
ps Body
body [Dec]
wheres)
= do { [GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
ps' <- [Pat] -> CvtM [LPat (GhcPass 'Parsed)]
cvtPats [Pat]
ps
; let pps :: [GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
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 (GhcPass 'Parsed))]
ps'
; [GenLocated
(SrcAnn NoEpAnns)
(GRHS (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
g' <- Body -> CvtM [LGRHS (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
cvtGuard Body
body
; HsLocalBinds (GhcPass 'Parsed)
ds' <- SDoc -> [Dec] -> CvtM (HsLocalBinds (GhcPass 'Parsed))
cvtLocalDecs (String -> SDoc
text String
"a where clause") [Dec]
wheres
; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ forall p body.
XCMatch p body
-> HsMatchContext p -> [LPat p] -> GRHSs p body -> Match p body
Hs.Match forall a. EpAnn a
noAnn HsMatchContext (GhcPass 'Parsed)
ctxt [GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
pps (forall p body.
XCGRHSs p body -> [LGRHS p body] -> HsLocalBinds p -> GRHSs p body
GRHSs EpAnnComments
emptyComments [GenLocated
(SrcAnn NoEpAnns)
(GRHS (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
g' HsLocalBinds (GhcPass 'Parsed)
ds') }
cvtImplicitParamBind :: String -> TH.Exp -> CvtM (LIPBind GhcPs)
cvtImplicitParamBind :: String -> Exp -> CvtM (LIPBind (GhcPass 'Parsed))
cvtImplicitParamBind String
n Exp
e = do
Located HsIPName
n' <- forall a. CvtM a -> CvtM (Located a)
wrapL (String -> CvtM HsIPName
ipName String
n)
LocatedA (HsExpr (GhcPass 'Parsed))
e' <- Exp -> CvtM (LHsExpr (GhcPass 'Parsed))
cvtl Exp
e
forall e ann. e -> CvtM (LocatedAn ann e)
returnLA (forall id.
XCIPBind id -> XRec id HsIPName -> LHsExpr id -> IPBind id
IPBind forall a. EpAnn a
noAnn (forall e ann. Located e -> LocatedAn ann e
reLocA Located HsIPName
n') LocatedA (HsExpr (GhcPass 'Parsed))
e')
cvtl :: TH.Exp -> CvtM (LHsExpr GhcPs)
cvtl :: Exp -> CvtM (LHsExpr (GhcPass 'Parsed))
cvtl Exp
e = forall a. CvtM a -> CvtM (LocatedA a)
wrapLA (Exp -> CvtM (HsExpr (GhcPass 'Parsed))
cvt Exp
e)
where
cvt :: Exp -> CvtM (HsExpr (GhcPass 'Parsed))
cvt (VarE Name
s) = do { RdrName
s' <- Name -> CvtM RdrName
vName Name
s; forall ann a b. (LocatedAn ann a -> b) -> a -> CvtM b
wrapParLA (forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
noExtField) RdrName
s' }
cvt (ConE Name
s) = do { RdrName
s' <- Name -> CvtM RdrName
cName Name
s; forall ann a b. (LocatedAn ann a -> b) -> a -> CvtM b
wrapParLA (forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
noExtField) RdrName
s' }
cvt (LitE Lit
l)
| Lit -> Bool
overloadedLit Lit
l = forall (l :: * -> *).
(Lit -> CvtM (l (GhcPass 'Parsed)))
-> (l (GhcPass 'Parsed) -> HsExpr (GhcPass 'Parsed))
-> (l (GhcPass 'Parsed) -> Bool)
-> CvtM (HsExpr (GhcPass 'Parsed))
go Lit -> CvtM (HsOverLit (GhcPass 'Parsed))
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 (GhcPass 'Parsed)))
-> (l (GhcPass 'Parsed) -> HsExpr (GhcPass 'Parsed))
-> (l (GhcPass 'Parsed) -> Bool)
-> CvtM (HsExpr (GhcPass 'Parsed))
go Lit -> CvtM (HsLit (GhcPass 'Parsed))
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 (GhcPass 'Parsed)))
-> (l (GhcPass 'Parsed) -> HsExpr (GhcPass 'Parsed))
-> (l (GhcPass 'Parsed) -> Bool)
-> CvtM (HsExpr (GhcPass 'Parsed))
go Lit -> CvtM (l (GhcPass 'Parsed))
cvt_lit l (GhcPass 'Parsed) -> HsExpr (GhcPass 'Parsed)
mk_expr l (GhcPass 'Parsed) -> Bool
is_compound_lit = do
l (GhcPass 'Parsed)
l' <- Lit -> CvtM (l (GhcPass 'Parsed))
cvt_lit Lit
l
let e' :: HsExpr (GhcPass 'Parsed)
e' = l (GhcPass 'Parsed) -> HsExpr (GhcPass 'Parsed)
mk_expr l (GhcPass 'Parsed)
l'
if l (GhcPass 'Parsed) -> Bool
is_compound_lit l (GhcPass 'Parsed)
l' then forall ann a b. (LocatedAn ann a -> b) -> a -> CvtM b
wrapParLA forall (id :: Pass). LHsExpr (GhcPass id) -> HsExpr (GhcPass id)
gHsPar HsExpr (GhcPass 'Parsed)
e' else forall (f :: * -> *) a. Applicative f => a -> f a
pure HsExpr (GhcPass 'Parsed)
e'
cvt (AppE x :: Exp
x@(LamE [Pat]
_ Exp
_) Exp
y) = do { LocatedA (HsExpr (GhcPass 'Parsed))
x' <- Exp -> CvtM (LHsExpr (GhcPass 'Parsed))
cvtl Exp
x; LocatedA (HsExpr (GhcPass 'Parsed))
y' <- Exp -> CvtM (LHsExpr (GhcPass 'Parsed))
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 LocatedA (HsExpr (GhcPass 'Parsed))
x')
(forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkLHsPar LocatedA (HsExpr (GhcPass 'Parsed))
y')}
cvt (AppE Exp
x Exp
y) = do { LocatedA (HsExpr (GhcPass 'Parsed))
x' <- Exp -> CvtM (LHsExpr (GhcPass 'Parsed))
cvtl Exp
x; LocatedA (HsExpr (GhcPass 'Parsed))
y' <- Exp -> CvtM (LHsExpr (GhcPass 'Parsed))
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 LocatedA (HsExpr (GhcPass 'Parsed))
x')
(forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkLHsPar LocatedA (HsExpr (GhcPass 'Parsed))
y')}
cvt (AppTypeE Exp
e Type
t) = do { LocatedA (HsExpr (GhcPass 'Parsed))
e' <- Exp -> CvtM (LHsExpr (GhcPass 'Parsed))
cvtl Exp
e
; GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
t' <- Type -> CvtM (LHsType (GhcPass 'Parsed))
cvtType Type
t
; let tp :: LHsType (GhcPass 'Parsed)
tp = forall (p :: Pass).
PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)
parenthesizeHsType PprPrec
appPrec GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
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 LocatedA (HsExpr (GhcPass 'Parsed))
e'
forall a b. (a -> b) -> a -> b
$ forall thing. thing -> HsWildCardBndrs (GhcPass 'Parsed) thing
mkHsWildCardBndrs LHsType (GhcPass 'Parsed)
tp }
cvt (LamE [] Exp
e) = Exp -> CvtM (HsExpr (GhcPass 'Parsed))
cvt Exp
e
cvt (LamE [Pat]
ps Exp
e) = do { [GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
ps' <- [Pat] -> CvtM [LPat (GhcPass 'Parsed)]
cvtPats [Pat]
ps; LocatedA (HsExpr (GhcPass 'Parsed))
e' <- Exp -> CvtM (LHsExpr (GhcPass 'Parsed))
cvtl Exp
e
; let pats :: [GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
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 (GhcPass 'Parsed))]
ps'
; Origin
th_origin <- CvtM Origin
getOrigin
; forall ann a b. (LocatedAn ann a -> b) -> a -> CvtM b
wrapParLA (forall p. XLam p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLam NoExtField
noExtField forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: Pass) (body :: * -> *).
AnnoBody p body =>
Origin
-> LocatedL
[LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]
-> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))
mkMatchGroup Origin
th_origin)
[forall (p :: Pass) (body :: * -> *).
(Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcSpanAnnA,
Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcAnn NoEpAnns) =>
HsMatchContext (GhcPass p)
-> [LPat (GhcPass p)]
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkSimpleMatch forall p. HsMatchContext p
LambdaExpr [GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
pats LocatedA (HsExpr (GhcPass 'Parsed))
e']}
cvt (LamCaseE [Match]
ms) = do { [GenLocated
SrcSpanAnnA
(Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
ms' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (HsMatchContext (GhcPass 'Parsed)
-> Match
-> CvtM (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
cvtMatch forall a b. (a -> b) -> a -> b
$ forall p. LamCaseVariant -> HsMatchContext p
LamCaseAlt LamCaseVariant
LamCase) [Match]
ms
; Origin
th_origin <- CvtM Origin
getOrigin
; forall ann a b. (LocatedAn ann a -> b) -> a -> CvtM b
wrapParLA (forall p.
XLamCase p
-> LamCaseVariant -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLamCase forall a. EpAnn a
noAnn LamCaseVariant
LamCase forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: Pass) (body :: * -> *).
AnnoBody p body =>
Origin
-> LocatedL
[LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]
-> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))
mkMatchGroup Origin
th_origin) [GenLocated
SrcSpanAnnA
(Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
ms'
}
cvt (LamCasesE [Clause]
ms)
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Clause]
ms = forall a. SDoc -> CvtM a
failWith (String -> SDoc
text String
"\\cases expression with no alternatives")
| Bool
otherwise = do { [GenLocated
SrcSpanAnnA
(Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
ms' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (HsMatchContext (GhcPass 'Parsed)
-> Clause
-> CvtM (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
cvtClause forall a b. (a -> b) -> a -> b
$ forall p. LamCaseVariant -> HsMatchContext p
LamCaseAlt LamCaseVariant
LamCases) [Clause]
ms
; Origin
th_origin <- CvtM Origin
getOrigin
; forall ann a b. (LocatedAn ann a -> b) -> a -> CvtM b
wrapParLA (forall p.
XLamCase p
-> LamCaseVariant -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLamCase forall a. EpAnn a
noAnn LamCaseVariant
LamCases forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: Pass) (body :: * -> *).
AnnoBody p body =>
Origin
-> LocatedL
[LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]
-> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))
mkMatchGroup Origin
th_origin) [GenLocated
SrcSpanAnnA
(Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
ms'
}
cvt (TupE [Maybe Exp]
es) = [Maybe Exp] -> Boxity -> CvtM (HsExpr (GhcPass 'Parsed))
cvt_tup [Maybe Exp]
es Boxity
Boxed
cvt (UnboxedTupE [Maybe Exp]
es) = [Maybe Exp] -> Boxity -> CvtM (HsExpr (GhcPass 'Parsed))
cvt_tup [Maybe Exp]
es Boxity
Unboxed
cvt (UnboxedSumE Exp
e Int
alt Int
arity) = do { LocatedA (HsExpr (GhcPass 'Parsed))
e' <- Exp -> CvtM (LHsExpr (GhcPass 'Parsed))
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 LocatedA (HsExpr (GhcPass 'Parsed))
e'}
cvt (CondE Exp
x Exp
y Exp
z) = do { LocatedA (HsExpr (GhcPass 'Parsed))
x' <- Exp -> CvtM (LHsExpr (GhcPass 'Parsed))
cvtl Exp
x; LocatedA (HsExpr (GhcPass 'Parsed))
y' <- Exp -> CvtM (LHsExpr (GhcPass 'Parsed))
cvtl Exp
y; LocatedA (HsExpr (GhcPass 'Parsed))
z' <- Exp -> CvtM (LHsExpr (GhcPass 'Parsed))
cvtl Exp
z;
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> EpAnn AnnsIf
-> HsExpr (GhcPass 'Parsed)
mkHsIf LocatedA (HsExpr (GhcPass 'Parsed))
x' LocatedA (HsExpr (GhcPass 'Parsed))
y' LocatedA (HsExpr (GhcPass 'Parsed))
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
(SrcAnn NoEpAnns)
(GRHS (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
alts' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Guard, Exp)
-> CvtM (LGRHS (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
cvtpair [(Guard, Exp)]
alts
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p. XMultiIf p -> [LGRHS p (LHsExpr p)] -> HsExpr p
HsMultiIf forall a. EpAnn a
noAnn [GenLocated
(SrcAnn NoEpAnns)
(GRHS (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
alts' }
cvt (LetE [Dec]
ds Exp
e) = do { HsLocalBinds (GhcPass 'Parsed)
ds' <- SDoc -> [Dec] -> CvtM (HsLocalBinds (GhcPass 'Parsed))
cvtLocalDecs (String -> SDoc
text String
"a let expression") [Dec]
ds
; LocatedA (HsExpr (GhcPass 'Parsed))
e' <- Exp -> CvtM (LHsExpr (GhcPass 'Parsed))
cvtl Exp
e; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p.
XLet p
-> LHsToken "let" p
-> HsLocalBinds p
-> LHsToken "in" p
-> LHsExpr p
-> HsExpr p
HsLet forall a. EpAnn a
noAnn forall (tok :: Symbol). GenLocated TokenLocation (HsToken tok)
noHsTok HsLocalBinds (GhcPass 'Parsed)
ds' forall (tok :: Symbol). GenLocated TokenLocation (HsToken tok)
noHsTok LocatedA (HsExpr (GhcPass 'Parsed))
e'}
cvt (CaseE Exp
e [Match]
ms) = do { LocatedA (HsExpr (GhcPass 'Parsed))
e' <- Exp -> CvtM (LHsExpr (GhcPass 'Parsed))
cvtl Exp
e; [GenLocated
SrcSpanAnnA
(Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
ms' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (HsMatchContext (GhcPass 'Parsed)
-> Match
-> CvtM (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
cvtMatch forall p. HsMatchContext p
CaseAlt) [Match]
ms
; Origin
th_origin <- CvtM Origin
getOrigin
; forall ann a b. (LocatedAn ann a -> b) -> a -> CvtM b
wrapParLA (forall p.
XCase p -> LHsExpr p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsCase forall a. EpAnn a
noAnn LocatedA (HsExpr (GhcPass 'Parsed))
e' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: Pass) (body :: * -> *).
AnnoBody p body =>
Origin
-> LocatedL
[LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]
-> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))
mkMatchGroup Origin
th_origin) [GenLocated
SrcSpanAnnA
(Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
ms' }
cvt (DoE Maybe ModName
m [Stmt]
ss) = HsDoFlavour -> [Stmt] -> CvtM (HsExpr (GhcPass 'Parsed))
cvtHsDo (Maybe ModuleName -> HsDoFlavour
DoExpr (ModName -> ModuleName
mk_mod forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ModName
m)) [Stmt]
ss
cvt (MDoE Maybe ModName
m [Stmt]
ss) = HsDoFlavour -> [Stmt] -> CvtM (HsExpr (GhcPass 'Parsed))
cvtHsDo (Maybe ModuleName -> HsDoFlavour
MDoExpr (ModName -> ModuleName
mk_mod forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ModName
m)) [Stmt]
ss
cvt (CompE [Stmt]
ss) = HsDoFlavour -> [Stmt] -> CvtM (HsExpr (GhcPass 'Parsed))
cvtHsDo HsDoFlavour
ListComp [Stmt]
ss
cvt (ArithSeqE Range
dd) = do { ArithSeqInfo (GhcPass 'Parsed)
dd' <- Range -> CvtM (ArithSeqInfo (GhcPass 'Parsed))
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 (GhcPass 'Parsed)
dd' }
cvt (ListE [Exp]
xs)
| Just String
s <- [Exp] -> Maybe String
allCharLs [Exp]
xs = do { HsLit (GhcPass 'Parsed)
l' <- Lit -> CvtM (HsLit (GhcPass 'Parsed))
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 (GhcPass 'Parsed)
l') }
| Bool
otherwise = do { [LocatedA (HsExpr (GhcPass 'Parsed))]
xs' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Exp -> CvtM (LHsExpr (GhcPass 'Parsed))
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 [LocatedA (HsExpr (GhcPass 'Parsed))]
xs'
}
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 { LocatedA (HsExpr (GhcPass 'Parsed))
x' <- Exp -> CvtM (LHsExpr (GhcPass 'Parsed))
cvtl Exp
x
; LocatedA (HsExpr (GhcPass 'Parsed))
s' <- Exp -> CvtM (LHsExpr (GhcPass 'Parsed))
cvtl Exp
s
; LocatedA (HsExpr (GhcPass 'Parsed))
y' <- Exp -> CvtM (LHsExpr (GhcPass 'Parsed))
cvtl Exp
y
; let px :: LHsExpr (GhcPass 'Parsed)
px = forall (p :: Pass).
IsPass p =>
PprPrec -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
parenthesizeHsExpr PprPrec
opPrec LocatedA (HsExpr (GhcPass 'Parsed))
x'
py :: LHsExpr (GhcPass 'Parsed)
py = forall (p :: Pass).
IsPass p =>
PprPrec -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
parenthesizeHsExpr PprPrec
opPrec LocatedA (HsExpr (GhcPass 'Parsed))
y'
; forall ann a b. (LocatedAn ann a -> b) -> a -> CvtM b
wrapParLA forall (id :: Pass). LHsExpr (GhcPass id) -> HsExpr (GhcPass id)
gHsPar
forall a b. (a -> b) -> a -> b
$ forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp forall a. EpAnn a
noAnn LHsExpr (GhcPass 'Parsed)
px LocatedA (HsExpr (GhcPass 'Parsed))
s' LHsExpr (GhcPass 'Parsed)
py }
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 { LocatedA (HsExpr (GhcPass 'Parsed))
s' <- Exp -> CvtM (LHsExpr (GhcPass 'Parsed))
cvtl Exp
s; LocatedA (HsExpr (GhcPass 'Parsed))
y' <- Exp -> CvtM (LHsExpr (GhcPass 'Parsed))
cvtl Exp
y
; forall ann a b. (LocatedAn ann a -> b) -> a -> CvtM b
wrapParLA forall (id :: Pass). LHsExpr (GhcPass id) -> HsExpr (GhcPass id)
gHsPar forall a b. (a -> b) -> a -> b
$
forall p. XSectionR p -> LHsExpr p -> LHsExpr p -> HsExpr p
SectionR EpAnnCO
noComments LocatedA (HsExpr (GhcPass 'Parsed))
s' LocatedA (HsExpr (GhcPass 'Parsed))
y' }
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 { LocatedA (HsExpr (GhcPass 'Parsed))
x' <- Exp -> CvtM (LHsExpr (GhcPass 'Parsed))
cvtl Exp
x; LocatedA (HsExpr (GhcPass 'Parsed))
s' <- Exp -> CvtM (LHsExpr (GhcPass 'Parsed))
cvtl Exp
s
; forall ann a b. (LocatedAn ann a -> b) -> a -> CvtM b
wrapParLA forall (id :: Pass). LHsExpr (GhcPass id) -> HsExpr (GhcPass id)
gHsPar forall a b. (a -> b) -> a -> b
$
forall p. XSectionL p -> LHsExpr p -> LHsExpr p -> HsExpr p
SectionL EpAnnCO
noComments LocatedA (HsExpr (GhcPass 'Parsed))
x' LocatedA (HsExpr (GhcPass 'Parsed))
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 { LocatedA (HsExpr (GhcPass 'Parsed))
s' <- Exp -> CvtM (LHsExpr (GhcPass 'Parsed))
cvtl Exp
s
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (id :: Pass). LHsExpr (GhcPass id) -> HsExpr (GhcPass id)
gHsPar LocatedA (HsExpr (GhcPass 'Parsed))
s' }
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 { LocatedA (HsExpr (GhcPass 'Parsed))
x' <- Exp -> CvtM (LHsExpr (GhcPass 'Parsed))
cvtl Exp
x
; let x'' :: LocatedA (HsExpr (GhcPass 'Parsed))
x'' = case forall l e. GenLocated l e -> e
unLoc LocatedA (HsExpr (GhcPass 'Parsed))
x' of
OpApp {} -> LocatedA (HsExpr (GhcPass 'Parsed))
x'
HsExpr (GhcPass 'Parsed)
_ -> forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkLHsPar LocatedA (HsExpr (GhcPass 'Parsed))
x'
; LHsExpr (GhcPass 'Parsed)
-> Exp -> Exp -> CvtM (HsExpr (GhcPass 'Parsed))
cvtOpApp LocatedA (HsExpr (GhcPass 'Parsed))
x'' Exp
s Exp
y }
cvt (ParensE Exp
e) = do { LocatedA (HsExpr (GhcPass 'Parsed))
e' <- Exp -> CvtM (LHsExpr (GhcPass 'Parsed))
cvtl Exp
e; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (id :: Pass). LHsExpr (GhcPass id) -> HsExpr (GhcPass id)
gHsPar LocatedA (HsExpr (GhcPass 'Parsed))
e' }
cvt (SigE Exp
e Type
t) = do { LocatedA (HsExpr (GhcPass 'Parsed))
e' <- Exp -> CvtM (LHsExpr (GhcPass 'Parsed))
cvtl Exp
e; GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Parsed))
t' <- Type -> CvtM (LHsSigType (GhcPass 'Parsed))
cvtSigType Type
t
; let pe :: LHsExpr (GhcPass 'Parsed)
pe = forall (p :: Pass).
IsPass p =>
PprPrec -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
parenthesizeHsExpr PprPrec
sigPrec LocatedA (HsExpr (GhcPass 'Parsed))
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 (GhcPass 'Parsed)
pe (forall thing. thing -> HsWildCardBndrs (GhcPass 'Parsed) thing
mkHsWildCardBndrs GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Parsed))
t') }
cvt (RecConE Name
c [FieldExp]
flds) = do { LocatedN RdrName
c' <- Name -> CvtM (LocatedN RdrName)
cNameN Name
c
; [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc (GhcPass 'Parsed)))
(LocatedA (HsExpr (GhcPass 'Parsed))))]
flds' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall t.
(RdrName -> CvtM t)
-> FieldExp
-> CvtM
(LHsFieldBind
(GhcPass 'Parsed)
(LocatedAn NoEpAnns t)
(LHsExpr (GhcPass 'Parsed)))
cvtFld (forall ann a b. (LocatedAn ann a -> b) -> a -> CvtM b
wrapParLA LocatedN RdrName -> FieldOcc (GhcPass 'Parsed)
mkFieldOcc)) [FieldExp]
flds
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ LocatedN RdrName
-> HsRecordBinds (GhcPass 'Parsed)
-> EpAnn [AddEpAnn]
-> HsExpr (GhcPass 'Parsed)
mkRdrRecordCon LocatedN RdrName
c' (forall p arg.
[LHsRecField p arg] -> Maybe (Located Int) -> HsRecFields p arg
HsRecFields [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc (GhcPass 'Parsed)))
(LocatedA (HsExpr (GhcPass 'Parsed))))]
flds' forall a. Maybe a
Nothing) forall a. EpAnn a
noAnn }
cvt (RecUpdE Exp
e [FieldExp]
flds) = do { LocatedA (HsExpr (GhcPass 'Parsed))
e' <- Exp -> CvtM (LHsExpr (GhcPass 'Parsed))
cvtl Exp
e
; [GenLocated
SrcSpanAnnA
(HsFieldBind
(LocatedAn NoEpAnns (AmbiguousFieldOcc (GhcPass 'Parsed)))
(LocatedA (HsExpr (GhcPass 'Parsed))))]
flds'
<- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall t.
(RdrName -> CvtM t)
-> FieldExp
-> CvtM
(LHsFieldBind
(GhcPass 'Parsed)
(LocatedAn NoEpAnns t)
(LHsExpr (GhcPass 'Parsed)))
cvtFld (forall ann a b. (LocatedAn ann a -> b) -> a -> CvtM b
wrapParLA LocatedN RdrName -> AmbiguousFieldOcc (GhcPass 'Parsed)
mkAmbiguousFieldOcc))
[FieldExp]
flds
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p.
XRecordUpd p
-> LHsExpr p
-> Either [LHsRecUpdField p] [LHsRecUpdProj p]
-> HsExpr p
RecordUpd forall a. EpAnn a
noAnn LocatedA (HsExpr (GhcPass 'Parsed))
e' (forall a b. a -> Either a b
Left [GenLocated
SrcSpanAnnA
(HsFieldBind
(LocatedAn NoEpAnns (AmbiguousFieldOcc (GhcPass 'Parsed)))
(LocatedA (HsExpr (GhcPass 'Parsed))))]
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 (GhcPass 'Parsed))
cvtl Exp
e
cvt (UnboundVarE Name
s) = do
{ RdrName
s' <- Name -> CvtM RdrName
vcName Name
s
; forall ann a b. (LocatedAn ann a -> b) -> a -> CvtM b
wrapParLA (forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
noExtField) RdrName
s' }
cvt (LabelE String
s) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p. XOverLabel p -> 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 { LocatedA (HsExpr (GhcPass 'Parsed))
e' <- Exp -> CvtM (LHsExpr (GhcPass 'Parsed))
cvtl Exp
exp
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p.
XGetField p -> LHsExpr p -> XRec p (DotFieldOcc p) -> HsExpr p
HsGetField EpAnnCO
noComments LocatedA (HsExpr (GhcPass 'Parsed))
e' (forall l e. l -> e -> GenLocated l e
L forall ann. SrcAnn ann
noSrcSpanA (forall p. XCDotFieldOcc p -> XRec p CLabelString -> DotFieldOcc p
DotFieldOcc forall a. EpAnn a
noAnn (forall l e. l -> e -> GenLocated l e
L forall ann. SrcAnn ann
noSrcSpanA (String -> CLabelString
fsLit String
f)))) }
cvt (ProjectionE NonEmpty String
xs) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p.
XProjection p -> NonEmpty (XRec p (DotFieldOcc p)) -> HsExpr p
HsProjection forall a. EpAnn a
noAnn forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall l e. l -> e -> GenLocated l e
L forall ann. SrcAnn ann
noSrcSpanA forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p. XCDotFieldOcc p -> XRec p CLabelString -> DotFieldOcc p
DotFieldOcc forall a. EpAnn a
noAnn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. l -> e -> GenLocated l e
L forall ann. SrcAnn ann
noSrcSpanA forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> CLabelString
fsLit) NonEmpty String
xs
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")
cvtFld :: (RdrName -> CvtM t) -> (TH.Name, TH.Exp)
-> CvtM (LHsFieldBind GhcPs (LocatedAn NoEpAnns t) (LHsExpr GhcPs))
cvtFld :: forall t.
(RdrName -> CvtM t)
-> FieldExp
-> CvtM
(LHsFieldBind
(GhcPass 'Parsed)
(LocatedAn NoEpAnns t)
(LHsExpr (GhcPass 'Parsed)))
cvtFld RdrName -> CvtM t
f (Name
v,Exp
e)
= do { LocatedA RdrName
v' <- Name -> CvtM (LocatedA RdrName)
vNameL Name
v
; GenLocated SrcSpanAnnA t
lhs' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse RdrName -> CvtM t
f LocatedA RdrName
v'
; LocatedA (HsExpr (GhcPass 'Parsed))
e' <- Exp -> CvtM (LHsExpr (GhcPass 'Parsed))
cvtl Exp
e
; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ HsFieldBind { hfbAnn :: XHsFieldBind (LocatedAn NoEpAnns t)
hfbAnn = forall a. EpAnn a
noAnn
, hfbLHS :: LocatedAn NoEpAnns t
hfbLHS = forall ann1 a2 ann2. LocatedAn ann1 a2 -> LocatedAn ann2 a2
la2la GenLocated SrcSpanAnnA t
lhs'
, hfbRHS :: LocatedA (HsExpr (GhcPass 'Parsed))
hfbRHS = LocatedA (HsExpr (GhcPass 'Parsed))
e'
, hfbPun :: Bool
hfbPun = Bool
False} }
cvtDD :: Range -> CvtM (ArithSeqInfo GhcPs)
cvtDD :: Range -> CvtM (ArithSeqInfo (GhcPass 'Parsed))
cvtDD (FromR Exp
x) = do { LocatedA (HsExpr (GhcPass 'Parsed))
x' <- Exp -> CvtM (LHsExpr (GhcPass 'Parsed))
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 LocatedA (HsExpr (GhcPass 'Parsed))
x' }
cvtDD (FromThenR Exp
x Exp
y) = do { LocatedA (HsExpr (GhcPass 'Parsed))
x' <- Exp -> CvtM (LHsExpr (GhcPass 'Parsed))
cvtl Exp
x; LocatedA (HsExpr (GhcPass 'Parsed))
y' <- Exp -> CvtM (LHsExpr (GhcPass 'Parsed))
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 LocatedA (HsExpr (GhcPass 'Parsed))
x' LocatedA (HsExpr (GhcPass 'Parsed))
y' }
cvtDD (FromToR Exp
x Exp
y) = do { LocatedA (HsExpr (GhcPass 'Parsed))
x' <- Exp -> CvtM (LHsExpr (GhcPass 'Parsed))
cvtl Exp
x; LocatedA (HsExpr (GhcPass 'Parsed))
y' <- Exp -> CvtM (LHsExpr (GhcPass 'Parsed))
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 LocatedA (HsExpr (GhcPass 'Parsed))
x' LocatedA (HsExpr (GhcPass 'Parsed))
y' }
cvtDD (FromThenToR Exp
x Exp
y Exp
z) = do { LocatedA (HsExpr (GhcPass 'Parsed))
x' <- Exp -> CvtM (LHsExpr (GhcPass 'Parsed))
cvtl Exp
x; LocatedA (HsExpr (GhcPass 'Parsed))
y' <- Exp -> CvtM (LHsExpr (GhcPass 'Parsed))
cvtl Exp
y; LocatedA (HsExpr (GhcPass 'Parsed))
z' <- Exp -> CvtM (LHsExpr (GhcPass 'Parsed))
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 LocatedA (HsExpr (GhcPass 'Parsed))
x' LocatedA (HsExpr (GhcPass 'Parsed))
y' LocatedA (HsExpr (GhcPass 'Parsed))
z' }
cvt_tup :: [Maybe Exp] -> Boxity -> CvtM (HsExpr GhcPs)
cvt_tup :: [Maybe Exp] -> Boxity -> CvtM (HsExpr (GhcPass 'Parsed))
cvt_tup [Maybe Exp]
es Boxity
boxity = do { let cvtl_maybe :: Maybe Exp -> CvtM (HsTupArg (GhcPass 'Parsed))
cvtl_maybe Maybe Exp
Nothing = forall (m :: * -> *) a. Monad m => a -> m a
return (EpAnn EpaLocation -> HsTupArg (GhcPass 'Parsed)
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 (GhcPass 'Parsed))
cvtl Exp
e)
; [HsTupArg (GhcPass 'Parsed)]
es' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Maybe Exp -> CvtM (HsTupArg (GhcPass 'Parsed))
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 (GhcPass 'Parsed)]
es'
Boxity
boxity }
cvtOpApp :: LHsExpr GhcPs -> TH.Exp -> TH.Exp -> CvtM (HsExpr GhcPs)
cvtOpApp :: LHsExpr (GhcPass 'Parsed)
-> Exp -> Exp -> CvtM (HsExpr (GhcPass 'Parsed))
cvtOpApp LHsExpr (GhcPass 'Parsed)
x Exp
op1 (UInfixE Exp
y Exp
op2 Exp
z)
= do { LocatedA (HsExpr (GhcPass 'Parsed))
l <- forall a. CvtM a -> CvtM (LocatedA a)
wrapLA forall a b. (a -> b) -> a -> b
$ LHsExpr (GhcPass 'Parsed)
-> Exp -> Exp -> CvtM (HsExpr (GhcPass 'Parsed))
cvtOpApp LHsExpr (GhcPass 'Parsed)
x Exp
op1 Exp
y
; LHsExpr (GhcPass 'Parsed)
-> Exp -> Exp -> CvtM (HsExpr (GhcPass 'Parsed))
cvtOpApp LocatedA (HsExpr (GhcPass 'Parsed))
l Exp
op2 Exp
z }
cvtOpApp LHsExpr (GhcPass 'Parsed)
x Exp
op Exp
y
= do { LocatedA (HsExpr (GhcPass 'Parsed))
op' <- Exp -> CvtM (LHsExpr (GhcPass 'Parsed))
cvtl Exp
op
; LocatedA (HsExpr (GhcPass 'Parsed))
y' <- Exp -> CvtM (LHsExpr (GhcPass 'Parsed))
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 (GhcPass 'Parsed)
x LocatedA (HsExpr (GhcPass 'Parsed))
op' LocatedA (HsExpr (GhcPass 'Parsed))
y') }
cvtHsDo :: HsDoFlavour -> [TH.Stmt] -> CvtM (HsExpr GhcPs)
cvtHsDo :: HsDoFlavour -> [Stmt] -> CvtM (HsExpr (GhcPass 'Parsed))
cvtHsDo HsDoFlavour
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
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))]
stmts' <- [Stmt]
-> CvtM [LStmt (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
cvtStmts [Stmt]
stmts
; let Just ([GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))]
stmts'', GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))
last') = forall a. [a] -> Maybe ([a], a)
snocView [GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))]
stmts'
; GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))
last'' <- case GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))
last' of
(L SrcSpanAnnA
loc (BodyStmt XBodyStmt
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed)))
_ LocatedA (HsExpr (GhcPass 'Parsed))
body SyntaxExpr (GhcPass 'Parsed)
_ SyntaxExpr (GhcPass 'Parsed)
_))
-> 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 LocatedA (HsExpr (GhcPass 'Parsed))
body))
GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))
_ -> forall a. SDoc -> CvtM a
failWith (GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))
-> SDoc
bad_last GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))
last')
; forall ann a b. (LocatedAn ann a -> b) -> a -> CvtM b
wrapParLA (forall p. XDo p -> HsDoFlavour -> XRec p [ExprLStmt p] -> HsExpr p
HsDo forall a. EpAnn a
noAnn HsDoFlavour
do_or_lc) ([GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))]
stmts'' forall a. [a] -> [a] -> [a]
++ [GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))
last'']) }
where
bad_last :: GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))
-> SDoc
bad_last GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))
stmt = [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Illegal last statement of" SDoc -> SDoc -> SDoc
<+> HsDoFlavour -> SDoc
pprAHsDoFlavour HsDoFlavour
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
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))
stmt
, String -> SDoc
text String
"(It should be an expression.)" ]
cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt GhcPs (LHsExpr GhcPs)]
cvtStmts :: [Stmt]
-> CvtM [LStmt (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
cvtStmts = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Stmt -> CvtM (LStmt (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
cvtStmt
cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt GhcPs (LHsExpr GhcPs))
cvtStmt :: Stmt -> CvtM (LStmt (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
cvtStmt (NoBindS Exp
e) = do { LocatedA (HsExpr (GhcPass 'Parsed))
e' <- Exp -> CvtM (LHsExpr (GhcPass 'Parsed))
cvtl Exp
e; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ forall (bodyR :: * -> *) (idL :: Pass).
LocatedA (bodyR (GhcPass 'Parsed))
-> StmtLR
(GhcPass idL)
(GhcPass 'Parsed)
(LocatedA (bodyR (GhcPass 'Parsed)))
mkBodyStmt LocatedA (HsExpr (GhcPass 'Parsed))
e' }
cvtStmt (TH.BindS Pat
p Exp
e) = do { GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
p' <- Pat -> CvtM (LPat (GhcPass 'Parsed))
cvtPat Pat
p; LocatedA (HsExpr (GhcPass 'Parsed))
e' <- Exp -> CvtM (LHsExpr (GhcPass 'Parsed))
cvtl Exp
e; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ forall (bodyR :: * -> *).
EpAnn [AddEpAnn]
-> LPat (GhcPass 'Parsed)
-> LocatedA (bodyR (GhcPass 'Parsed))
-> StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(LocatedA (bodyR (GhcPass 'Parsed)))
mkPsBindStmt forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
p' LocatedA (HsExpr (GhcPass 'Parsed))
e' }
cvtStmt (TH.LetS [Dec]
ds) = do { HsLocalBinds (GhcPass 'Parsed)
ds' <- SDoc -> [Dec] -> CvtM (HsLocalBinds (GhcPass 'Parsed))
cvtLocalDecs (String -> SDoc
text String
"a let binding") [Dec]
ds
; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ forall idL idR body.
XLetStmt idL idR body
-> HsLocalBindsLR idL idR -> StmtLR idL idR body
LetStmt forall a. EpAnn a
noAnn HsLocalBinds (GhcPass 'Parsed)
ds' }
cvtStmt (TH.ParS [[Stmt]]
dss) = do { [ParStmtBlock (GhcPass 'Parsed) (GhcPass 'Parsed)]
dss' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {idR} {p :: Pass}.
(XParStmtBlock (GhcPass 'Parsed) idR ~ NoExtField,
SyntaxExprGhc p ~ SyntaxExpr idR, IsPass p) =>
[Stmt] -> CvtM (ParStmtBlock (GhcPass 'Parsed) idR)
cvt_one [[Stmt]]
dss
; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ forall idL idR body.
XParStmt idL idR body
-> [ParStmtBlock idL idR]
-> HsExpr idR
-> SyntaxExpr idR
-> StmtLR idL idR body
ParStmt NoExtField
noExtField [ParStmtBlock (GhcPass 'Parsed) (GhcPass 'Parsed)]
dss' forall (p :: Pass). HsExpr (GhcPass p)
noExpr forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
noSyntaxExpr }
where
cvt_one :: [Stmt] -> CvtM (ParStmtBlock (GhcPass 'Parsed) idR)
cvt_one [Stmt]
ds = do { [GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))]
ds' <- [Stmt]
-> CvtM [LStmt (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
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
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))]
ds' forall a. HasCallStack => a
undefined forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
noSyntaxExpr) }
cvtStmt (TH.RecS [Stmt]
ss) = do { [GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))]
ss' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Stmt -> CvtM (LStmt (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
cvtStmt [Stmt]
ss
; StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed)))
rec_stmt <- forall ann a b. (LocatedAn ann a -> b) -> a -> CvtM b
wrapParLA (forall (idL :: Pass) bodyR.
(Anno
[GenLocated
(Anno (StmtLR (GhcPass idL) (GhcPass 'Parsed) bodyR))
(StmtLR (GhcPass idL) (GhcPass 'Parsed) bodyR)]
~ SrcSpanAnnL) =>
EpAnn AnnList
-> LocatedL [LStmtLR (GhcPass idL) (GhcPass 'Parsed) bodyR]
-> StmtLR (GhcPass idL) (GhcPass 'Parsed) bodyR
mkRecStmt forall a. EpAnn a
noAnn) [GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))]
ss'
; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed)))
rec_stmt }
cvtMatch :: HsMatchContext GhcPs
-> TH.Match -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))
cvtMatch :: HsMatchContext (GhcPass 'Parsed)
-> Match
-> CvtM (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
cvtMatch HsMatchContext (GhcPass 'Parsed)
ctxt (TH.Match Pat
p Body
body [Dec]
decs)
= do { GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
p' <- Pat -> CvtM (LPat (GhcPass 'Parsed))
cvtPat Pat
p
; let lp :: GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
lp = case GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
p' of
(L SrcSpanAnnA
loc SigPat{}) -> forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (forall (pass :: Pass). LPat (GhcPass pass) -> Pat (GhcPass pass)
gParPat GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
p')
GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
_ -> GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
p'
; [GenLocated
(SrcAnn NoEpAnns)
(GRHS (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
g' <- Body -> CvtM [LGRHS (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
cvtGuard Body
body
; HsLocalBinds (GhcPass 'Parsed)
decs' <- SDoc -> [Dec] -> CvtM (HsLocalBinds (GhcPass 'Parsed))
cvtLocalDecs (String -> SDoc
text String
"a where clause") [Dec]
decs
; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ forall p body.
XCMatch p body
-> HsMatchContext p -> [LPat p] -> GRHSs p body -> Match p body
Hs.Match forall a. EpAnn a
noAnn HsMatchContext (GhcPass 'Parsed)
ctxt [GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
lp] (forall p body.
XCGRHSs p body -> [LGRHS p body] -> HsLocalBinds p -> GRHSs p body
GRHSs EpAnnComments
emptyComments [GenLocated
(SrcAnn NoEpAnns)
(GRHS (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
g' HsLocalBinds (GhcPass 'Parsed)
decs') }
cvtGuard :: TH.Body -> CvtM [LGRHS GhcPs (LHsExpr GhcPs)]
cvtGuard :: Body -> CvtM [LGRHS (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
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 (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
cvtpair [(Guard, Exp)]
pairs
cvtGuard (NormalB Exp
e) = do { LocatedA (HsExpr (GhcPass 'Parsed))
e' <- Exp -> CvtM (LHsExpr (GhcPass 'Parsed))
cvtl Exp
e
; GenLocated
(SrcAnn NoEpAnns)
(GRHS (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))
g' <- forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ forall p body.
XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body
GRHS forall a. EpAnn a
noAnn [] LocatedA (HsExpr (GhcPass 'Parsed))
e'; forall (m :: * -> *) a. Monad m => a -> m a
return [GenLocated
(SrcAnn NoEpAnns)
(GRHS (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))
g'] }
cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS GhcPs (LHsExpr GhcPs))
cvtpair :: (Guard, Exp)
-> CvtM (LGRHS (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
cvtpair (NormalG Exp
ge,Exp
rhs) = do { LocatedA (HsExpr (GhcPass 'Parsed))
ge' <- Exp -> CvtM (LHsExpr (GhcPass 'Parsed))
cvtl Exp
ge; LocatedA (HsExpr (GhcPass 'Parsed))
rhs' <- Exp -> CvtM (LHsExpr (GhcPass 'Parsed))
cvtl Exp
rhs
; GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))
g' <- forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ forall (bodyR :: * -> *) (idL :: Pass).
LocatedA (bodyR (GhcPass 'Parsed))
-> StmtLR
(GhcPass idL)
(GhcPass 'Parsed)
(LocatedA (bodyR (GhcPass 'Parsed)))
mkBodyStmt LocatedA (HsExpr (GhcPass 'Parsed))
ge'
; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ forall p body.
XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body
GRHS forall a. EpAnn a
noAnn [GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))
g'] LocatedA (HsExpr (GhcPass 'Parsed))
rhs' }
cvtpair (PatG [Stmt]
gs,Exp
rhs) = do { [GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))]
gs' <- [Stmt]
-> CvtM [LStmt (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
cvtStmts [Stmt]
gs; LocatedA (HsExpr (GhcPass 'Parsed))
rhs' <- Exp -> CvtM (LHsExpr (GhcPass 'Parsed))
cvtl Exp
rhs
; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ forall p body.
XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body
GRHS forall a. EpAnn a
noAnn [GenLocated
SrcSpanAnnA
(StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))]
gs' LocatedA (HsExpr (GhcPass 'Parsed))
rhs' }
cvtOverLit :: Lit -> CvtM (HsOverLit GhcPs)
cvtOverLit :: Lit -> CvtM (HsOverLit (GhcPass 'Parsed))
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 (GhcPass 'Parsed)
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 (GhcPass 'Parsed)
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 (GhcPass 'Parsed)
mkHsIsString (String -> SourceText
quotedSourceText String
s) CLabelString
s'
}
cvtOverLit Lit
_ = forall a. String -> a
panic String
"Convert.cvtOverLit: Unexpected overloaded literal"
allCharLs :: [TH.Exp] -> Maybe String
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 (GhcPass 'Parsed))
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"
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 (GhcPass 'Parsed)]
cvtPats [Pat]
pats = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pat -> CvtM (LPat (GhcPass 'Parsed))
cvtPat [Pat]
pats
cvtPat :: TH.Pat -> CvtM (Hs.LPat GhcPs)
cvtPat :: Pat -> CvtM (LPat (GhcPass 'Parsed))
cvtPat Pat
pat = forall a. CvtM a -> CvtM (LocatedA a)
wrapLA (Pat -> CvtM (Pat (GhcPass 'Parsed))
cvtp Pat
pat)
cvtp :: TH.Pat -> CvtM (Hs.Pat GhcPs)
cvtp :: Pat -> CvtM (Pat (GhcPass 'Parsed))
cvtp (TH.LitP Lit
l)
| Lit -> Bool
overloadedLit Lit
l = do { HsOverLit (GhcPass 'Parsed)
l' <- Lit -> CvtM (HsOverLit (GhcPass 'Parsed))
cvtOverLit Lit
l
; LocatedAn NoEpAnns (HsOverLit (GhcPass 'Parsed))
l'' <- forall e ann. e -> CvtM (LocatedAn ann e)
returnLA HsOverLit (GhcPass 'Parsed)
l'
; forall (m :: * -> *) a. Monad m => a -> m a
return (LocatedAn NoEpAnns (HsOverLit (GhcPass 'Parsed))
-> Maybe (SyntaxExpr (GhcPass 'Parsed))
-> EpAnn [AddEpAnn]
-> Pat (GhcPass 'Parsed)
mkNPat LocatedAn NoEpAnns (HsOverLit (GhcPass 'Parsed))
l'' forall a. Maybe a
Nothing forall a. EpAnn a
noAnn) }
| Bool
otherwise = do { HsLit (GhcPass 'Parsed)
l' <- Lit -> CvtM (HsLit (GhcPass 'Parsed))
cvtLit Lit
l; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p. XLitPat p -> HsLit p -> Pat p
Hs.LitPat NoExtField
noExtField HsLit (GhcPass 'Parsed)
l' }
cvtp (TH.VarP Name
s) = do { RdrName
s' <- Name -> CvtM RdrName
vName Name
s
; forall ann a b. (LocatedAn ann a -> b) -> a -> CvtM b
wrapParLA (forall p. XVarPat p -> LIdP p -> Pat p
Hs.VarPat NoExtField
noExtField) RdrName
s' }
cvtp (TupP [Pat]
ps) = do { [GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
ps' <- [Pat] -> CvtM [LPat (GhcPass 'Parsed)]
cvtPats [Pat]
ps
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p. XTuplePat p -> [LPat p] -> Boxity -> Pat p
TuplePat forall a. EpAnn a
noAnn [GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
ps' Boxity
Boxed }
cvtp (UnboxedTupP [Pat]
ps) = do { [GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
ps' <- [Pat] -> CvtM [LPat (GhcPass 'Parsed)]
cvtPats [Pat]
ps
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p. XTuplePat p -> [LPat p] -> Boxity -> Pat p
TuplePat forall a. EpAnn a
noAnn [GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
ps' Boxity
Unboxed }
cvtp (UnboxedSumP Pat
p Int
alt Int
arity)
= do { GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
p' <- Pat -> CvtM (LPat (GhcPass 'Parsed))
cvtPat Pat
p
; Int -> Int -> CvtM ()
unboxedSumChecks Int
alt Int
arity
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p. XSumPat p -> LPat p -> Int -> Int -> Pat p
SumPat forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
p' Int
alt Int
arity }
cvtp (ConP Name
s [Type]
ts [Pat]
ps) = do { LocatedN RdrName
s' <- Name -> CvtM (LocatedN RdrName)
cNameN Name
s
; [GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
ps' <- [Pat] -> CvtM [LPat (GhcPass 'Parsed)]
cvtPats [Pat]
ps
; [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
ts' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> CvtM (LHsType (GhcPass 'Parsed))
cvtType [Type]
ts
; let pps :: [GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
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 (GhcPass 'Parsed))]
ps'
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ConPat
{ pat_con_ext :: XConPat (GhcPass 'Parsed)
pat_con_ext = forall a. EpAnn a
noAnn
, pat_con :: XRec (GhcPass 'Parsed) (ConLikeP (GhcPass 'Parsed))
pat_con = LocatedN RdrName
s'
, pat_args :: HsConPatDetails (GhcPass 'Parsed)
pat_args = forall tyarg arg rec.
[tyarg] -> [arg] -> HsConDetails tyarg arg rec
PrefixCon (forall a b. (a -> b) -> [a] -> [b]
map (EpAnn EpaLocation
-> LHsType (GhcPass 'Parsed) -> HsPatSigType (GhcPass 'Parsed)
mkHsPatSigType forall a. EpAnn a
noAnn) [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
ts') [GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
pps
}
}
cvtp (InfixP Pat
p1 Name
s Pat
p2) = do { LocatedN RdrName
s' <- Name -> CvtM (LocatedN RdrName)
cNameN Name
s; GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
p1' <- Pat -> CvtM (LPat (GhcPass 'Parsed))
cvtPat Pat
p1; GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
p2' <- Pat -> CvtM (LPat (GhcPass 'Parsed))
cvtPat Pat
p2
; forall ann a b. (LocatedAn ann a -> b) -> a -> CvtM b
wrapParLA forall (pass :: Pass). LPat (GhcPass pass) -> Pat (GhcPass pass)
gParPat forall a b. (a -> b) -> a -> b
$
ConPat
{ pat_con_ext :: XConPat (GhcPass 'Parsed)
pat_con_ext = forall a. EpAnn a
noAnn
, pat_con :: XRec (GhcPass 'Parsed) (ConLikeP (GhcPass 'Parsed))
pat_con = LocatedN RdrName
s'
, pat_args :: HsConPatDetails (GhcPass 'Parsed)
pat_args = forall tyarg arg rec. arg -> arg -> HsConDetails tyarg arg rec
InfixCon
(forall (p :: Pass).
IsPass p =>
PprPrec -> LPat (GhcPass p) -> LPat (GhcPass p)
parenthesizePat PprPrec
opPrec GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
p1')
(forall (p :: Pass).
IsPass p =>
PprPrec -> LPat (GhcPass p) -> LPat (GhcPass p)
parenthesizePat PprPrec
opPrec GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
p2')
}
}
cvtp (UInfixP Pat
p1 Name
s Pat
p2) = do { GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
p1' <- Pat -> CvtM (LPat (GhcPass 'Parsed))
cvtPat Pat
p1; LPat (GhcPass 'Parsed)
-> Name -> Pat -> CvtM (Pat (GhcPass 'Parsed))
cvtOpAppP GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
p1' Name
s Pat
p2 }
cvtp (ParensP Pat
p) = do { GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
p' <- Pat -> CvtM (LPat (GhcPass 'Parsed))
cvtPat Pat
p;
; case forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
p' of
ParPat {} -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
p'
Pat (GhcPass 'Parsed)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (pass :: Pass). LPat (GhcPass pass) -> Pat (GhcPass pass)
gParPat GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
p' }
cvtp (TildeP Pat
p) = do { GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
p' <- Pat -> CvtM (LPat (GhcPass 'Parsed))
cvtPat Pat
p; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p. XLazyPat p -> LPat p -> Pat p
LazyPat forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
p' }
cvtp (BangP Pat
p) = do { GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
p' <- Pat -> CvtM (LPat (GhcPass 'Parsed))
cvtPat Pat
p; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p. XBangPat p -> LPat p -> Pat p
BangPat forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
p' }
cvtp (TH.AsP Name
s Pat
p) = do { LocatedN RdrName
s' <- Name -> CvtM (LocatedN RdrName)
vNameN Name
s; GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
p' <- Pat -> CvtM (LPat (GhcPass 'Parsed))
cvtPat Pat
p
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p. XAsPat p -> LIdP p -> LPat p -> Pat p
AsPat forall a. EpAnn a
noAnn LocatedN RdrName
s' GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
p' }
cvtp Pat
TH.WildP = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p. XWildPat p -> Pat p
WildPat NoExtField
noExtField
cvtp (RecP Name
c [FieldPat]
fs) = do { LocatedN RdrName
c' <- Name -> CvtM (LocatedN RdrName)
cNameN Name
c; [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc (GhcPass 'Parsed)))
(GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))))]
fs' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FieldPat
-> CvtM (LHsRecField (GhcPass 'Parsed) (LPat (GhcPass 'Parsed)))
cvtPatFld [FieldPat]
fs
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ConPat
{ pat_con_ext :: XConPat (GhcPass 'Parsed)
pat_con_ext = forall a. EpAnn a
noAnn
, pat_con :: XRec (GhcPass 'Parsed) (ConLikeP (GhcPass 'Parsed))
pat_con = LocatedN RdrName
c'
, pat_args :: HsConPatDetails (GhcPass 'Parsed)
pat_args = forall tyarg arg rec. rec -> HsConDetails tyarg arg rec
Hs.RecCon forall a b. (a -> b) -> a -> b
$ forall p arg.
[LHsRecField p arg] -> Maybe (Located Int) -> HsRecFields p arg
HsRecFields [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc (GhcPass 'Parsed)))
(GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))))]
fs' forall a. Maybe a
Nothing
}
}
cvtp (ListP [Pat]
ps) = do { [GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
ps' <- [Pat] -> CvtM [LPat (GhcPass 'Parsed)]
cvtPats [Pat]
ps
; forall (m :: * -> *) a. Monad m => a -> m a
return
forall a b. (a -> b) -> a -> b
$ forall p. XListPat p -> [LPat p] -> Pat p
ListPat forall a. EpAnn a
noAnn [GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
ps'}
cvtp (SigP Pat
p Type
t) = do { GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
p' <- Pat -> CvtM (LPat (GhcPass 'Parsed))
cvtPat Pat
p; GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
t' <- Type -> CvtM (LHsType (GhcPass 'Parsed))
cvtType Type
t
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p. XSigPat p -> LPat p -> HsPatSigType (NoGhcTc p) -> Pat p
SigPat forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
p' (EpAnn EpaLocation
-> LHsType (GhcPass 'Parsed) -> HsPatSigType (GhcPass 'Parsed)
mkHsPatSigType forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
t') }
cvtp (ViewP Exp
e Pat
p) = do { LocatedA (HsExpr (GhcPass 'Parsed))
e' <- Exp -> CvtM (LHsExpr (GhcPass 'Parsed))
cvtl Exp
e; GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
p' <- Pat -> CvtM (LPat (GhcPass 'Parsed))
cvtPat Pat
p
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall p. XViewPat p -> LHsExpr p -> LPat p -> Pat p
ViewPat forall a. EpAnn a
noAnn LocatedA (HsExpr (GhcPass 'Parsed))
e' GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
p'}
cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField GhcPs (LPat GhcPs))
cvtPatFld :: FieldPat
-> CvtM (LHsRecField (GhcPass 'Parsed) (LPat (GhcPass 'Parsed)))
cvtPatFld (Name
s,Pat
p)
= do { L SrcSpanAnnN
ls RdrName
s' <- Name -> CvtM (LocatedN RdrName)
vNameN Name
s
; GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
p' <- Pat -> CvtM (LPat (GhcPass 'Parsed))
cvtPat Pat
p
; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ HsFieldBind { hfbAnn :: XHsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc (GhcPass 'Parsed)))
hfbAnn = forall a. EpAnn a
noAnn
, hfbLHS :: GenLocated (SrcAnn NoEpAnns) (FieldOcc (GhcPass 'Parsed))
hfbLHS
= forall l e. l -> e -> GenLocated l e
L (forall a ann. SrcSpanAnn' a -> SrcAnn ann
l2l SrcSpanAnnN
ls) forall a b. (a -> b) -> a -> b
$ LocatedN RdrName -> FieldOcc (GhcPass 'Parsed)
mkFieldOcc (forall l e. l -> e -> GenLocated l e
L (forall a ann. SrcSpanAnn' a -> SrcAnn ann
l2l SrcSpanAnnN
ls) RdrName
s')
, hfbRHS :: GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
hfbRHS = GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
p'
, hfbPun :: Bool
hfbPun = Bool
False} }
cvtOpAppP :: Hs.LPat GhcPs -> TH.Name -> TH.Pat -> CvtM (Hs.Pat GhcPs)
cvtOpAppP :: LPat (GhcPass 'Parsed)
-> Name -> Pat -> CvtM (Pat (GhcPass 'Parsed))
cvtOpAppP LPat (GhcPass 'Parsed)
x Name
op1 (UInfixP Pat
y Name
op2 Pat
z)
= do { GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
l <- forall a. CvtM a -> CvtM (LocatedA a)
wrapLA forall a b. (a -> b) -> a -> b
$ LPat (GhcPass 'Parsed)
-> Name -> Pat -> CvtM (Pat (GhcPass 'Parsed))
cvtOpAppP LPat (GhcPass 'Parsed)
x Name
op1 Pat
y
; LPat (GhcPass 'Parsed)
-> Name -> Pat -> CvtM (Pat (GhcPass 'Parsed))
cvtOpAppP GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
l Name
op2 Pat
z }
cvtOpAppP LPat (GhcPass 'Parsed)
x Name
op Pat
y
= do { LocatedN RdrName
op' <- Name -> CvtM (LocatedN RdrName)
cNameN Name
op
; GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
y' <- Pat -> CvtM (LPat (GhcPass 'Parsed))
cvtPat Pat
y
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ConPat
{ pat_con_ext :: XConPat (GhcPass 'Parsed)
pat_con_ext = forall a. EpAnn a
noAnn
, pat_con :: XRec (GhcPass 'Parsed) (ConLikeP (GhcPass 'Parsed))
pat_con = LocatedN RdrName
op'
, pat_args :: HsConPatDetails (GhcPass 'Parsed)
pat_args = forall tyarg arg rec. arg -> arg -> HsConDetails tyarg arg rec
InfixCon LPat (GhcPass 'Parsed)
x GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
y'
}
}
class CvtFlag flag flag' | flag -> flag' where
cvtFlag :: flag -> flag'
instance CvtFlag () () where
cvtFlag :: () -> ()
cvtFlag () = ()
instance CvtFlag TH.Specificity Hs.Specificity where
cvtFlag :: Specificity -> Specificity
cvtFlag Specificity
TH.SpecifiedSpec = Specificity
Hs.SpecifiedSpec
cvtFlag Specificity
TH.InferredSpec = Specificity
Hs.InferredSpec
cvtTvs :: CvtFlag flag flag' => [TH.TyVarBndr flag] -> CvtM [LHsTyVarBndr flag' GhcPs]
cvtTvs :: forall flag flag'.
CvtFlag flag flag' =>
[TyVarBndr flag] -> CvtM [LHsTyVarBndr flag' (GhcPass 'Parsed)]
cvtTvs [TyVarBndr flag]
tvs = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall flag flag'.
CvtFlag flag flag' =>
TyVarBndr flag -> CvtM (LHsTyVarBndr flag' (GhcPass 'Parsed))
cvt_tv [TyVarBndr flag]
tvs
cvt_tv :: CvtFlag flag flag' => (TH.TyVarBndr flag) -> CvtM (LHsTyVarBndr flag' GhcPs)
cvt_tv :: forall flag flag'.
CvtFlag flag flag' =>
TyVarBndr flag -> CvtM (LHsTyVarBndr flag' (GhcPass 'Parsed))
cvt_tv (TH.PlainTV Name
nm flag
fl)
= do { LocatedN RdrName
nm' <- Name -> CvtM (LocatedN RdrName)
tNameN Name
nm
; let fl' :: flag'
fl' = forall flag flag'. CvtFlag flag flag' => flag -> flag'
cvtFlag flag
fl
; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ forall flag pass.
XUserTyVar pass -> flag -> LIdP pass -> HsTyVarBndr flag pass
UserTyVar forall a. EpAnn a
noAnn flag'
fl' LocatedN RdrName
nm' }
cvt_tv (TH.KindedTV Name
nm flag
fl Type
ki)
= do { LocatedN RdrName
nm' <- Name -> CvtM (LocatedN RdrName)
tNameN Name
nm
; let fl' :: flag'
fl' = forall flag flag'. CvtFlag flag flag' => flag -> flag'
cvtFlag flag
fl
; GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
ki' <- Type -> CvtM (LHsType (GhcPass 'Parsed))
cvtKind Type
ki
; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ forall flag pass.
XKindedTyVar pass
-> flag -> LIdP pass -> LHsKind pass -> HsTyVarBndr flag pass
KindedTyVar forall a. EpAnn a
noAnn flag'
fl' LocatedN RdrName
nm' GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
ki' }
cvtRole :: TH.Role -> Maybe Coercion.Role
cvtRole :: Role -> Maybe Role
cvtRole Role
TH.NominalR = forall a. a -> Maybe a
Just Role
Coercion.Nominal
cvtRole Role
TH.RepresentationalR = forall a. a -> Maybe a
Just Role
Coercion.Representational
cvtRole Role
TH.PhantomR = forall a. a -> Maybe a
Just Role
Coercion.Phantom
cvtRole Role
TH.InferR = forall a. Maybe a
Nothing
cvtContext :: PprPrec -> TH.Cxt -> CvtM (LHsContext GhcPs)
cvtContext :: PprPrec -> [Type] -> CvtM (LHsContext (GhcPass 'Parsed))
cvtContext PprPrec
p [Type]
tys = do { [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
preds' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> CvtM (LHsType (GhcPass 'Parsed))
cvtPred [Type]
tys
; forall (p :: Pass).
PprPrec -> LHsContext (GhcPass p) -> LHsContext (GhcPass p)
parenthesizeHsContext PprPrec
p forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e ann. e -> CvtM (LocatedAn ann e)
returnLA [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
preds' }
cvtPred :: TH.Pred -> CvtM (LHsType GhcPs)
cvtPred :: Type -> CvtM (LHsType (GhcPass 'Parsed))
cvtPred = Type -> CvtM (LHsType (GhcPass 'Parsed))
cvtType
cvtDerivClauseTys :: TH.Cxt -> CvtM (LDerivClauseTys GhcPs)
cvtDerivClauseTys :: [Type] -> CvtM (LDerivClauseTys (GhcPass 'Parsed))
cvtDerivClauseTys [Type]
tys
= do { [GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Parsed))]
tys' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> CvtM (LHsSigType (GhcPass 'Parsed))
cvtSigType [Type]
tys
; case [GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Parsed))]
tys' of
[ty' :: GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Parsed))
ty'@(L SrcSpanAnnA
l (HsSig { sig_bndrs :: forall pass. HsSigType pass -> HsOuterSigTyVarBndrs pass
sig_bndrs = HsOuterImplicit{}
, sig_body :: forall pass. HsSigType pass -> LHsType pass
sig_body = L SrcSpanAnnA
_ (HsTyVar XTyVar (GhcPass 'Parsed)
_ PromotionFlag
NotPromoted XRec (GhcPass 'Parsed) (IdP (GhcPass 'Parsed))
_) }))]
-> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l e. l -> e -> GenLocated l e
L (forall a ann. SrcSpanAnn' a -> SrcAnn ann
l2l SrcSpanAnnA
l) forall a b. (a -> b) -> a -> b
$ forall pass.
XDctSingle pass -> LHsSigType pass -> DerivClauseTys pass
DctSingle NoExtField
noExtField GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Parsed))
ty'
[GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Parsed))]
_ -> forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ forall pass.
XDctMulti pass -> [LHsSigType pass] -> DerivClauseTys pass
DctMulti NoExtField
noExtField [GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Parsed))]
tys' }
cvtDerivClause :: TH.DerivClause
-> CvtM (LHsDerivingClause GhcPs)
cvtDerivClause :: DerivClause -> CvtM (LHsDerivingClause (GhcPass 'Parsed))
cvtDerivClause (TH.DerivClause Maybe DerivStrategy
ds [Type]
tys)
= do { GenLocated SrcSpanAnnC (DerivClauseTys (GhcPass 'Parsed))
tys' <- [Type] -> CvtM (LDerivClauseTys (GhcPass 'Parsed))
cvtDerivClauseTys [Type]
tys
; Maybe
(GenLocated (SrcAnn NoEpAnns) (DerivStrategy (GhcPass 'Parsed)))
ds' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse DerivStrategy -> CvtM (LDerivStrategy (GhcPass 'Parsed))
cvtDerivStrategy Maybe DerivStrategy
ds
; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ forall pass.
XCHsDerivingClause pass
-> Maybe (LDerivStrategy pass)
-> LDerivClauseTys pass
-> HsDerivingClause pass
HsDerivingClause forall a. EpAnn a
noAnn Maybe
(GenLocated (SrcAnn NoEpAnns) (DerivStrategy (GhcPass 'Parsed)))
ds' GenLocated SrcSpanAnnC (DerivClauseTys (GhcPass 'Parsed))
tys' }
cvtDerivStrategy :: TH.DerivStrategy -> CvtM (Hs.LDerivStrategy GhcPs)
cvtDerivStrategy :: DerivStrategy -> CvtM (LDerivStrategy (GhcPass 'Parsed))
cvtDerivStrategy DerivStrategy
TH.StockStrategy = forall e ann. e -> CvtM (LocatedAn ann e)
returnLA (forall pass. XStockStrategy pass -> DerivStrategy pass
Hs.StockStrategy forall a. EpAnn a
noAnn)
cvtDerivStrategy DerivStrategy
TH.AnyclassStrategy = forall e ann. e -> CvtM (LocatedAn ann e)
returnLA (forall pass. XAnyClassStrategy pass -> DerivStrategy pass
Hs.AnyclassStrategy forall a. EpAnn a
noAnn)
cvtDerivStrategy DerivStrategy
TH.NewtypeStrategy = forall e ann. e -> CvtM (LocatedAn ann e)
returnLA (forall pass. XNewtypeStrategy pass -> DerivStrategy pass
Hs.NewtypeStrategy forall a. EpAnn a
noAnn)
cvtDerivStrategy (TH.ViaStrategy Type
ty) = do
GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Parsed))
ty' <- Type -> CvtM (LHsSigType (GhcPass 'Parsed))
cvtSigType Type
ty
forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ forall pass. XViaStrategy pass -> DerivStrategy pass
Hs.ViaStrategy (EpAnn [AddEpAnn] -> LHsSigType (GhcPass 'Parsed) -> XViaStrategyPs
XViaStrategyPs forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Parsed))
ty')
cvtType :: TH.Type -> CvtM (LHsType GhcPs)
cvtType :: Type -> CvtM (LHsType (GhcPass 'Parsed))
cvtType = String -> Type -> CvtM (LHsType (GhcPass 'Parsed))
cvtTypeKind String
"type"
cvtSigType :: TH.Type -> CvtM (LHsSigType GhcPs)
cvtSigType :: Type -> CvtM (LHsSigType (GhcPass 'Parsed))
cvtSigType = String -> Type -> CvtM (LHsSigType (GhcPass 'Parsed))
cvtSigTypeKind String
"type"
cvtSigTypeKind :: String -> TH.Type -> CvtM (LHsSigType GhcPs)
cvtSigTypeKind :: String -> Type -> CvtM (LHsSigType (GhcPass 'Parsed))
cvtSigTypeKind String
ty_str Type
ty = do
GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
ty' <- String -> Type -> CvtM (LHsType (GhcPass 'Parsed))
cvtTypeKind String
ty_str Type
ty
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ LHsType (GhcPass 'Parsed) -> LHsSigType (GhcPass 'Parsed)
hsTypeToHsSigType forall a b. (a -> b) -> a -> b
$ forall (p :: Pass).
PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)
parenthesizeHsType PprPrec
sigPrec GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
ty'
cvtTypeKind :: String -> TH.Type -> CvtM (LHsType GhcPs)
cvtTypeKind :: String -> Type -> CvtM (LHsType (GhcPass 'Parsed))
cvtTypeKind String
ty_str Type
ty
= do { (Type
head_ty, [HsArg
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))]
tys') <- Type -> CvtM (Type, HsTyPats (GhcPass 'Parsed))
split_ty_app Type
ty
; let m_normals :: Maybe [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
m_normals = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {a} {ty}. HsArg a ty -> Maybe a
extract_normal [HsArg
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))]
tys'
where extract_normal :: HsArg a ty -> Maybe a
extract_normal (HsValArg a
ty) = forall a. a -> Maybe a
Just a
ty
extract_normal HsArg a ty
_ = forall a. Maybe a
Nothing
; case Type
head_ty of
TupleT Int
n
| Just [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
normals <- Maybe [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
m_normals
, [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
normals forall a. [a] -> Int -> Bool
`lengthIs` Int
n
-> forall e ann. e -> CvtM (LocatedAn ann e)
returnLA (forall pass.
XTupleTy pass -> HsTupleSort -> [LHsType pass] -> HsType pass
HsTupleTy forall a. EpAnn a
noAnn HsTupleSort
HsBoxedOrConstraintTuple [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
normals)
| Bool
otherwise
-> do { LocatedN RdrName
tuple_tc <- forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ forall thing. NamedThing thing => thing -> RdrName
getRdrName forall a b. (a -> b) -> a -> b
$ Boxity -> Int -> TyCon
tupleTyCon Boxity
Boxed Int
n
; HsType (GhcPass 'Parsed)
-> HsTyPats (GhcPass 'Parsed) -> CvtM (LHsType (GhcPass 'Parsed))
mk_apps (forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar forall a. EpAnn a
noAnn PromotionFlag
NotPromoted LocatedN RdrName
tuple_tc) [HsArg
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))]
tys' }
UnboxedTupleT Int
n
| Just [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
normals <- Maybe [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
m_normals
, [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
normals forall a. [a] -> Int -> Bool
`lengthIs` Int
n
-> forall e ann. e -> CvtM (LocatedAn ann e)
returnLA (forall pass.
XTupleTy pass -> HsTupleSort -> [LHsType pass] -> HsType pass
HsTupleTy forall a. EpAnn a
noAnn HsTupleSort
HsUnboxedTuple [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
normals)
| Bool
otherwise
-> do { LocatedN RdrName
tuple_tc <- forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ forall thing. NamedThing thing => thing -> RdrName
getRdrName forall a b. (a -> b) -> a -> b
$ Boxity -> Int -> TyCon
tupleTyCon Boxity
Unboxed Int
n
; HsType (GhcPass 'Parsed)
-> HsTyPats (GhcPass 'Parsed) -> CvtM (LHsType (GhcPass 'Parsed))
mk_apps (forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar forall a. EpAnn a
noAnn PromotionFlag
NotPromoted LocatedN RdrName
tuple_tc) [HsArg
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))]
tys' }
UnboxedSumT Int
n
| Int
n forall a. Ord a => a -> a -> Bool
< Int
2
-> forall a. SDoc -> CvtM a
failWith forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Illegal sum arity:" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text (forall a. Show a => a -> String
show Int
n)
, Int -> SDoc -> SDoc
nest Int
2 forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"Sums must have an arity of at least 2" ]
| Just [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
normals <- Maybe [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
m_normals
, [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
normals forall a. [a] -> Int -> Bool
`lengthIs` Int
n
-> forall e ann. e -> CvtM (LocatedAn ann e)
returnLA (forall pass. XSumTy pass -> [LHsType pass] -> HsType pass
HsSumTy forall a. EpAnn a
noAnn [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
normals)
| Bool
otherwise
-> do { LocatedN RdrName
sum_tc <- forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ forall thing. NamedThing thing => thing -> RdrName
getRdrName forall a b. (a -> b) -> a -> b
$ Int -> TyCon
sumTyCon Int
n
; HsType (GhcPass 'Parsed)
-> HsTyPats (GhcPass 'Parsed) -> CvtM (LHsType (GhcPass 'Parsed))
mk_apps (forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar forall a. EpAnn a
noAnn PromotionFlag
NotPromoted LocatedN RdrName
sum_tc) [HsArg
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))]
tys' }
Type
ArrowT
| Just [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
normals <- Maybe [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
m_normals
, [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
x',GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
y'] <- [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
normals -> do
GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
x'' <- case forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
x' of
HsFunTy{} -> forall e ann. e -> CvtM (LocatedAn ann e)
returnLA (forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
x')
HsForAllTy{} -> forall e ann. e -> CvtM (LocatedAn ann e)
returnLA (forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
x')
HsQualTy{} -> forall e ann. e -> CvtM (LocatedAn ann e)
returnLA (forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
x')
HsType (GhcPass 'Parsed)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
forall (p :: Pass).
PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)
parenthesizeHsType PprPrec
sigPrec GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
x'
let y'' :: LHsType (GhcPass 'Parsed)
y'' = forall (p :: Pass).
PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)
parenthesizeHsType PprPrec
sigPrec GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
y'
forall e ann. e -> CvtM (LocatedAn ann e)
returnLA (forall pass.
XFunTy pass
-> HsArrow pass -> LHsType pass -> LHsType pass -> HsType pass
HsFunTy forall a. EpAnn a
noAnn (forall pass. LHsUniToken "->" "\8594" pass -> HsArrow pass
HsUnrestrictedArrow forall (tok :: Symbol) (utok :: Symbol).
GenLocated TokenLocation (HsUniToken tok utok)
noHsUniTok) GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
x'' LHsType (GhcPass 'Parsed)
y'')
| Bool
otherwise
-> do { LocatedN RdrName
fun_tc <- forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ forall thing. NamedThing thing => thing -> RdrName
getRdrName TyCon
unrestrictedFunTyCon
; HsType (GhcPass 'Parsed)
-> HsTyPats (GhcPass 'Parsed) -> CvtM (LHsType (GhcPass 'Parsed))
mk_apps (forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar forall a. EpAnn a
noAnn PromotionFlag
NotPromoted LocatedN RdrName
fun_tc) [HsArg
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))]
tys' }
Type
MulArrowT
| Just [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
normals <- Maybe [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
m_normals
, [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
w',GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
x',GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
y'] <- [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
normals -> do
GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
x'' <- case forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
x' of
HsFunTy{} -> forall e ann. e -> CvtM (LocatedAn ann e)
returnLA (forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
x')
HsForAllTy{} -> forall e ann. e -> CvtM (LocatedAn ann e)
returnLA (forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
x')
HsQualTy{} -> forall e ann. e -> CvtM (LocatedAn ann e)
returnLA (forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
x')
HsType (GhcPass 'Parsed)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
forall (p :: Pass).
PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)
parenthesizeHsType PprPrec
sigPrec GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
x'
let y'' :: LHsType (GhcPass 'Parsed)
y'' = forall (p :: Pass).
PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)
parenthesizeHsType PprPrec
sigPrec GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
y'
w'' :: HsArrow (GhcPass 'Parsed)
w'' = LHsType (GhcPass 'Parsed) -> HsArrow (GhcPass 'Parsed)
hsTypeToArrow GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
w'
forall e ann. e -> CvtM (LocatedAn ann e)
returnLA (forall pass.
XFunTy pass
-> HsArrow pass -> LHsType pass -> LHsType pass -> HsType pass
HsFunTy forall a. EpAnn a
noAnn HsArrow (GhcPass 'Parsed)
w'' GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
x'' LHsType (GhcPass 'Parsed)
y'')
| Bool
otherwise
-> do { LocatedN RdrName
fun_tc <- forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ forall thing. NamedThing thing => thing -> RdrName
getRdrName TyCon
funTyCon
; HsType (GhcPass 'Parsed)
-> HsTyPats (GhcPass 'Parsed) -> CvtM (LHsType (GhcPass 'Parsed))
mk_apps (forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar forall a. EpAnn a
noAnn PromotionFlag
NotPromoted LocatedN RdrName
fun_tc) [HsArg
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))]
tys' }
Type
ListT
| Just [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
normals <- Maybe [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
m_normals
, [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
x'] <- [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
normals ->
forall e ann. e -> CvtM (LocatedAn ann e)
returnLA (forall pass. XListTy pass -> LHsType pass -> HsType pass
HsListTy forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
x')
| Bool
otherwise
-> do { LocatedN RdrName
list_tc <- forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ forall thing. NamedThing thing => thing -> RdrName
getRdrName TyCon
listTyCon
; HsType (GhcPass 'Parsed)
-> HsTyPats (GhcPass 'Parsed) -> CvtM (LHsType (GhcPass 'Parsed))
mk_apps (forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar forall a. EpAnn a
noAnn PromotionFlag
NotPromoted LocatedN RdrName
list_tc) [HsArg
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))]
tys' }
VarT Name
nm -> do { LocatedN RdrName
nm' <- Name -> CvtM (LocatedN RdrName)
tNameN Name
nm
; HsType (GhcPass 'Parsed)
-> HsTyPats (GhcPass 'Parsed) -> CvtM (LHsType (GhcPass 'Parsed))
mk_apps (forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar forall a. EpAnn a
noAnn PromotionFlag
NotPromoted LocatedN RdrName
nm') [HsArg
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))]
tys' }
ConT Name
nm -> do { RdrName
nm' <- Name -> CvtM RdrName
tconName Name
nm
; let prom :: PromotionFlag
prom = RdrName -> PromotionFlag
name_promotedness RdrName
nm'
; LocatedN RdrName
lnm' <- forall e ann. e -> CvtM (LocatedAn ann e)
returnLA RdrName
nm'
; HsType (GhcPass 'Parsed)
-> HsTyPats (GhcPass 'Parsed) -> CvtM (LHsType (GhcPass 'Parsed))
mk_apps (forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar forall a. EpAnn a
noAnn PromotionFlag
prom LocatedN RdrName
lnm') [HsArg
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))]
tys'}
ForallT [TyVarBndr Specificity]
tvs [Type]
cxt Type
ty
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [HsArg
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))]
tys'
-> do { [GenLocated
SrcSpanAnnA (HsTyVarBndr Specificity (GhcPass 'Parsed))]
tvs' <- forall flag flag'.
CvtFlag flag flag' =>
[TyVarBndr flag] -> CvtM [LHsTyVarBndr flag' (GhcPass 'Parsed)]
cvtTvs [TyVarBndr Specificity]
tvs
; GenLocated
SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
cxt' <- PprPrec -> [Type] -> CvtM (LHsContext (GhcPass 'Parsed))
cvtContext PprPrec
funPrec [Type]
cxt
; GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
ty' <- Type -> CvtM (LHsType (GhcPass 'Parsed))
cvtType Type
ty
; SrcSpan
loc <- CvtM SrcSpan
getL
; let loc' :: SrcSpanAnnA
loc' = forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc
; let tele :: HsForAllTelescope (GhcPass 'Parsed)
tele = forall (p :: Pass).
EpAnnForallTy
-> [LHsTyVarBndr Specificity (GhcPass p)]
-> HsForAllTelescope (GhcPass p)
mkHsForAllInvisTele forall a. EpAnn a
noAnn [GenLocated
SrcSpanAnnA (HsTyVarBndr Specificity (GhcPass 'Parsed))]
tvs'
hs_ty :: LHsType (GhcPass 'Parsed)
hs_ty = SrcSpanAnnA
-> HsForAllTelescope (GhcPass 'Parsed)
-> LHsType (GhcPass 'Parsed)
-> LHsType (GhcPass 'Parsed)
mkHsForAllTy SrcSpanAnnA
loc' HsForAllTelescope (GhcPass 'Parsed)
tele LHsType (GhcPass 'Parsed)
rho_ty
rho_ty :: LHsType (GhcPass 'Parsed)
rho_ty = [Type]
-> SrcSpanAnnA
-> LHsContext (GhcPass 'Parsed)
-> LHsType (GhcPass 'Parsed)
-> LHsType (GhcPass 'Parsed)
mkHsQualTy [Type]
cxt SrcSpanAnnA
loc' GenLocated
SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
cxt' GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
ty'
; forall (m :: * -> *) a. Monad m => a -> m a
return LHsType (GhcPass 'Parsed)
hs_ty }
ForallVisT [TyVarBndr ()]
tvs Type
ty
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [HsArg
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))]
tys'
-> do { [GenLocated SrcSpanAnnA (HsTyVarBndr () (GhcPass 'Parsed))]
tvs' <- forall flag flag'.
CvtFlag flag flag' =>
[TyVarBndr flag] -> CvtM [LHsTyVarBndr flag' (GhcPass 'Parsed)]
cvtTvs [TyVarBndr ()]
tvs
; GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
ty' <- Type -> CvtM (LHsType (GhcPass 'Parsed))
cvtType Type
ty
; SrcSpan
loc <- CvtM SrcSpan
getL
; let loc' :: SrcSpanAnnA
loc' = forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc
; let tele :: HsForAllTelescope (GhcPass 'Parsed)
tele = forall (p :: Pass).
EpAnnForallTy
-> [LHsTyVarBndr () (GhcPass p)] -> HsForAllTelescope (GhcPass p)
mkHsForAllVisTele forall a. EpAnn a
noAnn [GenLocated SrcSpanAnnA (HsTyVarBndr () (GhcPass 'Parsed))]
tvs'
; forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA
-> HsForAllTelescope (GhcPass 'Parsed)
-> LHsType (GhcPass 'Parsed)
-> LHsType (GhcPass 'Parsed)
mkHsForAllTy SrcSpanAnnA
loc' HsForAllTelescope (GhcPass 'Parsed)
tele GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
ty' }
SigT Type
ty Type
ki
-> do { GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
ty' <- Type -> CvtM (LHsType (GhcPass 'Parsed))
cvtType Type
ty
; GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
ki' <- Type -> CvtM (LHsType (GhcPass 'Parsed))
cvtKind Type
ki
; HsType (GhcPass 'Parsed)
-> HsTyPats (GhcPass 'Parsed) -> CvtM (LHsType (GhcPass 'Parsed))
mk_apps (forall pass.
XKindSig pass -> LHsType pass -> LHsType pass -> HsType pass
HsKindSig forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
ty' GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
ki') [HsArg
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))]
tys'
}
LitT TyLit
lit
-> HsType (GhcPass 'Parsed)
-> HsTyPats (GhcPass 'Parsed) -> CvtM (LHsType (GhcPass 'Parsed))
mk_apps (forall pass. XTyLit pass -> HsTyLit -> HsType pass
HsTyLit NoExtField
noExtField (TyLit -> HsTyLit
cvtTyLit TyLit
lit)) [HsArg
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))]
tys'
Type
WildCardT
-> HsType (GhcPass 'Parsed)
-> HsTyPats (GhcPass 'Parsed) -> CvtM (LHsType (GhcPass 'Parsed))
mk_apps HsType (GhcPass 'Parsed)
mkAnonWildCardTy [HsArg
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))]
tys'
InfixT Type
t1 Name
s Type
t2
-> do { RdrName
s' <- Name -> CvtM RdrName
tconName Name
s
; GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
t1' <- Type -> CvtM (LHsType (GhcPass 'Parsed))
cvtType Type
t1
; GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
t2' <- Type -> CvtM (LHsType (GhcPass 'Parsed))
cvtType Type
t2
; let prom :: PromotionFlag
prom = RdrName -> PromotionFlag
name_promotedness RdrName
s'
; LocatedN RdrName
ls' <- forall e ann. e -> CvtM (LocatedAn ann e)
returnLA RdrName
s'
; HsType (GhcPass 'Parsed)
-> HsTyPats (GhcPass 'Parsed) -> CvtM (LHsType (GhcPass 'Parsed))
mk_apps
(forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar forall a. EpAnn a
noAnn PromotionFlag
prom LocatedN RdrName
ls')
([forall tm ty. tm -> HsArg tm ty
HsValArg GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
t1', forall tm ty. tm -> HsArg tm ty
HsValArg GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
t2'] forall a. [a] -> [a] -> [a]
++ [HsArg
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))]
tys')
}
UInfixT Type
t1 Name
s Type
t2
-> do { LocatedN RdrName
s' <- Name -> CvtM (LocatedN RdrName)
tconNameN Name
s
; GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
t2' <- Type -> CvtM (LHsType (GhcPass 'Parsed))
cvtType Type
t2
; GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
t <- PromotionFlag
-> Type
-> LocatedN RdrName
-> LHsType (GhcPass 'Parsed)
-> CvtM (LHsType (GhcPass 'Parsed))
cvtOpAppT PromotionFlag
NotPromoted Type
t1 LocatedN RdrName
s' GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
t2'
; HsType (GhcPass 'Parsed)
-> HsTyPats (GhcPass 'Parsed) -> CvtM (LHsType (GhcPass 'Parsed))
mk_apps (forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
t) [HsArg
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))]
tys'
}
PromotedInfixT Type
t1 Name
s Type
t2
-> do { LocatedN RdrName
s' <- Name -> CvtM (LocatedN RdrName)
cNameN Name
s
; GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
t1' <- Type -> CvtM (LHsType (GhcPass 'Parsed))
cvtType Type
t1
; GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
t2' <- Type -> CvtM (LHsType (GhcPass 'Parsed))
cvtType Type
t2
; HsType (GhcPass 'Parsed)
-> HsTyPats (GhcPass 'Parsed) -> CvtM (LHsType (GhcPass 'Parsed))
mk_apps
(forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar forall a. EpAnn a
noAnn PromotionFlag
IsPromoted LocatedN RdrName
s')
([forall tm ty. tm -> HsArg tm ty
HsValArg GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
t1', forall tm ty. tm -> HsArg tm ty
HsValArg GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
t2'] forall a. [a] -> [a] -> [a]
++ [HsArg
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))]
tys')
}
PromotedUInfixT Type
t1 Name
s Type
t2
-> do { LocatedN RdrName
s' <- Name -> CvtM (LocatedN RdrName)
cNameN Name
s
; GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
t2' <- Type -> CvtM (LHsType (GhcPass 'Parsed))
cvtType Type
t2
; GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
t <- PromotionFlag
-> Type
-> LocatedN RdrName
-> LHsType (GhcPass 'Parsed)
-> CvtM (LHsType (GhcPass 'Parsed))
cvtOpAppT PromotionFlag
IsPromoted Type
t1 LocatedN RdrName
s' GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
t2'
; HsType (GhcPass 'Parsed)
-> HsTyPats (GhcPass 'Parsed) -> CvtM (LHsType (GhcPass 'Parsed))
mk_apps (forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
t) [HsArg
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))]
tys'
}
ParensT Type
t
-> do { GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
t' <- Type -> CvtM (LHsType (GhcPass 'Parsed))
cvtType Type
t
; HsType (GhcPass 'Parsed)
-> HsTyPats (GhcPass 'Parsed) -> CvtM (LHsType (GhcPass 'Parsed))
mk_apps (forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
t') [HsArg
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))]
tys'
}
PromotedT Name
nm -> do { LocatedN RdrName
nm' <- Name -> CvtM (LocatedN RdrName)
cNameN Name
nm
; HsType (GhcPass 'Parsed)
-> HsTyPats (GhcPass 'Parsed) -> CvtM (LHsType (GhcPass 'Parsed))
mk_apps (forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar forall a. EpAnn a
noAnn PromotionFlag
IsPromoted LocatedN RdrName
nm')
[HsArg
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))]
tys' }
PromotedTupleT Int
n
| Just [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
normals <- Maybe [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
m_normals
, [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
normals forall a. [a] -> Int -> Bool
`lengthIs` Int
n
-> forall e ann. e -> CvtM (LocatedAn ann e)
returnLA (forall pass. XExplicitTupleTy pass -> [LHsType pass] -> HsType pass
HsExplicitTupleTy forall a. EpAnn a
noAnn [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
normals)
| Bool
otherwise
-> do { LocatedN RdrName
tuple_tc <- forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ forall thing. NamedThing thing => thing -> RdrName
getRdrName forall a b. (a -> b) -> a -> b
$ Boxity -> Int -> DataCon
tupleDataCon Boxity
Boxed Int
n
; HsType (GhcPass 'Parsed)
-> HsTyPats (GhcPass 'Parsed) -> CvtM (LHsType (GhcPass 'Parsed))
mk_apps (forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar forall a. EpAnn a
noAnn PromotionFlag
IsPromoted LocatedN RdrName
tuple_tc) [HsArg
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))]
tys' }
Type
PromotedNilT
-> HsType (GhcPass 'Parsed)
-> HsTyPats (GhcPass 'Parsed) -> CvtM (LHsType (GhcPass 'Parsed))
mk_apps (forall pass.
XExplicitListTy pass
-> PromotionFlag -> [LHsType pass] -> HsType pass
HsExplicitListTy forall a. EpAnn a
noAnn PromotionFlag
IsPromoted []) [HsArg
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))]
tys'
Type
PromotedConsT
| Just [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
normals <- Maybe [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
m_normals
, [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
ty1, L SrcSpanAnnA
_ (HsExplicitListTy XExplicitListTy (GhcPass 'Parsed)
_ PromotionFlag
ip [LHsType (GhcPass 'Parsed)]
tys2)] <- [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
normals
-> forall e ann. e -> CvtM (LocatedAn ann e)
returnLA (forall pass.
XExplicitListTy pass
-> PromotionFlag -> [LHsType pass] -> HsType pass
HsExplicitListTy forall a. EpAnn a
noAnn PromotionFlag
ip (GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
ty1forall a. a -> [a] -> [a]
:[LHsType (GhcPass 'Parsed)]
tys2))
| Bool
otherwise
-> do { LocatedN RdrName
cons_tc <- forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
consDataCon
; HsType (GhcPass 'Parsed)
-> HsTyPats (GhcPass 'Parsed) -> CvtM (LHsType (GhcPass 'Parsed))
mk_apps (forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar forall a. EpAnn a
noAnn PromotionFlag
IsPromoted LocatedN RdrName
cons_tc) [HsArg
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))]
tys' }
Type
StarT
-> do { LocatedN RdrName
type_tc <- forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ forall thing. NamedThing thing => thing -> RdrName
getRdrName TyCon
liftedTypeKindTyCon
; HsType (GhcPass 'Parsed)
-> HsTyPats (GhcPass 'Parsed) -> CvtM (LHsType (GhcPass 'Parsed))
mk_apps (forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar forall a. EpAnn a
noAnn PromotionFlag
NotPromoted LocatedN RdrName
type_tc) [HsArg
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))]
tys' }
Type
ConstraintT
-> do { LocatedN RdrName
constraint_tc <- forall e ann. e -> CvtM (LocatedAn ann e)
returnLA forall a b. (a -> b) -> a -> b
$ forall thing. NamedThing thing => thing -> RdrName
getRdrName TyCon
constraintKindTyCon
; HsType (GhcPass 'Parsed)
-> HsTyPats (GhcPass 'Parsed) -> CvtM (LHsType (GhcPass 'Parsed))
mk_apps (forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar forall a. EpAnn a
noAnn PromotionFlag
NotPromoted LocatedN RdrName
constraint_tc) [HsArg
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))]
tys' }
Type
EqualityT
| Just [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
normals <- Maybe [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
m_normals
, [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
x',GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
y'] <- [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
normals ->
let px :: LHsType (GhcPass 'Parsed)
px = forall (p :: Pass).
PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)
parenthesizeHsType PprPrec
opPrec GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
x'
py :: LHsType (GhcPass 'Parsed)
py = forall (p :: Pass).
PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)
parenthesizeHsType PprPrec
opPrec GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
y'
in do { LocatedN RdrName
eq_tc <- forall e ann. e -> CvtM (LocatedAn ann e)
returnLA RdrName
eqTyCon_RDR
; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA (forall pass.
XOpTy pass
-> PromotionFlag
-> LHsType pass
-> LIdP pass
-> LHsType pass
-> HsType pass
HsOpTy forall a. EpAnn a
noAnn PromotionFlag
NotPromoted LHsType (GhcPass 'Parsed)
px LocatedN RdrName
eq_tc LHsType (GhcPass 'Parsed)
py) }
| Bool
otherwise ->
do { LocatedN RdrName
eq_tc <- forall e ann. e -> CvtM (LocatedAn ann e)
returnLA RdrName
eqTyCon_RDR
; HsType (GhcPass 'Parsed)
-> HsTyPats (GhcPass 'Parsed) -> CvtM (LHsType (GhcPass 'Parsed))
mk_apps (forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar forall a. EpAnn a
noAnn PromotionFlag
NotPromoted LocatedN RdrName
eq_tc) [HsArg
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))]
tys' }
ImplicitParamT String
n Type
t
-> do { Located HsIPName
n' <- forall a. CvtM a -> CvtM (Located a)
wrapL forall a b. (a -> b) -> a -> b
$ String -> CvtM HsIPName
ipName String
n
; GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
t' <- Type -> CvtM (LHsType (GhcPass 'Parsed))
cvtType Type
t
; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA (forall pass.
XIParamTy pass -> XRec pass HsIPName -> LHsType pass -> HsType pass
HsIParamTy forall a. EpAnn a
noAnn (forall e ann. Located e -> LocatedAn ann e
reLocA Located HsIPName
n') GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
t')
}
Type
_ -> forall a. SDoc -> CvtM a
failWith (String -> SDoc
text String
"Malformed " SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
ty_str SDoc -> SDoc -> SDoc
<+> String -> SDoc
text (forall a. Show a => a -> String
show Type
ty))
}
hsTypeToArrow :: LHsType GhcPs -> HsArrow GhcPs
hsTypeToArrow :: LHsType (GhcPass 'Parsed) -> HsArrow (GhcPass 'Parsed)
hsTypeToArrow LHsType (GhcPass 'Parsed)
w = case forall l e. GenLocated l e -> e
unLoc LHsType (GhcPass 'Parsed)
w of
HsTyVar XTyVar (GhcPass 'Parsed)
_ PromotionFlag
_ (L SrcSpanAnnN
_ (RdrName -> Maybe Name
isExact_maybe -> Just Name
n))
| Name
n forall a. Eq a => a -> a -> Bool
== Name
oneDataConName -> forall pass. HsLinearArrowTokens pass -> HsArrow pass
HsLinearArrow (forall pass.
LHsToken "%1" pass
-> LHsUniToken "->" "\8594" pass -> HsLinearArrowTokens pass
HsPct1 forall (tok :: Symbol). GenLocated TokenLocation (HsToken tok)
noHsTok forall (tok :: Symbol) (utok :: Symbol).
GenLocated TokenLocation (HsUniToken tok utok)
noHsUniTok)
| Name
n forall a. Eq a => a -> a -> Bool
== Name
manyDataConName -> forall pass. LHsUniToken "->" "\8594" pass -> HsArrow pass
HsUnrestrictedArrow forall (tok :: Symbol) (utok :: Symbol).
GenLocated TokenLocation (HsUniToken tok utok)
noHsUniTok
HsType (GhcPass 'Parsed)
_ -> forall pass.
LHsToken "%" pass
-> LHsType pass -> LHsUniToken "->" "\8594" pass -> HsArrow pass
HsExplicitMult forall (tok :: Symbol). GenLocated TokenLocation (HsToken tok)
noHsTok LHsType (GhcPass 'Parsed)
w forall (tok :: Symbol) (utok :: Symbol).
GenLocated TokenLocation (HsUniToken tok utok)
noHsUniTok
name_promotedness :: RdrName -> Hs.PromotionFlag
name_promotedness :: RdrName -> PromotionFlag
name_promotedness RdrName
nm
| RdrName -> Bool
isRdrDataCon RdrName
nm = PromotionFlag
IsPromoted
| Bool
otherwise = PromotionFlag
NotPromoted
mk_apps :: HsType GhcPs -> [LHsTypeArg GhcPs] -> CvtM (LHsType GhcPs)
mk_apps :: HsType (GhcPass 'Parsed)
-> HsTyPats (GhcPass 'Parsed) -> CvtM (LHsType (GhcPass 'Parsed))
mk_apps HsType (GhcPass 'Parsed)
head_ty HsTyPats (GhcPass 'Parsed)
type_args = do
GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
head_ty' <- forall e ann. e -> CvtM (LocatedAn ann e)
returnLA HsType (GhcPass 'Parsed)
head_ty
let phead_ty :: LHsType GhcPs
phead_ty :: LHsType (GhcPass 'Parsed)
phead_ty = forall (p :: Pass).
PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)
parenthesizeHsType PprPrec
sigPrec GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
head_ty'
go :: [LHsTypeArg GhcPs] -> CvtM (LHsType GhcPs)
go :: HsTyPats (GhcPass 'Parsed) -> CvtM (LHsType (GhcPass 'Parsed))
go [] = forall (f :: * -> *) a. Applicative f => a -> f a
pure GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
head_ty'
go (LHsTypeArg (GhcPass 'Parsed)
arg:HsTyPats (GhcPass 'Parsed)
args) =
case LHsTypeArg (GhcPass 'Parsed)
arg of
HsValArg LHsType (GhcPass 'Parsed)
ty -> do GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
p_ty <- forall {p :: Pass}.
GenLocated SrcSpanAnnA (HsType (GhcPass p))
-> CvtM (GenLocated SrcSpanAnnA (HsType (GhcPass p)))
add_parens LHsType (GhcPass 'Parsed)
ty
HsType (GhcPass 'Parsed)
-> HsTyPats (GhcPass 'Parsed) -> CvtM (LHsType (GhcPass 'Parsed))
mk_apps (forall pass.
XAppTy pass -> LHsType pass -> LHsType pass -> HsType pass
HsAppTy NoExtField
noExtField LHsType (GhcPass 'Parsed)
phead_ty GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
p_ty) HsTyPats (GhcPass 'Parsed)
args
HsTypeArg SrcSpan
l LHsType (GhcPass 'Parsed)
ki -> do GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
p_ki <- forall {p :: Pass}.
GenLocated SrcSpanAnnA (HsType (GhcPass p))
-> CvtM (GenLocated SrcSpanAnnA (HsType (GhcPass p)))
add_parens LHsType (GhcPass 'Parsed)
ki
HsType (GhcPass 'Parsed)
-> HsTyPats (GhcPass 'Parsed) -> CvtM (LHsType (GhcPass 'Parsed))
mk_apps (forall pass.
XAppKindTy pass -> LHsType pass -> LHsType pass -> HsType pass
HsAppKindTy SrcSpan
l LHsType (GhcPass 'Parsed)
phead_ty GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
p_ki) HsTyPats (GhcPass 'Parsed)
args
HsArgPar SrcSpan
_ -> HsType (GhcPass 'Parsed)
-> HsTyPats (GhcPass 'Parsed) -> CvtM (LHsType (GhcPass 'Parsed))
mk_apps (forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy forall a. EpAnn a
noAnn LHsType (GhcPass 'Parsed)
phead_ty) HsTyPats (GhcPass 'Parsed)
args
HsTyPats (GhcPass 'Parsed) -> CvtM (LHsType (GhcPass 'Parsed))
go HsTyPats (GhcPass 'Parsed)
type_args
where
add_parens :: GenLocated SrcSpanAnnA (HsType (GhcPass p))
-> CvtM (GenLocated SrcSpanAnnA (HsType (GhcPass p)))
add_parens lt :: GenLocated SrcSpanAnnA (HsType (GhcPass p))
lt@(L SrcSpanAnnA
_ HsType (GhcPass p)
t)
| forall (p :: Pass). PprPrec -> HsType (GhcPass p) -> Bool
hsTypeNeedsParens PprPrec
appPrec HsType (GhcPass p)
t = forall e ann. e -> CvtM (LocatedAn ann e)
returnLA (forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (HsType (GhcPass p))
lt)
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return GenLocated SrcSpanAnnA (HsType (GhcPass p))
lt
wrap_tyarg :: LHsTypeArg GhcPs -> LHsTypeArg GhcPs
wrap_tyarg :: LHsTypeArg (GhcPass 'Parsed) -> LHsTypeArg (GhcPass 'Parsed)
wrap_tyarg (HsValArg LHsType (GhcPass 'Parsed)
ty) = forall tm ty. tm -> HsArg tm ty
HsValArg forall a b. (a -> b) -> a -> b
$ forall (p :: Pass).
PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)
parenthesizeHsType PprPrec
appPrec LHsType (GhcPass 'Parsed)
ty
wrap_tyarg (HsTypeArg SrcSpan
l LHsType (GhcPass 'Parsed)
ki) = forall tm ty. SrcSpan -> ty -> HsArg tm ty
HsTypeArg SrcSpan
l forall a b. (a -> b) -> a -> b
$ forall (p :: Pass).
PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)
parenthesizeHsType PprPrec
appPrec LHsType (GhcPass 'Parsed)
ki
wrap_tyarg ta :: LHsTypeArg (GhcPass 'Parsed)
ta@(HsArgPar {}) = LHsTypeArg (GhcPass 'Parsed)
ta
split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsTypeArg GhcPs])
split_ty_app :: Type -> CvtM (Type, HsTyPats (GhcPass 'Parsed))
split_ty_app Type
ty = Type
-> [HsArg
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))]
-> CvtM
(Type,
[HsArg
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))])
go Type
ty []
where
go :: Type
-> [HsArg
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))]
-> CvtM
(Type,
[HsArg
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))])
go (AppT Type
f Type
a) [HsArg
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))]
as' = do { GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
a' <- Type -> CvtM (LHsType (GhcPass 'Parsed))
cvtType Type
a; Type
-> [HsArg
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))]
-> CvtM
(Type,
[HsArg
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))])
go Type
f (forall tm ty. tm -> HsArg tm ty
HsValArg GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
a'forall a. a -> [a] -> [a]
:[HsArg
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))]
as') }
go (AppKindT Type
ty Type
ki) [HsArg
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))]
as' = do { GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
ki' <- Type -> CvtM (LHsType (GhcPass 'Parsed))
cvtKind Type
ki
; Type
-> [HsArg
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))]
-> CvtM
(Type,
[HsArg
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))])
go Type
ty (forall tm ty. SrcSpan -> ty -> HsArg tm ty
HsTypeArg SrcSpan
noSrcSpan GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
ki'forall a. a -> [a] -> [a]
:[HsArg
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))]
as') }
go (ParensT Type
t) [HsArg
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))]
as' = do { SrcSpan
loc <- CvtM SrcSpan
getL; Type
-> [HsArg
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))]
-> CvtM
(Type,
[HsArg
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))])
go Type
t (forall tm ty. SrcSpan -> HsArg tm ty
HsArgPar SrcSpan
locforall a. a -> [a] -> [a]
: [HsArg
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))]
as') }
go Type
f [HsArg
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))]
as = forall (m :: * -> *) a. Monad m => a -> m a
return (Type
f,[HsArg
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))]
as)
cvtTyLit :: TH.TyLit -> HsTyLit
cvtTyLit :: TyLit -> HsTyLit
cvtTyLit (TH.NumTyLit Integer
i) = SourceText -> Integer -> HsTyLit
HsNumTy SourceText
NoSourceText Integer
i
cvtTyLit (TH.StrTyLit String
s) = SourceText -> CLabelString -> HsTyLit
HsStrTy SourceText
NoSourceText (String -> CLabelString
fsLit String
s)
cvtTyLit (TH.CharTyLit Char
c) = SourceText -> Char -> HsTyLit
HsCharTy SourceText
NoSourceText Char
c
cvtOpAppT :: PromotionFlag -> TH.Type -> LocatedN RdrName -> LHsType GhcPs -> CvtM (LHsType GhcPs)
cvtOpAppT :: PromotionFlag
-> Type
-> LocatedN RdrName
-> LHsType (GhcPass 'Parsed)
-> CvtM (LHsType (GhcPass 'Parsed))
cvtOpAppT PromotionFlag
prom (UInfixT Type
x Name
op2 Type
y) LocatedN RdrName
op1 LHsType (GhcPass 'Parsed)
z
= do { LocatedN RdrName
op2' <- Name -> CvtM (LocatedN RdrName)
tconNameN Name
op2
; GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
l <- PromotionFlag
-> Type
-> LocatedN RdrName
-> LHsType (GhcPass 'Parsed)
-> CvtM (LHsType (GhcPass 'Parsed))
cvtOpAppT PromotionFlag
prom Type
y LocatedN RdrName
op1 LHsType (GhcPass 'Parsed)
z
; PromotionFlag
-> Type
-> LocatedN RdrName
-> LHsType (GhcPass 'Parsed)
-> CvtM (LHsType (GhcPass 'Parsed))
cvtOpAppT PromotionFlag
NotPromoted Type
x LocatedN RdrName
op2' GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
l }
cvtOpAppT PromotionFlag
prom (PromotedUInfixT Type
x Name
op2 Type
y) LocatedN RdrName
op1 LHsType (GhcPass 'Parsed)
z
= do { LocatedN RdrName
op2' <- Name -> CvtM (LocatedN RdrName)
cNameN Name
op2
; GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
l <- PromotionFlag
-> Type
-> LocatedN RdrName
-> LHsType (GhcPass 'Parsed)
-> CvtM (LHsType (GhcPass 'Parsed))
cvtOpAppT PromotionFlag
prom Type
y LocatedN RdrName
op1 LHsType (GhcPass 'Parsed)
z
; PromotionFlag
-> Type
-> LocatedN RdrName
-> LHsType (GhcPass 'Parsed)
-> CvtM (LHsType (GhcPass 'Parsed))
cvtOpAppT PromotionFlag
IsPromoted Type
x LocatedN RdrName
op2' GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
l }
cvtOpAppT PromotionFlag
prom Type
x LocatedN RdrName
op LHsType (GhcPass 'Parsed)
y
= do { GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
x' <- Type -> CvtM (LHsType (GhcPass 'Parsed))
cvtType Type
x
; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA (forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
PromotionFlag
-> LHsType (GhcPass p)
-> LocatedN (IdP (GhcPass p))
-> LHsType (GhcPass p)
-> HsType (GhcPass p)
mkHsOpTy PromotionFlag
prom GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
x' LocatedN RdrName
op LHsType (GhcPass 'Parsed)
y) }
cvtKind :: TH.Kind -> CvtM (LHsKind GhcPs)
cvtKind :: Type -> CvtM (LHsType (GhcPass 'Parsed))
cvtKind = String -> Type -> CvtM (LHsType (GhcPass 'Parsed))
cvtTypeKind String
"kind"
cvtSigKind :: TH.Kind -> CvtM (LHsSigType GhcPs)
cvtSigKind :: Type -> CvtM (LHsSigType (GhcPass 'Parsed))
cvtSigKind = String -> Type -> CvtM (LHsSigType (GhcPass 'Parsed))
cvtSigTypeKind String
"kind"
cvtMaybeKindToFamilyResultSig :: Maybe TH.Kind
-> CvtM (LFamilyResultSig GhcPs)
cvtMaybeKindToFamilyResultSig :: Maybe Type -> CvtM (LFamilyResultSig (GhcPass 'Parsed))
cvtMaybeKindToFamilyResultSig Maybe Type
Nothing = forall e ann. e -> CvtM (LocatedAn ann e)
returnLA (forall pass. XNoSig pass -> FamilyResultSig pass
Hs.NoSig NoExtField
noExtField)
cvtMaybeKindToFamilyResultSig (Just Type
ki) = do { GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
ki' <- Type -> CvtM (LHsType (GhcPass 'Parsed))
cvtKind Type
ki
; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA (forall pass. XCKindSig pass -> LHsKind pass -> FamilyResultSig pass
Hs.KindSig NoExtField
noExtField GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
ki') }
cvtFamilyResultSig :: TH.FamilyResultSig -> CvtM (Hs.LFamilyResultSig GhcPs)
cvtFamilyResultSig :: FamilyResultSig -> CvtM (LFamilyResultSig (GhcPass 'Parsed))
cvtFamilyResultSig FamilyResultSig
TH.NoSig = forall e ann. e -> CvtM (LocatedAn ann e)
returnLA (forall pass. XNoSig pass -> FamilyResultSig pass
Hs.NoSig NoExtField
noExtField)
cvtFamilyResultSig (TH.KindSig Type
ki) = do { GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
ki' <- Type -> CvtM (LHsType (GhcPass 'Parsed))
cvtKind Type
ki
; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA (forall pass. XCKindSig pass -> LHsKind pass -> FamilyResultSig pass
Hs.KindSig NoExtField
noExtField GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
ki') }
cvtFamilyResultSig (TH.TyVarSig TyVarBndr ()
bndr) = do { GenLocated SrcSpanAnnA (HsTyVarBndr () (GhcPass 'Parsed))
tv <- forall flag flag'.
CvtFlag flag flag' =>
TyVarBndr flag -> CvtM (LHsTyVarBndr flag' (GhcPass 'Parsed))
cvt_tv TyVarBndr ()
bndr
; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA (forall pass.
XTyVarSig pass -> LHsTyVarBndr () pass -> FamilyResultSig pass
Hs.TyVarSig NoExtField
noExtField GenLocated SrcSpanAnnA (HsTyVarBndr () (GhcPass 'Parsed))
tv) }
cvtInjectivityAnnotation :: TH.InjectivityAnn
-> CvtM (Hs.LInjectivityAnn GhcPs)
cvtInjectivityAnnotation :: InjectivityAnn -> CvtM (LInjectivityAnn (GhcPass 'Parsed))
cvtInjectivityAnnotation (TH.InjectivityAnn Name
annLHS [Name]
annRHS)
= do { LocatedN RdrName
annLHS' <- Name -> CvtM (LocatedN RdrName)
tNameN Name
annLHS
; [LocatedN RdrName]
annRHS' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> CvtM (LocatedN RdrName)
tNameN [Name]
annRHS
; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA (forall pass.
XCInjectivityAnn pass
-> LIdP pass -> [LIdP pass] -> InjectivityAnn pass
Hs.InjectivityAnn forall a. EpAnn a
noAnn LocatedN RdrName
annLHS' [LocatedN RdrName]
annRHS') }
cvtPatSynSigTy :: TH.Type -> CvtM (LHsSigType GhcPs)
cvtPatSynSigTy :: Type -> CvtM (LHsSigType (GhcPass 'Parsed))
cvtPatSynSigTy (ForallT [TyVarBndr Specificity]
univs [Type]
reqs (ForallT [TyVarBndr Specificity]
exis [Type]
provs Type
ty))
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVarBndr Specificity]
exis, forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
provs = Type -> CvtM (LHsSigType (GhcPass 'Parsed))
cvtSigType ([TyVarBndr Specificity] -> [Type] -> Type -> Type
ForallT [TyVarBndr Specificity]
univs [Type]
reqs Type
ty)
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVarBndr Specificity]
univs, forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
reqs = do { GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
ty' <- Type -> CvtM (LHsType (GhcPass 'Parsed))
cvtType ([TyVarBndr Specificity] -> [Type] -> Type -> Type
ForallT [TyVarBndr Specificity]
exis [Type]
provs Type
ty)
; GenLocated
SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
ctxt' <- forall e ann. e -> CvtM (LocatedAn ann e)
returnLA []
; HsSigType (GhcPass 'Parsed)
cxtTy <- forall ann a b. (LocatedAn ann a -> b) -> a -> CvtM b
wrapParLA LHsType (GhcPass 'Parsed) -> HsSigType (GhcPass 'Parsed)
mkHsImplicitSigType forall a b. (a -> b) -> a -> b
$
HsQualTy { hst_ctxt :: LHsContext (GhcPass 'Parsed)
hst_ctxt = GenLocated
SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
ctxt'
, hst_xqual :: XQualTy (GhcPass 'Parsed)
hst_xqual = NoExtField
noExtField
, hst_body :: LHsType (GhcPass 'Parsed)
hst_body = GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
ty' }
; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA HsSigType (GhcPass 'Parsed)
cxtTy }
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
reqs = do { [GenLocated
SrcSpanAnnA (HsTyVarBndr Specificity (GhcPass 'Parsed))]
univs' <- forall flag flag'.
CvtFlag flag flag' =>
[TyVarBndr flag] -> CvtM [LHsTyVarBndr flag' (GhcPass 'Parsed)]
cvtTvs [TyVarBndr Specificity]
univs
; GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
ty' <- Type -> CvtM (LHsType (GhcPass 'Parsed))
cvtType ([TyVarBndr Specificity] -> [Type] -> Type -> Type
ForallT [TyVarBndr Specificity]
exis [Type]
provs Type
ty)
; LocatedAn AnnContext [LHsType (GhcPass 'Parsed)]
ctxt' <- forall e ann. e -> CvtM (LocatedAn ann e)
returnLA []
; let cxtTy :: HsType (GhcPass 'Parsed)
cxtTy = HsQualTy { hst_ctxt :: LHsContext (GhcPass 'Parsed)
hst_ctxt = LocatedAn AnnContext [LHsType (GhcPass 'Parsed)]
ctxt'
, hst_xqual :: XQualTy (GhcPass 'Parsed)
hst_xqual = NoExtField
noExtField
, hst_body :: LHsType (GhcPass 'Parsed)
hst_body = GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
ty' }
; HsSigType (GhcPass 'Parsed)
forTy <- forall ann a b. (LocatedAn ann a -> b) -> a -> CvtM b
wrapParLA (EpAnnForallTy
-> [LHsTyVarBndr Specificity (GhcPass 'Parsed)]
-> LHsType (GhcPass 'Parsed)
-> HsSigType (GhcPass 'Parsed)
mkHsExplicitSigType forall a. EpAnn a
noAnn [GenLocated
SrcSpanAnnA (HsTyVarBndr Specificity (GhcPass 'Parsed))]
univs') HsType (GhcPass 'Parsed)
cxtTy
; forall e ann. e -> CvtM (LocatedAn ann e)
returnLA HsSigType (GhcPass 'Parsed)
forTy }
| Bool
otherwise = Type -> CvtM (LHsSigType (GhcPass 'Parsed))
cvtSigType ([TyVarBndr Specificity] -> [Type] -> Type -> Type
ForallT [TyVarBndr Specificity]
univs [Type]
reqs ([TyVarBndr Specificity] -> [Type] -> Type -> Type
ForallT [TyVarBndr Specificity]
exis [Type]
provs Type
ty))
cvtPatSynSigTy Type
ty = Type -> CvtM (LHsSigType (GhcPass 'Parsed))
cvtSigType Type
ty
cvtFixity :: TH.Fixity -> Hs.Fixity
cvtFixity :: Fixity -> Fixity
cvtFixity (TH.Fixity Int
prec FixityDirection
dir) = SourceText -> Int -> FixityDirection -> Fixity
Hs.Fixity SourceText
NoSourceText Int
prec (FixityDirection -> FixityDirection
cvt_dir FixityDirection
dir)
where
cvt_dir :: FixityDirection -> FixityDirection
cvt_dir FixityDirection
TH.InfixL = FixityDirection
Hs.InfixL
cvt_dir FixityDirection
TH.InfixR = FixityDirection
Hs.InfixR
cvt_dir FixityDirection
TH.InfixN = FixityDirection
Hs.InfixN
overloadedLit :: Lit -> Bool
overloadedLit :: Lit -> Bool
overloadedLit (IntegerL Integer
_) = Bool
True
overloadedLit (RationalL Rational
_) = Bool
True
overloadedLit Lit
_ = Bool
False
unboxedSumChecks :: TH.SumAlt -> TH.SumArity -> CvtM ()
unboxedSumChecks :: Int -> Int -> CvtM ()
unboxedSumChecks Int
alt Int
arity
| Int
alt forall a. Ord a => a -> a -> Bool
> Int
arity
= forall a. SDoc -> CvtM a
failWith forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"Sum alternative" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text (forall a. Show a => a -> String
show Int
alt)
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"exceeds its arity," SDoc -> SDoc -> SDoc
<+> String -> SDoc
text (forall a. Show a => a -> String
show Int
arity)
| Int
alt forall a. Ord a => a -> a -> Bool
<= Int
0
= forall a. SDoc -> CvtM a
failWith forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Illegal sum alternative:" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text (forall a. Show a => a -> String
show Int
alt)
, Int -> SDoc -> SDoc
nest Int
2 forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"Sum alternatives must start from 1" ]
| Int
arity forall a. Ord a => a -> a -> Bool
< Int
2
= forall a. SDoc -> CvtM a
failWith forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Illegal sum arity:" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text (forall a. Show a => a -> String
show Int
arity)
, Int -> SDoc -> SDoc
nest Int
2 forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"Sums must have an arity of at least 2" ]
| Bool
otherwise
= forall (m :: * -> *) a. Monad m => a -> m a
return ()
mkHsForAllTy :: SrcSpanAnnA
-> HsForAllTelescope GhcPs
-> LHsType GhcPs
-> LHsType GhcPs
mkHsForAllTy :: SrcSpanAnnA
-> HsForAllTelescope (GhcPass 'Parsed)
-> LHsType (GhcPass 'Parsed)
-> LHsType (GhcPass 'Parsed)
mkHsForAllTy SrcSpanAnnA
loc HsForAllTelescope (GhcPass 'Parsed)
tele LHsType (GhcPass 'Parsed)
rho_ty
| Bool
no_tvs = LHsType (GhcPass 'Parsed)
rho_ty
| Bool
otherwise = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc forall a b. (a -> b) -> a -> b
$ HsForAllTy { hst_tele :: HsForAllTelescope (GhcPass 'Parsed)
hst_tele = HsForAllTelescope (GhcPass 'Parsed)
tele
, hst_xforall :: XForAllTy (GhcPass 'Parsed)
hst_xforall = NoExtField
noExtField
, hst_body :: LHsType (GhcPass 'Parsed)
hst_body = LHsType (GhcPass 'Parsed)
rho_ty }
where
no_tvs :: Bool
no_tvs = case HsForAllTelescope (GhcPass 'Parsed)
tele of
HsForAllVis { hsf_vis_bndrs :: forall pass. HsForAllTelescope pass -> [LHsTyVarBndr () pass]
hsf_vis_bndrs = [LHsTyVarBndr () (GhcPass 'Parsed)]
bndrs } -> forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LHsTyVarBndr () (GhcPass 'Parsed)]
bndrs
HsForAllInvis { hsf_invis_bndrs :: forall pass.
HsForAllTelescope pass -> [LHsTyVarBndr Specificity pass]
hsf_invis_bndrs = [LHsTyVarBndr Specificity (GhcPass 'Parsed)]
bndrs } -> forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LHsTyVarBndr Specificity (GhcPass 'Parsed)]
bndrs
mkHsQualTy :: TH.Cxt
-> SrcSpanAnnA
-> LHsContext GhcPs
-> LHsType GhcPs
-> LHsType GhcPs
mkHsQualTy :: [Type]
-> SrcSpanAnnA
-> LHsContext (GhcPass 'Parsed)
-> LHsType (GhcPass 'Parsed)
-> LHsType (GhcPass 'Parsed)
mkHsQualTy [Type]
ctxt SrcSpanAnnA
loc LHsContext (GhcPass 'Parsed)
ctxt' LHsType (GhcPass 'Parsed)
ty
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
ctxt = LHsType (GhcPass 'Parsed)
ty
| Bool
otherwise = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc forall a b. (a -> b) -> a -> b
$ HsQualTy { hst_xqual :: XQualTy (GhcPass 'Parsed)
hst_xqual = NoExtField
noExtField
, hst_ctxt :: LHsContext (GhcPass 'Parsed)
hst_ctxt = LHsContext (GhcPass 'Parsed)
ctxt'
, hst_body :: LHsType (GhcPass 'Parsed)
hst_body = LHsType (GhcPass 'Parsed)
ty }
mkHsContextMaybe :: LHsContext GhcPs -> Maybe (LHsContext GhcPs)
mkHsContextMaybe :: LHsContext (GhcPass 'Parsed)
-> Maybe (LHsContext (GhcPass 'Parsed))
mkHsContextMaybe lctxt :: LHsContext (GhcPass 'Parsed)
lctxt@(L SrcSpanAnnC
_ [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
ctxt)
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))]
ctxt = forall a. Maybe a
Nothing
| Bool
otherwise = forall a. a -> Maybe a
Just LHsContext (GhcPass 'Parsed)
lctxt
mkHsOuterFamEqnTyVarBndrs :: Maybe [LHsTyVarBndr () GhcPs] -> HsOuterFamEqnTyVarBndrs GhcPs
mkHsOuterFamEqnTyVarBndrs :: Maybe [LHsTyVarBndr () (GhcPass 'Parsed)]
-> HsOuterFamEqnTyVarBndrs (GhcPass 'Parsed)
mkHsOuterFamEqnTyVarBndrs = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall flag. HsOuterTyVarBndrs flag (GhcPass 'Parsed)
mkHsOuterImplicit (forall flag.
EpAnnForallTy
-> [LHsTyVarBndr flag (GhcPass 'Parsed)]
-> HsOuterTyVarBndrs flag (GhcPass 'Parsed)
mkHsOuterExplicit forall a. EpAnn a
noAnn)
vNameN, cNameN, vcNameN, tNameN, tconNameN :: TH.Name -> CvtM (LocatedN RdrName)
vNameL :: TH.Name -> CvtM (LocatedA RdrName)
vName, cName, vcName, tName, tconName :: TH.Name -> CvtM RdrName
vNameN :: Name -> CvtM (LocatedN RdrName)
vNameN Name
n = forall a. CvtM a -> CvtM (LocatedN a)
wrapLN (Name -> CvtM RdrName
vName Name
n)
vNameL :: Name -> CvtM (LocatedA RdrName)
vNameL Name
n = forall a. CvtM a -> CvtM (LocatedA a)
wrapLA (Name -> CvtM RdrName
vName Name
n)
vName :: Name -> CvtM RdrName
vName Name
n = NameSpace -> Name -> CvtM RdrName
cvtName NameSpace
OccName.varName Name
n
cNameN :: Name -> CvtM (LocatedN RdrName)
cNameN Name
n = forall a. CvtM a -> CvtM (LocatedN a)
wrapLN (Name -> CvtM RdrName
cName Name
n)
cName :: Name -> CvtM RdrName
cName Name
n = NameSpace -> Name -> CvtM RdrName
cvtName NameSpace
OccName.dataName Name
n
vcNameN :: Name -> CvtM (LocatedN RdrName)
vcNameN Name
n = forall a. CvtM a -> CvtM (LocatedN a)
wrapLN (Name -> CvtM RdrName
vcName Name
n)
vcName :: Name -> CvtM RdrName
vcName Name
n = if Name -> Bool
isVarName Name
n then Name -> CvtM RdrName
vName Name
n else Name -> CvtM RdrName
cName Name
n
tNameN :: Name -> CvtM (LocatedN RdrName)
tNameN Name
n = forall a. CvtM a -> CvtM (LocatedN a)
wrapLN (Name -> CvtM RdrName
tName Name
n)
tName :: Name -> CvtM RdrName
tName Name
n = NameSpace -> Name -> CvtM RdrName
cvtName NameSpace
OccName.tvName Name
n
tconNameN :: Name -> CvtM (LocatedN RdrName)
tconNameN Name
n = forall a. CvtM a -> CvtM (LocatedN a)
wrapLN (Name -> CvtM RdrName
tconName Name
n)
tconName :: Name -> CvtM RdrName
tconName Name
n = NameSpace -> Name -> CvtM RdrName
cvtName NameSpace
OccName.tcClsName Name
n
ipName :: String -> CvtM HsIPName
ipName :: String -> CvtM HsIPName
ipName String
n
= do { forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String -> Bool
okVarOcc String
n) (forall a. SDoc -> CvtM a
failWith (NameSpace -> String -> SDoc
badOcc NameSpace
OccName.varName String
n))
; forall (m :: * -> *) a. Monad m => a -> m a
return (CLabelString -> HsIPName
HsIPName (String -> CLabelString
fsLit String
n)) }
cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName
cvtName :: NameSpace -> Name -> CvtM RdrName
cvtName NameSpace
ctxt_ns (TH.Name OccName
occ NameFlavour
flavour)
| Bool -> Bool
not (NameSpace -> String -> Bool
okOcc NameSpace
ctxt_ns String
occ_str) = forall a. SDoc -> CvtM a
failWith (NameSpace -> String -> SDoc
badOcc NameSpace
ctxt_ns String
occ_str)
| Bool
otherwise
= do { SrcSpan
loc <- CvtM SrcSpan
getL
; let rdr_name :: RdrName
rdr_name = SrcSpan -> NameSpace -> String -> NameFlavour -> RdrName
thRdrName SrcSpan
loc NameSpace
ctxt_ns String
occ_str NameFlavour
flavour
; forall a. a -> CvtM ()
force RdrName
rdr_name
; forall (m :: * -> *) a. Monad m => a -> m a
return RdrName
rdr_name }
where
occ_str :: String
occ_str = OccName -> String
TH.occString OccName
occ
okOcc :: OccName.NameSpace -> String -> Bool
okOcc :: NameSpace -> String -> Bool
okOcc NameSpace
ns String
str
| NameSpace -> Bool
OccName.isVarNameSpace NameSpace
ns = String -> Bool
okVarOcc String
str
| NameSpace -> Bool
OccName.isDataConNameSpace NameSpace
ns = String -> Bool
okConOcc String
str
| Bool
otherwise = String -> Bool
okTcOcc String
str
isVarName :: TH.Name -> Bool
isVarName :: Name -> Bool
isVarName (TH.Name OccName
occ NameFlavour
_)
= case OccName -> String
TH.occString OccName
occ of
String
"" -> Bool
False
(Char
c:String
_) -> Char -> Bool
startsVarId Char
c Bool -> Bool -> Bool
|| Char -> Bool
startsVarSym Char
c
badOcc :: OccName.NameSpace -> String -> SDoc
badOcc :: NameSpace -> String -> SDoc
badOcc NameSpace
ctxt_ns String
occ
= String -> SDoc
text String
"Illegal" SDoc -> SDoc -> SDoc
<+> NameSpace -> SDoc
pprNameSpace NameSpace
ctxt_ns
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"name:" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (String -> SDoc
text String
occ)
thRdrName :: SrcSpan -> OccName.NameSpace -> String -> TH.NameFlavour -> RdrName
thRdrName :: SrcSpan -> NameSpace -> String -> NameFlavour -> RdrName
thRdrName SrcSpan
loc NameSpace
ctxt_ns String
th_occ NameFlavour
th_name
= case NameFlavour
th_name of
TH.NameG NameSpace
th_ns PkgName
pkg ModName
mod -> String -> NameSpace -> PkgName -> ModName -> RdrName
thOrigRdrName String
th_occ NameSpace
th_ns PkgName
pkg ModName
mod
TH.NameQ ModName
mod -> (ModuleName -> OccName -> RdrName
mkRdrQual forall a b. (a -> b) -> a -> b
$! ModName -> ModuleName
mk_mod ModName
mod) forall a b. (a -> b) -> a -> b
$! OccName
occ
TH.NameL Integer
uniq -> Name -> RdrName
nameRdrName forall a b. (a -> b) -> a -> b
$! (((Unique -> OccName -> SrcSpan -> Name
Name.mkInternalName forall a b. (a -> b) -> a -> b
$! Int -> Unique
mk_uniq (forall a. Num a => Integer -> a
fromInteger Integer
uniq)) forall a b. (a -> b) -> a -> b
$! OccName
occ) SrcSpan
loc)
TH.NameU Integer
uniq -> Name -> RdrName
nameRdrName forall a b. (a -> b) -> a -> b
$! (((Unique -> OccName -> SrcSpan -> Name
Name.mkSystemNameAt forall a b. (a -> b) -> a -> b
$! Int -> Unique
mk_uniq (forall a. Num a => Integer -> a
fromInteger Integer
uniq)) forall a b. (a -> b) -> a -> b
$! OccName
occ) SrcSpan
loc)
NameFlavour
TH.NameS | Just Name
name <- OccName -> Maybe Name
isBuiltInOcc_maybe OccName
occ -> Name -> RdrName
nameRdrName forall a b. (a -> b) -> a -> b
$! Name
name
| Bool
otherwise -> OccName -> RdrName
mkRdrUnqual forall a b. (a -> b) -> a -> b
$! OccName
occ
where
occ :: OccName.OccName
occ :: OccName
occ = NameSpace -> String -> OccName
mk_occ NameSpace
ctxt_ns String
th_occ
thOrigRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName
thOrigRdrName :: String -> NameSpace -> PkgName -> ModName -> RdrName
thOrigRdrName String
occ NameSpace
th_ns PkgName
pkg ModName
mod =
let occ' :: OccName
occ' = NameSpace -> String -> OccName
mk_occ (NameSpace -> NameSpace
mk_ghc_ns NameSpace
th_ns) String
occ
in case OccName -> Maybe Name
isBuiltInOcc_maybe OccName
occ' of
Just Name
name -> Name -> RdrName
nameRdrName Name
name
Maybe Name
Nothing -> (Module -> OccName -> RdrName
mkOrig forall a b. (a -> b) -> a -> b
$! (forall u. u -> ModuleName -> GenModule u
mkModule (PkgName -> Unit
mk_pkg PkgName
pkg) (ModName -> ModuleName
mk_mod ModName
mod))) forall a b. (a -> b) -> a -> b
$! OccName
occ'
thRdrNameGuesses :: TH.Name -> [RdrName]
thRdrNameGuesses :: Name -> [RdrName]
thRdrNameGuesses (TH.Name OccName
occ NameFlavour
flavour)
| TH.NameG NameSpace
th_ns PkgName
pkg ModName
mod <- NameFlavour
flavour = [ String -> NameSpace -> PkgName -> ModName -> RdrName
thOrigRdrName String
occ_str NameSpace
th_ns PkgName
pkg ModName
mod]
| Bool
otherwise = [ SrcSpan -> NameSpace -> String -> NameFlavour -> RdrName
thRdrName SrcSpan
noSrcSpan NameSpace
gns String
occ_str NameFlavour
flavour
| NameSpace
gns <- [NameSpace]
guessed_nss]
where
guessed_nss :: [NameSpace]
guessed_nss
| CLabelString -> Bool
isLexCon (String -> CLabelString
mkFastString String
occ_str) = [NameSpace
OccName.tcName, NameSpace
OccName.dataName]
| Bool
otherwise = [NameSpace
OccName.varName, NameSpace
OccName.tvName]
occ_str :: String
occ_str = OccName -> String
TH.occString OccName
occ
mk_occ :: OccName.NameSpace -> String -> OccName.OccName
mk_occ :: NameSpace -> String -> OccName
mk_occ NameSpace
ns String
occ = NameSpace -> String -> OccName
OccName.mkOccName NameSpace
ns String
occ
mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace
mk_ghc_ns :: NameSpace -> NameSpace
mk_ghc_ns NameSpace
TH.DataName = NameSpace
OccName.dataName
mk_ghc_ns NameSpace
TH.TcClsName = NameSpace
OccName.tcClsName
mk_ghc_ns NameSpace
TH.VarName = NameSpace
OccName.varName
mk_mod :: TH.ModName -> ModuleName
mk_mod :: ModName -> ModuleName
mk_mod ModName
mod = String -> ModuleName
mkModuleName (ModName -> String
TH.modString ModName
mod)
mk_pkg :: TH.PkgName -> Unit
mk_pkg :: PkgName -> Unit
mk_pkg PkgName
pkg = String -> Unit
stringToUnit (PkgName -> String
TH.pkgString PkgName
pkg)
mk_uniq :: Int -> Unique
mk_uniq :: Int -> Unique
mk_uniq Int
u = Int -> Unique
mkUniqueGrimily Int
u