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


This module converts Template Haskell syntax into HsSyn
-}

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}

module Convert( convertToHsExpr, convertToPat, convertToHsDecls,
                convertToHsType,
                thRdrNameGuesses ) where

import GhcPrelude

import HsSyn as Hs
import PrelNames
import RdrName
import qualified Name
import Module
import RdrHsSyn
import OccName
import SrcLoc
import Type
import qualified Coercion ( Role(..) )
import TysWiredIn
import BasicTypes as Hs
import ForeignCall
import Unique
import ErrUtils
import Bag
import Lexeme
import Util
import FastString
import Outputable
import MonadUtils ( foldrM )

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

import Data.Maybe( catMaybes, isNothing )
import Language.Haskell.TH as TH hiding (sigP)
import Language.Haskell.TH.Syntax as TH

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

convertToHsDecls :: SrcSpan -> [TH.Dec] -> Either MsgDoc [LHsDecl GhcPs]
convertToHsDecls :: SrcSpan -> [Dec] -> Either MsgDoc [LHsDecl GhcPs]
convertToHsDecls loc :: SrcSpan
loc ds :: [Dec]
ds = SrcSpan -> CvtM [LHsDecl GhcPs] -> Either MsgDoc [LHsDecl GhcPs]
forall a. SrcSpan -> CvtM a -> Either MsgDoc a
initCvt SrcSpan
loc (([Maybe (LHsDecl GhcPs)] -> [LHsDecl GhcPs])
-> CvtM [Maybe (LHsDecl GhcPs)] -> CvtM [LHsDecl GhcPs]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe (LHsDecl GhcPs)] -> [LHsDecl GhcPs]
forall a. [Maybe a] -> [a]
catMaybes ((Dec -> CvtM (Maybe (LHsDecl GhcPs)))
-> [Dec] -> CvtM [Maybe (LHsDecl GhcPs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Dec -> CvtM (Maybe (LHsDecl GhcPs))
cvt_dec [Dec]
ds))
  where
    cvt_dec :: Dec -> CvtM (Maybe (LHsDecl GhcPs))
cvt_dec d :: Dec
d = String
-> Dec
-> CvtM (Maybe (LHsDecl GhcPs))
-> CvtM (Maybe (LHsDecl GhcPs))
forall a b. (Show a, Ppr a) => String -> a -> CvtM b -> CvtM b
wrapMsg "declaration" Dec
d (Dec -> CvtM (Maybe (LHsDecl GhcPs))
cvtDec Dec
d)

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

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

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

-------------------------------------------------------------------
newtype CvtM a = CvtM { CvtM a -> SrcSpan -> Either MsgDoc (SrcSpan, a)
unCvtM :: SrcSpan -> Either MsgDoc (SrcSpan, a) }
        -- Push down the source location;
        -- Can fail, with a single error message

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

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

instance Functor CvtM where
    fmap :: (a -> b) -> CvtM a -> CvtM b
fmap = (a -> b) -> CvtM a -> CvtM b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

instance Applicative CvtM where
    pure :: a -> CvtM a
pure x :: a
x = (SrcSpan -> Either MsgDoc (SrcSpan, a)) -> CvtM a
forall a. (SrcSpan -> Either MsgDoc (SrcSpan, a)) -> CvtM a
CvtM ((SrcSpan -> Either MsgDoc (SrcSpan, a)) -> CvtM a)
-> (SrcSpan -> Either MsgDoc (SrcSpan, a)) -> CvtM a
forall a b. (a -> b) -> a -> b
$ \loc :: SrcSpan
loc -> (SrcSpan, a) -> Either MsgDoc (SrcSpan, a)
forall a b. b -> Either a b
Right (SrcSpan
loc,a
x)
    <*> :: CvtM (a -> b) -> CvtM a -> CvtM 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 m :: SrcSpan -> Either MsgDoc (SrcSpan, a)
m) >>= :: CvtM a -> (a -> CvtM b) -> CvtM b
>>= k :: a -> CvtM b
k = (SrcSpan -> Either MsgDoc (SrcSpan, b)) -> CvtM b
forall a. (SrcSpan -> Either MsgDoc (SrcSpan, a)) -> CvtM a
CvtM ((SrcSpan -> Either MsgDoc (SrcSpan, b)) -> CvtM b)
-> (SrcSpan -> Either MsgDoc (SrcSpan, b)) -> CvtM b
forall a b. (a -> b) -> a -> b
$ \loc :: SrcSpan
loc -> case SrcSpan -> Either MsgDoc (SrcSpan, a)
m SrcSpan
loc of
                                  Left err :: MsgDoc
err -> MsgDoc -> Either MsgDoc (SrcSpan, b)
forall a b. a -> Either a b
Left MsgDoc
err
                                  Right (loc' :: SrcSpan
loc',v :: a
v) -> CvtM b -> SrcSpan -> Either MsgDoc (SrcSpan, b)
forall a. CvtM a -> SrcSpan -> Either MsgDoc (SrcSpan, a)
unCvtM (a -> CvtM b
k a
v) SrcSpan
loc'

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

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

failWith :: MsgDoc -> CvtM a
failWith :: MsgDoc -> CvtM a
failWith m :: MsgDoc
m = (SrcSpan -> Either MsgDoc (SrcSpan, a)) -> CvtM a
forall a. (SrcSpan -> Either MsgDoc (SrcSpan, a)) -> CvtM a
CvtM (\_ -> MsgDoc -> Either MsgDoc (SrcSpan, a)
forall a b. a -> Either a b
Left MsgDoc
m)

getL :: CvtM SrcSpan
getL :: CvtM SrcSpan
getL = (SrcSpan -> Either MsgDoc (SrcSpan, SrcSpan)) -> CvtM SrcSpan
forall a. (SrcSpan -> Either MsgDoc (SrcSpan, a)) -> CvtM a
CvtM (\loc :: SrcSpan
loc -> (SrcSpan, SrcSpan) -> Either MsgDoc (SrcSpan, SrcSpan)
forall a b. b -> Either a b
Right (SrcSpan
loc,SrcSpan
loc))

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

returnL :: HasSrcSpan a => SrcSpanLess a -> CvtM a
returnL :: SrcSpanLess a -> CvtM a
returnL x :: SrcSpanLess a
x = (SrcSpan -> Either MsgDoc (SrcSpan, a)) -> CvtM a
forall a. (SrcSpan -> Either MsgDoc (SrcSpan, a)) -> CvtM a
CvtM (\loc :: SrcSpan
loc -> (SrcSpan, a) -> Either MsgDoc (SrcSpan, a)
forall a b. b -> Either a b
Right (SrcSpan
loc, SrcSpan -> SrcSpanLess a -> a
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc SrcSpanLess a
x))

returnJustL :: HasSrcSpan a => SrcSpanLess a -> CvtM (Maybe a)
returnJustL :: SrcSpanLess a -> CvtM (Maybe a)
returnJustL = (a -> Maybe a) -> CvtM a -> CvtM (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just (CvtM a -> CvtM (Maybe a))
-> (SrcSpanLess a -> CvtM a) -> SrcSpanLess a -> CvtM (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpanLess a -> CvtM a
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM a
returnL

wrapParL :: HasSrcSpan a =>
            (a -> SrcSpanLess a) -> SrcSpanLess a -> CvtM (SrcSpanLess  a)
wrapParL :: (a -> SrcSpanLess a) -> SrcSpanLess a -> CvtM (SrcSpanLess a)
wrapParL add_par :: a -> SrcSpanLess a
add_par x :: SrcSpanLess a
x = (SrcSpan -> Either MsgDoc (SrcSpan, SrcSpanLess a))
-> CvtM (SrcSpanLess a)
forall a. (SrcSpan -> Either MsgDoc (SrcSpan, a)) -> CvtM a
CvtM (\loc :: SrcSpan
loc -> (SrcSpan, SrcSpanLess a) -> Either MsgDoc (SrcSpan, SrcSpanLess a)
forall a b. b -> Either a b
Right (SrcSpan
loc, a -> SrcSpanLess a
add_par (SrcSpan -> SrcSpanLess a -> a
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc SrcSpanLess a
x)))

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

wrapL :: HasSrcSpan a => CvtM (SrcSpanLess a) -> CvtM a
wrapL :: CvtM (SrcSpanLess a) -> CvtM a
wrapL (CvtM m :: SrcSpan -> Either MsgDoc (SrcSpan, SrcSpanLess a)
m) = (SrcSpan -> Either MsgDoc (SrcSpan, a)) -> CvtM a
forall a. (SrcSpan -> Either MsgDoc (SrcSpan, a)) -> CvtM a
CvtM (\loc :: SrcSpan
loc -> case SrcSpan -> Either MsgDoc (SrcSpan, SrcSpanLess a)
m SrcSpan
loc of
                               Left err :: MsgDoc
err -> MsgDoc -> Either MsgDoc (SrcSpan, a)
forall a b. a -> Either a b
Left MsgDoc
err
                               Right (loc' :: SrcSpan
loc',v :: SrcSpanLess a
v) -> (SrcSpan, a) -> Either MsgDoc (SrcSpan, a)
forall a b. b -> Either a b
Right (SrcSpan
loc',SrcSpan -> SrcSpanLess a -> a
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc SrcSpanLess a
v))

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

cvtDec :: TH.Dec -> CvtM (Maybe (LHsDecl GhcPs))
cvtDec :: Dec -> CvtM (Maybe (LHsDecl GhcPs))
cvtDec (TH.ValD pat :: Pat
pat body :: Body
body ds :: [Dec]
ds)
  | TH.VarP s :: Name
s <- Pat
pat
  = do  { Located RdrName
s' <- Name -> CvtM (Located RdrName)
vNameL Name
s
        ; LMatch GhcPs (LHsExpr GhcPs)
cl' <- HsMatchContext RdrName
-> Clause -> CvtM (LMatch GhcPs (LHsExpr GhcPs))
cvtClause (Located RdrName -> HsMatchContext RdrName
forall id. Located id -> HsMatchContext id
mkPrefixFunRhs Located RdrName
s') ([Pat] -> Body -> [Dec] -> Clause
Clause [] Body
body [Dec]
ds)
        ; SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs))
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM (Maybe a)
returnJustL (SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs)))
-> SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs))
forall a b. (a -> b) -> a -> b
$ XValD GhcPs -> HsBind GhcPs -> HsDecl GhcPs
forall p. XValD p -> HsBind p -> HsDecl p
Hs.ValD XValD GhcPs
NoExt
noExt (HsBind GhcPs -> SrcSpanLess (LHsDecl GhcPs))
-> HsBind GhcPs -> SrcSpanLess (LHsDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> HsBind GhcPs
mkFunBind Located RdrName
s' [LMatch GhcPs (LHsExpr GhcPs)
cl'] }

  | Bool
otherwise
  = do  { LPat GhcPs
pat' <- Pat -> CvtM (LPat GhcPs)
cvtPat Pat
pat
        ; [LGRHS GhcPs (LHsExpr GhcPs)]
body' <- Body -> CvtM [LGRHS GhcPs (LHsExpr GhcPs)]
cvtGuard Body
body
        ; HsLocalBinds GhcPs
ds' <- MsgDoc -> [Dec] -> CvtM (HsLocalBinds GhcPs)
cvtLocalDecs (String -> MsgDoc
text "a where clause") [Dec]
ds
        ; SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs))
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM (Maybe a)
returnJustL (SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs)))
-> SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs))
forall a b. (a -> b) -> a -> b
$ XValD GhcPs -> HsBind GhcPs -> HsDecl GhcPs
forall p. XValD p -> HsBind p -> HsDecl p
Hs.ValD XValD GhcPs
NoExt
noExt (HsBind GhcPs -> SrcSpanLess (LHsDecl GhcPs))
-> HsBind GhcPs -> SrcSpanLess (LHsDecl GhcPs)
forall a b. (a -> b) -> a -> b
$
          PatBind :: forall idL idR.
XPatBind idL idR
-> LPat idL
-> GRHSs idR (LHsExpr idR)
-> ([Tickish Id], [[Tickish Id]])
-> HsBindLR idL idR
PatBind { pat_lhs :: LPat GhcPs
pat_lhs = LPat GhcPs
pat'
                  , pat_rhs :: GRHSs GhcPs (LHsExpr GhcPs)
pat_rhs = XCGRHSs GhcPs (LHsExpr GhcPs)
-> [LGRHS GhcPs (LHsExpr GhcPs)]
-> LHsLocalBinds GhcPs
-> GRHSs GhcPs (LHsExpr GhcPs)
forall p body.
XCGRHSs p body -> [LGRHS p body] -> LHsLocalBinds p -> GRHSs p body
GRHSs XCGRHSs GhcPs (LHsExpr GhcPs)
NoExt
noExt [LGRHS GhcPs (LHsExpr GhcPs)]
body' (SrcSpanLess (LHsLocalBinds GhcPs) -> LHsLocalBinds GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (LHsLocalBinds GhcPs)
HsLocalBinds GhcPs
ds')
                  , pat_ext :: XPatBind GhcPs GhcPs
pat_ext = XPatBind GhcPs GhcPs
NoExt
noExt
                  , pat_ticks :: ([Tickish Id], [[Tickish Id]])
pat_ticks = ([],[]) } }

cvtDec (TH.FunD nm :: Name
nm cls :: [Clause]
cls)
  | [Clause] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Clause]
cls
  = MsgDoc -> CvtM (Maybe (LHsDecl GhcPs))
forall a. MsgDoc -> CvtM a
failWith (String -> MsgDoc
text "Function binding for"
                 MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (String -> MsgDoc
text (Name -> String
forall a. Ppr a => a -> String
TH.pprint Name
nm))
                 MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text "has no equations")
  | Bool
otherwise
  = do  { Located RdrName
nm' <- Name -> CvtM (Located RdrName)
vNameL Name
nm
        ; [LMatch GhcPs (LHsExpr GhcPs)]
cls' <- (Clause -> CvtM (LMatch GhcPs (LHsExpr GhcPs)))
-> [Clause] -> CvtM [LMatch GhcPs (LHsExpr GhcPs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (HsMatchContext RdrName
-> Clause -> CvtM (LMatch GhcPs (LHsExpr GhcPs))
cvtClause (Located RdrName -> HsMatchContext RdrName
forall id. Located id -> HsMatchContext id
mkPrefixFunRhs Located RdrName
nm')) [Clause]
cls
        ; SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs))
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM (Maybe a)
returnJustL (SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs)))
-> SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs))
forall a b. (a -> b) -> a -> b
$ XValD GhcPs -> HsBind GhcPs -> HsDecl GhcPs
forall p. XValD p -> HsBind p -> HsDecl p
Hs.ValD XValD GhcPs
NoExt
noExt (HsBind GhcPs -> SrcSpanLess (LHsDecl GhcPs))
-> HsBind GhcPs -> SrcSpanLess (LHsDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> HsBind GhcPs
mkFunBind Located RdrName
nm' [LMatch GhcPs (LHsExpr GhcPs)]
cls' }

cvtDec (TH.SigD nm :: Name
nm typ :: Type
typ)
  = do  { Located RdrName
nm' <- Name -> CvtM (Located RdrName)
vNameL Name
nm
        ; LHsType GhcPs
ty' <- Type -> CvtM (LHsType GhcPs)
cvtType Type
typ
        ; SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs))
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM (Maybe a)
returnJustL (SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs)))
-> SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs))
forall a b. (a -> b) -> a -> b
$ XSigD GhcPs -> Sig GhcPs -> HsDecl GhcPs
forall p. XSigD p -> Sig p -> HsDecl p
Hs.SigD XSigD GhcPs
NoExt
noExt
                                    (XTypeSig GhcPs
-> [Located (IdP GhcPs)] -> LHsSigWcType GhcPs -> Sig GhcPs
forall pass.
XTypeSig pass
-> [Located (IdP pass)] -> LHsSigWcType pass -> Sig pass
TypeSig XTypeSig GhcPs
NoExt
noExt [Located RdrName
Located (IdP GhcPs)
nm'] (LHsType GhcPs -> LHsSigWcType GhcPs
mkLHsSigWcType LHsType GhcPs
ty')) }

cvtDec (TH.InfixD fx :: Fixity
fx nm :: Name
nm)
  -- Fixity signatures are allowed for variables, constructors, and types
  -- the renamer automatically looks for types during renaming, even when
  -- the RdrName says it's a variable or a constructor. So, just assume
  -- it's a variable or constructor and proceed.
  = do { Located RdrName
nm' <- Name -> CvtM (Located RdrName)
vcNameL Name
nm
       ; SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs))
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM (Maybe a)
returnJustL (XSigD GhcPs -> Sig GhcPs -> HsDecl GhcPs
forall p. XSigD p -> Sig p -> HsDecl p
Hs.SigD XSigD GhcPs
NoExt
noExt (XFixSig GhcPs -> FixitySig GhcPs -> Sig GhcPs
forall pass. XFixSig pass -> FixitySig pass -> Sig pass
FixSig XFixSig GhcPs
NoExt
noExt
                                      (XFixitySig GhcPs
-> [Located (IdP GhcPs)] -> Fixity -> FixitySig GhcPs
forall pass.
XFixitySig pass -> [Located (IdP pass)] -> Fixity -> FixitySig pass
FixitySig XFixitySig GhcPs
NoExt
noExt [Located RdrName
Located (IdP GhcPs)
nm'] (Fixity -> Fixity
cvtFixity Fixity
fx)))) }

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

cvtDec (TySynD tc :: Name
tc tvs :: [TyVarBndr]
tvs rhs :: Type
rhs)
  = do  { (_, tc' :: Located RdrName
tc', tvs' :: LHsQTyVars GhcPs
tvs') <- Cxt
-> Name
-> [TyVarBndr]
-> CvtM (LHsContext GhcPs, Located RdrName, LHsQTyVars GhcPs)
cvt_tycl_hdr [] Name
tc [TyVarBndr]
tvs
        ; LHsType GhcPs
rhs' <- Type -> CvtM (LHsType GhcPs)
cvtType Type
rhs
        ; SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs))
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM (Maybe a)
returnJustL (SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs)))
-> SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs))
forall a b. (a -> b) -> a -> b
$ XTyClD GhcPs -> TyClDecl GhcPs -> HsDecl GhcPs
forall p. XTyClD p -> TyClDecl p -> HsDecl p
TyClD XTyClD GhcPs
NoExt
noExt (TyClDecl GhcPs -> SrcSpanLess (LHsDecl GhcPs))
-> TyClDecl GhcPs -> SrcSpanLess (LHsDecl GhcPs)
forall a b. (a -> b) -> a -> b
$
          SynDecl :: forall pass.
XSynDecl pass
-> Located (IdP pass)
-> LHsQTyVars pass
-> LexicalFixity
-> LHsType pass
-> TyClDecl pass
SynDecl { tcdSExt :: XSynDecl GhcPs
tcdSExt = XSynDecl GhcPs
NoExt
noExt, tcdLName :: Located (IdP GhcPs)
tcdLName = Located RdrName
Located (IdP GhcPs)
tc', tcdTyVars :: LHsQTyVars GhcPs
tcdTyVars = LHsQTyVars GhcPs
tvs'
                  , tcdFixity :: LexicalFixity
tcdFixity = LexicalFixity
Prefix
                  , tcdRhs :: LHsType GhcPs
tcdRhs = LHsType GhcPs
rhs' } }

cvtDec (DataD ctxt :: Cxt
ctxt tc :: Name
tc tvs :: [TyVarBndr]
tvs ksig :: Maybe Type
ksig constrs :: [Con]
constrs derivs :: [DerivClause]
derivs)
  = do  { let isGadtCon :: Con -> Bool
isGadtCon (GadtC    _ _ _) = Bool
True
              isGadtCon (RecGadtC _ _ _) = Bool
True
              isGadtCon (ForallC  _ _ c :: Con
c) = Con -> Bool
isGadtCon Con
c
              isGadtCon _                = Bool
False
              isGadtDecl :: Bool
isGadtDecl  = (Con -> Bool) -> [Con] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Con -> Bool
isGadtCon [Con]
constrs
              isH98Decl :: Bool
isH98Decl   = (Con -> Bool) -> [Con] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool -> Bool
not (Bool -> Bool) -> (Con -> Bool) -> Con -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Con -> Bool
isGadtCon) [Con]
constrs
        ; Bool -> CvtM () -> CvtM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
isGadtDecl Bool -> Bool -> Bool
|| Bool
isH98Decl)
                 (MsgDoc -> CvtM ()
forall a. MsgDoc -> CvtM a
failWith (String -> MsgDoc
text "Cannot mix GADT constructors with Haskell 98"
                        MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text "constructors"))
        ; Bool -> CvtM () -> CvtM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Maybe Type -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Type
ksig Bool -> Bool -> Bool
|| Bool
isGadtDecl)
                 (MsgDoc -> CvtM ()
forall a. MsgDoc -> CvtM a
failWith (String -> MsgDoc
text "Kind signatures are only allowed on GADTs"))
        ; (ctxt' :: LHsContext GhcPs
ctxt', tc' :: Located RdrName
tc', tvs' :: LHsQTyVars GhcPs
tvs') <- Cxt
-> Name
-> [TyVarBndr]
-> CvtM (LHsContext GhcPs, Located RdrName, LHsQTyVars GhcPs)
cvt_tycl_hdr Cxt
ctxt Name
tc [TyVarBndr]
tvs
        ; Maybe (LHsType GhcPs)
ksig' <- Type -> CvtM (LHsType GhcPs)
cvtKind (Type -> CvtM (LHsType GhcPs))
-> Maybe Type -> CvtM (Maybe (LHsType GhcPs))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
`traverse` Maybe Type
ksig
        ; [LConDecl GhcPs]
cons' <- (Con -> CvtM (LConDecl GhcPs)) -> [Con] -> CvtM [LConDecl GhcPs]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Con -> CvtM (LConDecl GhcPs)
cvtConstr [Con]
constrs
        ; HsDeriving GhcPs
derivs' <- [DerivClause] -> CvtM (HsDeriving GhcPs)
cvtDerivs [DerivClause]
derivs
        ; let defn :: HsDataDefn GhcPs
defn = HsDataDefn :: forall pass.
XCHsDataDefn pass
-> NewOrData
-> LHsContext pass
-> Maybe (Located CType)
-> Maybe (LHsKind pass)
-> [LConDecl pass]
-> HsDeriving pass
-> HsDataDefn pass
HsDataDefn { dd_ext :: XCHsDataDefn GhcPs
dd_ext = XCHsDataDefn GhcPs
NoExt
noExt
                                , dd_ND :: NewOrData
dd_ND = NewOrData
DataType, dd_cType :: Maybe (Located CType)
dd_cType = Maybe (Located CType)
forall a. Maybe a
Nothing
                                , dd_ctxt :: LHsContext GhcPs
dd_ctxt = LHsContext GhcPs
ctxt'
                                , dd_kindSig :: Maybe (LHsType GhcPs)
dd_kindSig = Maybe (LHsType GhcPs)
ksig'
                                , dd_cons :: [LConDecl GhcPs]
dd_cons = [LConDecl GhcPs]
cons', dd_derivs :: HsDeriving GhcPs
dd_derivs = HsDeriving GhcPs
derivs' }
        ; SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs))
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM (Maybe a)
returnJustL (SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs)))
-> SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs))
forall a b. (a -> b) -> a -> b
$ XTyClD GhcPs -> TyClDecl GhcPs -> HsDecl GhcPs
forall p. XTyClD p -> TyClDecl p -> HsDecl p
TyClD XTyClD GhcPs
NoExt
noExt (DataDecl :: forall pass.
XDataDecl pass
-> Located (IdP pass)
-> LHsQTyVars pass
-> LexicalFixity
-> HsDataDefn pass
-> TyClDecl pass
DataDecl
                                        { tcdDExt :: XDataDecl GhcPs
tcdDExt = XDataDecl GhcPs
NoExt
noExt
                                        , tcdLName :: Located (IdP GhcPs)
tcdLName = Located RdrName
Located (IdP GhcPs)
tc', tcdTyVars :: LHsQTyVars GhcPs
tcdTyVars = LHsQTyVars GhcPs
tvs'
                                        , tcdFixity :: LexicalFixity
tcdFixity = LexicalFixity
Prefix
                                        , tcdDataDefn :: HsDataDefn GhcPs
tcdDataDefn = HsDataDefn GhcPs
defn }) }

cvtDec (NewtypeD ctxt :: Cxt
ctxt tc :: Name
tc tvs :: [TyVarBndr]
tvs ksig :: Maybe Type
ksig constr :: Con
constr derivs :: [DerivClause]
derivs)
  = do  { (ctxt' :: LHsContext GhcPs
ctxt', tc' :: Located RdrName
tc', tvs' :: LHsQTyVars GhcPs
tvs') <- Cxt
-> Name
-> [TyVarBndr]
-> CvtM (LHsContext GhcPs, Located RdrName, LHsQTyVars GhcPs)
cvt_tycl_hdr Cxt
ctxt Name
tc [TyVarBndr]
tvs
        ; Maybe (LHsType GhcPs)
ksig' <- Type -> CvtM (LHsType GhcPs)
cvtKind (Type -> CvtM (LHsType GhcPs))
-> Maybe Type -> CvtM (Maybe (LHsType GhcPs))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
`traverse` Maybe Type
ksig
        ; LConDecl GhcPs
con' <- Con -> CvtM (LConDecl GhcPs)
cvtConstr Con
constr
        ; HsDeriving GhcPs
derivs' <- [DerivClause] -> CvtM (HsDeriving GhcPs)
cvtDerivs [DerivClause]
derivs
        ; let defn :: HsDataDefn GhcPs
defn = HsDataDefn :: forall pass.
XCHsDataDefn pass
-> NewOrData
-> LHsContext pass
-> Maybe (Located CType)
-> Maybe (LHsKind pass)
-> [LConDecl pass]
-> HsDeriving pass
-> HsDataDefn pass
HsDataDefn { dd_ext :: XCHsDataDefn GhcPs
dd_ext = XCHsDataDefn GhcPs
NoExt
noExt
                                , dd_ND :: NewOrData
dd_ND = NewOrData
NewType, dd_cType :: Maybe (Located CType)
dd_cType = Maybe (Located CType)
forall a. Maybe a
Nothing
                                , dd_ctxt :: LHsContext GhcPs
dd_ctxt = LHsContext GhcPs
ctxt'
                                , dd_kindSig :: Maybe (LHsType GhcPs)
dd_kindSig = Maybe (LHsType GhcPs)
ksig'
                                , dd_cons :: [LConDecl GhcPs]
dd_cons = [LConDecl GhcPs
con']
                                , dd_derivs :: HsDeriving GhcPs
dd_derivs = HsDeriving GhcPs
derivs' }
        ; SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs))
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM (Maybe a)
returnJustL (SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs)))
-> SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs))
forall a b. (a -> b) -> a -> b
$ XTyClD GhcPs -> TyClDecl GhcPs -> HsDecl GhcPs
forall p. XTyClD p -> TyClDecl p -> HsDecl p
TyClD XTyClD GhcPs
NoExt
noExt (DataDecl :: forall pass.
XDataDecl pass
-> Located (IdP pass)
-> LHsQTyVars pass
-> LexicalFixity
-> HsDataDefn pass
-> TyClDecl pass
DataDecl
                                    { tcdDExt :: XDataDecl GhcPs
tcdDExt = XDataDecl GhcPs
NoExt
noExt
                                    , tcdLName :: Located (IdP GhcPs)
tcdLName = Located RdrName
Located (IdP GhcPs)
tc', tcdTyVars :: LHsQTyVars GhcPs
tcdTyVars = LHsQTyVars GhcPs
tvs'
                                    , tcdFixity :: LexicalFixity
tcdFixity = LexicalFixity
Prefix
                                    , tcdDataDefn :: HsDataDefn GhcPs
tcdDataDefn = HsDataDefn GhcPs
defn }) }

cvtDec (ClassD ctxt :: Cxt
ctxt cl :: Name
cl tvs :: [TyVarBndr]
tvs fds :: [FunDep]
fds decs :: [Dec]
decs)
  = do  { (cxt' :: LHsContext GhcPs
cxt', tc' :: Located RdrName
tc', tvs' :: LHsQTyVars GhcPs
tvs') <- Cxt
-> Name
-> [TyVarBndr]
-> CvtM (LHsContext GhcPs, Located RdrName, LHsQTyVars GhcPs)
cvt_tycl_hdr Cxt
ctxt Name
cl [TyVarBndr]
tvs
        ; [Located (FunDep (Located RdrName))]
fds'  <- (FunDep -> CvtM (Located (FunDep (Located RdrName))))
-> [FunDep] -> CvtM [Located (FunDep (Located RdrName))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FunDep -> CvtM (Located (FunDep (Located RdrName)))
FunDep -> CvtM (LHsFunDep GhcPs)
cvt_fundep [FunDep]
fds
        ; (binds' :: LHsBinds GhcPs
binds', sigs' :: [LSig GhcPs]
sigs', fams' :: [LFamilyDecl GhcPs]
fams', ats' :: [LTyFamInstDecl GhcPs]
ats', adts' :: [LDataFamInstDecl GhcPs]
adts') <- MsgDoc
-> [Dec]
-> CvtM
     (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],
      [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs])
cvt_ci_decs (String -> MsgDoc
text "a class declaration") [Dec]
decs
        ; Bool -> CvtM () -> CvtM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([LDataFamInstDecl GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LDataFamInstDecl GhcPs]
adts')
            (MsgDoc -> CvtM ()
forall a. MsgDoc -> CvtM a
failWith (MsgDoc -> CvtM ()) -> MsgDoc -> CvtM ()
forall a b. (a -> b) -> a -> b
$ (String -> MsgDoc
text "Default data instance declarations"
                     MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text "are not allowed:")
                   MsgDoc -> MsgDoc -> MsgDoc
$$ ([LDataFamInstDecl GhcPs] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
Outputable.ppr [LDataFamInstDecl GhcPs]
adts'))
        ; [LTyFamDefltEqn GhcPs]
at_defs <- (LTyFamInstDecl GhcPs -> CvtM (LTyFamDefltEqn GhcPs))
-> [LTyFamInstDecl GhcPs] -> CvtM [LTyFamDefltEqn GhcPs]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LTyFamInstDecl GhcPs -> CvtM (LTyFamDefltEqn GhcPs)
cvt_at_def [LTyFamInstDecl GhcPs]
ats'
        ; SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs))
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM (Maybe a)
returnJustL (SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs)))
-> SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs))
forall a b. (a -> b) -> a -> b
$ XTyClD GhcPs -> TyClDecl GhcPs -> HsDecl GhcPs
forall p. XTyClD p -> TyClDecl p -> HsDecl p
TyClD XTyClD GhcPs
NoExt
noExt (TyClDecl GhcPs -> SrcSpanLess (LHsDecl GhcPs))
-> TyClDecl GhcPs -> SrcSpanLess (LHsDecl GhcPs)
forall a b. (a -> b) -> a -> b
$
          ClassDecl :: forall pass.
XClassDecl pass
-> LHsContext pass
-> Located (IdP pass)
-> LHsQTyVars pass
-> LexicalFixity
-> [LHsFunDep pass]
-> [LSig pass]
-> LHsBinds pass
-> [LFamilyDecl pass]
-> [LTyFamDefltEqn pass]
-> [LDocDecl]
-> TyClDecl pass
ClassDecl { tcdCExt :: XClassDecl GhcPs
tcdCExt = XClassDecl GhcPs
NoExt
noExt
                    , tcdCtxt :: LHsContext GhcPs
tcdCtxt = LHsContext GhcPs
cxt', tcdLName :: Located (IdP GhcPs)
tcdLName = Located RdrName
Located (IdP GhcPs)
tc', tcdTyVars :: LHsQTyVars GhcPs
tcdTyVars = LHsQTyVars GhcPs
tvs'
                    , tcdFixity :: LexicalFixity
tcdFixity = LexicalFixity
Prefix
                    , tcdFDs :: [LHsFunDep GhcPs]
tcdFDs = [Located (FunDep (Located RdrName))]
[LHsFunDep GhcPs]
fds', tcdSigs :: [LSig GhcPs]
tcdSigs = [LSig GhcPs] -> [LSig GhcPs]
Hs.mkClassOpSigs [LSig GhcPs]
sigs'
                    , tcdMeths :: LHsBinds GhcPs
tcdMeths = LHsBinds GhcPs
binds'
                    , tcdATs :: [LFamilyDecl GhcPs]
tcdATs = [LFamilyDecl GhcPs]
fams', tcdATDefs :: [LTyFamDefltEqn GhcPs]
tcdATDefs = [LTyFamDefltEqn GhcPs]
at_defs, tcdDocs :: [LDocDecl]
tcdDocs = [] }
                              -- no docs in TH ^^
        }
  where
    cvt_at_def :: LTyFamInstDecl GhcPs -> CvtM (LTyFamDefltEqn GhcPs)
    -- Very similar to what happens in RdrHsSyn.mkClassDecl
    cvt_at_def :: LTyFamInstDecl GhcPs -> CvtM (LTyFamDefltEqn GhcPs)
cvt_at_def decl :: LTyFamInstDecl GhcPs
decl = case LTyFamInstDecl GhcPs
-> Either (SrcSpan, MsgDoc) (LTyFamDefltEqn GhcPs, P ())
RdrHsSyn.mkATDefault LTyFamInstDecl GhcPs
decl of
                        Right (def :: LTyFamDefltEqn GhcPs
def, _) -> LTyFamDefltEqn GhcPs -> CvtM (LTyFamDefltEqn GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return LTyFamDefltEqn GhcPs
def
                        Left (_, msg :: MsgDoc
msg) -> MsgDoc -> CvtM (LTyFamDefltEqn GhcPs)
forall a. MsgDoc -> CvtM a
failWith MsgDoc
msg

cvtDec (InstanceD o :: Maybe Overlap
o ctxt :: Cxt
ctxt ty :: Type
ty decs :: [Dec]
decs)
  = do  { let doc :: MsgDoc
doc = String -> MsgDoc
text "an instance declaration"
        ; (binds' :: LHsBinds GhcPs
binds', sigs' :: [LSig GhcPs]
sigs', fams' :: [LFamilyDecl GhcPs]
fams', ats' :: [LTyFamInstDecl GhcPs]
ats', adts' :: [LDataFamInstDecl GhcPs]
adts') <- MsgDoc
-> [Dec]
-> CvtM
     (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],
      [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs])
cvt_ci_decs MsgDoc
doc [Dec]
decs
        ; Bool -> CvtM () -> CvtM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([LFamilyDecl GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LFamilyDecl GhcPs]
fams') (MsgDoc -> CvtM ()
forall a. MsgDoc -> CvtM a
failWith (MsgDoc -> [LFamilyDecl GhcPs] -> MsgDoc
forall a. Outputable a => MsgDoc -> [a] -> MsgDoc
mkBadDecMsg MsgDoc
doc [LFamilyDecl GhcPs]
fams'))
        ; LHsContext GhcPs
ctxt' <- Cxt -> CvtM (LHsContext GhcPs)
cvtContext Cxt
ctxt
        ; (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc ty' :: SrcSpanLess (LHsType GhcPs)
ty') <- Type -> CvtM (LHsType GhcPs)
cvtType Type
ty
        ; let inst_ty' :: LHsType GhcPs
inst_ty' = Cxt
-> SrcSpan -> LHsContext GhcPs -> LHsType GhcPs -> LHsType GhcPs
mkHsQualTy Cxt
ctxt SrcSpan
loc LHsContext GhcPs
ctxt' (LHsType GhcPs -> LHsType GhcPs) -> LHsType GhcPs -> LHsType GhcPs
forall a b. (a -> b) -> a -> b
$ SrcSpan -> SrcSpanLess (LHsType GhcPs) -> LHsType GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc SrcSpanLess (LHsType GhcPs)
ty'
        ; SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs))
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM (Maybe a)
returnJustL (SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs)))
-> SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs))
forall a b. (a -> b) -> a -> b
$ XInstD GhcPs -> InstDecl GhcPs -> HsDecl GhcPs
forall p. XInstD p -> InstDecl p -> HsDecl p
InstD XInstD GhcPs
NoExt
noExt (InstDecl GhcPs -> SrcSpanLess (LHsDecl GhcPs))
-> InstDecl GhcPs -> SrcSpanLess (LHsDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ XClsInstD GhcPs -> ClsInstDecl GhcPs -> InstDecl GhcPs
forall pass. XClsInstD pass -> ClsInstDecl pass -> InstDecl pass
ClsInstD XClsInstD GhcPs
NoExt
noExt (ClsInstDecl GhcPs -> InstDecl GhcPs)
-> ClsInstDecl GhcPs -> InstDecl GhcPs
forall a b. (a -> b) -> a -> b
$
          ClsInstDecl :: forall pass.
XCClsInstDecl pass
-> LHsSigType pass
-> LHsBinds pass
-> [LSig pass]
-> [LTyFamInstDecl pass]
-> [LDataFamInstDecl pass]
-> Maybe (Located OverlapMode)
-> ClsInstDecl pass
ClsInstDecl { cid_ext :: XCClsInstDecl GhcPs
cid_ext = XCClsInstDecl GhcPs
NoExt
noExt, cid_poly_ty :: LHsSigType GhcPs
cid_poly_ty = LHsType GhcPs -> LHsSigType GhcPs
mkLHsSigType LHsType GhcPs
inst_ty'
                      , cid_binds :: LHsBinds GhcPs
cid_binds = LHsBinds GhcPs
binds'
                      , cid_sigs :: [LSig GhcPs]
cid_sigs = [LSig GhcPs] -> [LSig GhcPs]
Hs.mkClassOpSigs [LSig GhcPs]
sigs'
                      , cid_tyfam_insts :: [LTyFamInstDecl GhcPs]
cid_tyfam_insts = [LTyFamInstDecl GhcPs]
ats', cid_datafam_insts :: [LDataFamInstDecl GhcPs]
cid_datafam_insts = [LDataFamInstDecl GhcPs]
adts'
                      , cid_overlap_mode :: Maybe (Located OverlapMode)
cid_overlap_mode = (Overlap -> Located OverlapMode)
-> Maybe Overlap -> Maybe (Located OverlapMode)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SrcSpan -> SrcSpanLess (Located OverlapMode) -> Located OverlapMode
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (OverlapMode -> Located OverlapMode)
-> (Overlap -> OverlapMode) -> Overlap -> Located OverlapMode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Overlap -> OverlapMode
overlap) Maybe Overlap
o } }
  where
  overlap :: Overlap -> OverlapMode
overlap pragma :: Overlap
pragma =
    case Overlap
pragma of
      TH.Overlaps      -> SourceText -> OverlapMode
Hs.Overlaps     (String -> SourceText
SourceText "OVERLAPS")
      TH.Overlappable  -> SourceText -> OverlapMode
Hs.Overlappable (String -> SourceText
SourceText "OVERLAPPABLE")
      TH.Overlapping   -> SourceText -> OverlapMode
Hs.Overlapping  (String -> SourceText
SourceText "OVERLAPPING")
      TH.Incoherent    -> SourceText -> OverlapMode
Hs.Incoherent   (String -> SourceText
SourceText "INCOHERENT")




cvtDec (ForeignD ford :: Foreign
ford)
  = do { ForeignDecl GhcPs
ford' <- Foreign -> CvtM (ForeignDecl GhcPs)
cvtForD Foreign
ford
       ; SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs))
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM (Maybe a)
returnJustL (SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs)))
-> SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs))
forall a b. (a -> b) -> a -> b
$ XForD GhcPs -> ForeignDecl GhcPs -> HsDecl GhcPs
forall p. XForD p -> ForeignDecl p -> HsDecl p
ForD XForD GhcPs
NoExt
noExt ForeignDecl GhcPs
ford' }

cvtDec (DataFamilyD tc :: Name
tc tvs :: [TyVarBndr]
tvs kind :: Maybe Type
kind)
  = do { (_, tc' :: Located RdrName
tc', tvs' :: LHsQTyVars GhcPs
tvs') <- Cxt
-> Name
-> [TyVarBndr]
-> CvtM (LHsContext GhcPs, Located RdrName, LHsQTyVars GhcPs)
cvt_tycl_hdr [] Name
tc [TyVarBndr]
tvs
       ; LFamilyResultSig GhcPs
result <- Maybe Type -> CvtM (LFamilyResultSig GhcPs)
cvtMaybeKindToFamilyResultSig Maybe Type
kind
       ; SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs))
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM (Maybe a)
returnJustL (SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs)))
-> SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs))
forall a b. (a -> b) -> a -> b
$ XTyClD GhcPs -> TyClDecl GhcPs -> HsDecl GhcPs
forall p. XTyClD p -> TyClDecl p -> HsDecl p
TyClD XTyClD GhcPs
NoExt
noExt (TyClDecl GhcPs -> SrcSpanLess (LHsDecl GhcPs))
-> TyClDecl GhcPs -> SrcSpanLess (LHsDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ XFamDecl GhcPs -> FamilyDecl GhcPs -> TyClDecl GhcPs
forall pass. XFamDecl pass -> FamilyDecl pass -> TyClDecl pass
FamDecl XFamDecl GhcPs
NoExt
noExt (FamilyDecl GhcPs -> TyClDecl GhcPs)
-> FamilyDecl GhcPs -> TyClDecl GhcPs
forall a b. (a -> b) -> a -> b
$
         XCFamilyDecl GhcPs
-> FamilyInfo GhcPs
-> Located (IdP GhcPs)
-> LHsQTyVars GhcPs
-> LexicalFixity
-> LFamilyResultSig GhcPs
-> Maybe (LInjectivityAnn GhcPs)
-> FamilyDecl GhcPs
forall pass.
XCFamilyDecl pass
-> FamilyInfo pass
-> Located (IdP pass)
-> LHsQTyVars pass
-> LexicalFixity
-> LFamilyResultSig pass
-> Maybe (LInjectivityAnn pass)
-> FamilyDecl pass
FamilyDecl XCFamilyDecl GhcPs
NoExt
noExt FamilyInfo GhcPs
forall pass. FamilyInfo pass
DataFamily Located RdrName
Located (IdP GhcPs)
tc' LHsQTyVars GhcPs
tvs' LexicalFixity
Prefix LFamilyResultSig GhcPs
result Maybe (LInjectivityAnn GhcPs)
forall a. Maybe a
Nothing }

cvtDec (DataInstD ctxt :: Cxt
ctxt bndrs :: Maybe [TyVarBndr]
bndrs tys :: Type
tys ksig :: Maybe Type
ksig constrs :: [Con]
constrs derivs :: [DerivClause]
derivs)
  = do { (ctxt' :: LHsContext GhcPs
ctxt', tc' :: Located RdrName
tc', bndrs' :: Maybe [LHsTyVarBndr GhcPs]
bndrs', typats' :: HsTyPats GhcPs
typats') <- Cxt
-> Maybe [TyVarBndr]
-> Type
-> CvtM
     (LHsContext GhcPs, Located RdrName, Maybe [LHsTyVarBndr GhcPs],
      HsTyPats GhcPs)
cvt_datainst_hdr Cxt
ctxt Maybe [TyVarBndr]
bndrs Type
tys
       ; Maybe (LHsType GhcPs)
ksig' <- Type -> CvtM (LHsType GhcPs)
cvtKind (Type -> CvtM (LHsType GhcPs))
-> Maybe Type -> CvtM (Maybe (LHsType GhcPs))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
`traverse` Maybe Type
ksig
       ; [LConDecl GhcPs]
cons' <- (Con -> CvtM (LConDecl GhcPs)) -> [Con] -> CvtM [LConDecl GhcPs]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Con -> CvtM (LConDecl GhcPs)
cvtConstr [Con]
constrs
       ; HsDeriving GhcPs
derivs' <- [DerivClause] -> CvtM (HsDeriving GhcPs)
cvtDerivs [DerivClause]
derivs
       ; let defn :: HsDataDefn GhcPs
defn = HsDataDefn :: forall pass.
XCHsDataDefn pass
-> NewOrData
-> LHsContext pass
-> Maybe (Located CType)
-> Maybe (LHsKind pass)
-> [LConDecl pass]
-> HsDeriving pass
-> HsDataDefn pass
HsDataDefn { dd_ext :: XCHsDataDefn GhcPs
dd_ext = XCHsDataDefn GhcPs
NoExt
noExt
                               , dd_ND :: NewOrData
dd_ND = NewOrData
DataType, dd_cType :: Maybe (Located CType)
dd_cType = Maybe (Located CType)
forall a. Maybe a
Nothing
                               , dd_ctxt :: LHsContext GhcPs
dd_ctxt = LHsContext GhcPs
ctxt'
                               , dd_kindSig :: Maybe (LHsType GhcPs)
dd_kindSig = Maybe (LHsType GhcPs)
ksig'
                               , dd_cons :: [LConDecl GhcPs]
dd_cons = [LConDecl GhcPs]
cons', dd_derivs :: HsDeriving GhcPs
dd_derivs = HsDeriving GhcPs
derivs' }

       ; SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs))
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM (Maybe a)
returnJustL (SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs)))
-> SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs))
forall a b. (a -> b) -> a -> b
$ XInstD GhcPs -> InstDecl GhcPs -> HsDecl GhcPs
forall p. XInstD p -> InstDecl p -> HsDecl p
InstD XInstD GhcPs
NoExt
noExt (InstDecl GhcPs -> SrcSpanLess (LHsDecl GhcPs))
-> InstDecl GhcPs -> SrcSpanLess (LHsDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ DataFamInstD :: forall pass.
XDataFamInstD pass -> DataFamInstDecl pass -> InstDecl pass
DataFamInstD
           { dfid_ext :: XDataFamInstD GhcPs
dfid_ext = XDataFamInstD GhcPs
NoExt
noExt
           , dfid_inst :: DataFamInstDecl GhcPs
dfid_inst = DataFamInstDecl :: forall pass.
FamInstEqn pass (HsDataDefn pass) -> DataFamInstDecl pass
DataFamInstDecl { dfid_eqn :: FamInstEqn GhcPs (HsDataDefn GhcPs)
dfid_eqn = FamEqn GhcPs (HsTyPats GhcPs) (HsDataDefn GhcPs)
-> FamInstEqn GhcPs (HsDataDefn GhcPs)
forall thing. thing -> HsImplicitBndrs GhcPs thing
mkHsImplicitBndrs (FamEqn GhcPs (HsTyPats GhcPs) (HsDataDefn GhcPs)
 -> FamInstEqn GhcPs (HsDataDefn GhcPs))
-> FamEqn GhcPs (HsTyPats GhcPs) (HsDataDefn GhcPs)
-> FamInstEqn GhcPs (HsDataDefn GhcPs)
forall a b. (a -> b) -> a -> b
$
                           FamEqn :: forall pass pats rhs.
XCFamEqn pass pats rhs
-> Located (IdP pass)
-> Maybe [LHsTyVarBndr pass]
-> pats
-> LexicalFixity
-> rhs
-> FamEqn pass pats rhs
FamEqn { feqn_ext :: XCFamEqn GhcPs (HsTyPats GhcPs) (HsDataDefn GhcPs)
feqn_ext = XCFamEqn GhcPs (HsTyPats GhcPs) (HsDataDefn GhcPs)
NoExt
noExt
                                  , feqn_tycon :: Located (IdP GhcPs)
feqn_tycon = Located RdrName
Located (IdP GhcPs)
tc'
                                  , feqn_bndrs :: Maybe [LHsTyVarBndr GhcPs]
feqn_bndrs = Maybe [LHsTyVarBndr GhcPs]
bndrs'
                                  , feqn_pats :: HsTyPats GhcPs
feqn_pats = HsTyPats GhcPs
typats'
                                  , feqn_rhs :: HsDataDefn GhcPs
feqn_rhs = HsDataDefn GhcPs
defn
                                  , feqn_fixity :: LexicalFixity
feqn_fixity = LexicalFixity
Prefix } }}}

cvtDec (NewtypeInstD ctxt :: Cxt
ctxt bndrs :: Maybe [TyVarBndr]
bndrs tys :: Type
tys ksig :: Maybe Type
ksig constr :: Con
constr derivs :: [DerivClause]
derivs)
  = do { (ctxt' :: LHsContext GhcPs
ctxt', tc' :: Located RdrName
tc', bndrs' :: Maybe [LHsTyVarBndr GhcPs]
bndrs', typats' :: HsTyPats GhcPs
typats') <- Cxt
-> Maybe [TyVarBndr]
-> Type
-> CvtM
     (LHsContext GhcPs, Located RdrName, Maybe [LHsTyVarBndr GhcPs],
      HsTyPats GhcPs)
cvt_datainst_hdr Cxt
ctxt Maybe [TyVarBndr]
bndrs Type
tys
       ; Maybe (LHsType GhcPs)
ksig' <- Type -> CvtM (LHsType GhcPs)
cvtKind (Type -> CvtM (LHsType GhcPs))
-> Maybe Type -> CvtM (Maybe (LHsType GhcPs))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
`traverse` Maybe Type
ksig
       ; LConDecl GhcPs
con' <- Con -> CvtM (LConDecl GhcPs)
cvtConstr Con
constr
       ; HsDeriving GhcPs
derivs' <- [DerivClause] -> CvtM (HsDeriving GhcPs)
cvtDerivs [DerivClause]
derivs
       ; let defn :: HsDataDefn GhcPs
defn = HsDataDefn :: forall pass.
XCHsDataDefn pass
-> NewOrData
-> LHsContext pass
-> Maybe (Located CType)
-> Maybe (LHsKind pass)
-> [LConDecl pass]
-> HsDeriving pass
-> HsDataDefn pass
HsDataDefn { dd_ext :: XCHsDataDefn GhcPs
dd_ext = XCHsDataDefn GhcPs
NoExt
noExt
                               , dd_ND :: NewOrData
dd_ND = NewOrData
NewType, dd_cType :: Maybe (Located CType)
dd_cType = Maybe (Located CType)
forall a. Maybe a
Nothing
                               , dd_ctxt :: LHsContext GhcPs
dd_ctxt = LHsContext GhcPs
ctxt'
                               , dd_kindSig :: Maybe (LHsType GhcPs)
dd_kindSig = Maybe (LHsType GhcPs)
ksig'
                               , dd_cons :: [LConDecl GhcPs]
dd_cons = [LConDecl GhcPs
con'], dd_derivs :: HsDeriving GhcPs
dd_derivs = HsDeriving GhcPs
derivs' }
       ; SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs))
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM (Maybe a)
returnJustL (SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs)))
-> SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs))
forall a b. (a -> b) -> a -> b
$ XInstD GhcPs -> InstDecl GhcPs -> HsDecl GhcPs
forall p. XInstD p -> InstDecl p -> HsDecl p
InstD XInstD GhcPs
NoExt
noExt (InstDecl GhcPs -> SrcSpanLess (LHsDecl GhcPs))
-> InstDecl GhcPs -> SrcSpanLess (LHsDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ DataFamInstD :: forall pass.
XDataFamInstD pass -> DataFamInstDecl pass -> InstDecl pass
DataFamInstD
           { dfid_ext :: XDataFamInstD GhcPs
dfid_ext = XDataFamInstD GhcPs
NoExt
noExt
           , dfid_inst :: DataFamInstDecl GhcPs
dfid_inst = DataFamInstDecl :: forall pass.
FamInstEqn pass (HsDataDefn pass) -> DataFamInstDecl pass
DataFamInstDecl { dfid_eqn :: FamInstEqn GhcPs (HsDataDefn GhcPs)
dfid_eqn = FamEqn GhcPs (HsTyPats GhcPs) (HsDataDefn GhcPs)
-> FamInstEqn GhcPs (HsDataDefn GhcPs)
forall thing. thing -> HsImplicitBndrs GhcPs thing
mkHsImplicitBndrs (FamEqn GhcPs (HsTyPats GhcPs) (HsDataDefn GhcPs)
 -> FamInstEqn GhcPs (HsDataDefn GhcPs))
-> FamEqn GhcPs (HsTyPats GhcPs) (HsDataDefn GhcPs)
-> FamInstEqn GhcPs (HsDataDefn GhcPs)
forall a b. (a -> b) -> a -> b
$
                           FamEqn :: forall pass pats rhs.
XCFamEqn pass pats rhs
-> Located (IdP pass)
-> Maybe [LHsTyVarBndr pass]
-> pats
-> LexicalFixity
-> rhs
-> FamEqn pass pats rhs
FamEqn { feqn_ext :: XCFamEqn GhcPs (HsTyPats GhcPs) (HsDataDefn GhcPs)
feqn_ext = XCFamEqn GhcPs (HsTyPats GhcPs) (HsDataDefn GhcPs)
NoExt
noExt
                                  , feqn_tycon :: Located (IdP GhcPs)
feqn_tycon = Located RdrName
Located (IdP GhcPs)
tc'
                                  , feqn_bndrs :: Maybe [LHsTyVarBndr GhcPs]
feqn_bndrs = Maybe [LHsTyVarBndr GhcPs]
bndrs'
                                  , feqn_pats :: HsTyPats GhcPs
feqn_pats = HsTyPats GhcPs
typats'
                                  , feqn_rhs :: HsDataDefn GhcPs
feqn_rhs = HsDataDefn GhcPs
defn
                                  , feqn_fixity :: LexicalFixity
feqn_fixity = LexicalFixity
Prefix } }}}

cvtDec (TySynInstD eqn :: TySynEqn
eqn)
  = do  { (LTyFamInstEqn GhcPs -> Located (SrcSpanLess (LTyFamInstEqn GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ eqn' :: SrcSpanLess (LTyFamInstEqn GhcPs)
eqn') <- TySynEqn -> CvtM (LTyFamInstEqn GhcPs)
cvtTySynEqn TySynEqn
eqn
        ; SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs))
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM (Maybe a)
returnJustL (SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs)))
-> SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs))
forall a b. (a -> b) -> a -> b
$ XInstD GhcPs -> InstDecl GhcPs -> HsDecl GhcPs
forall p. XInstD p -> InstDecl p -> HsDecl p
InstD XInstD GhcPs
NoExt
noExt (InstDecl GhcPs -> SrcSpanLess (LHsDecl GhcPs))
-> InstDecl GhcPs -> SrcSpanLess (LHsDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ TyFamInstD :: forall pass.
XTyFamInstD pass -> TyFamInstDecl pass -> InstDecl pass
TyFamInstD
            { tfid_ext :: XTyFamInstD GhcPs
tfid_ext = XTyFamInstD GhcPs
NoExt
noExt
            , tfid_inst :: TyFamInstDecl GhcPs
tfid_inst = TyFamInstDecl :: forall pass. TyFamInstEqn pass -> TyFamInstDecl pass
TyFamInstDecl { tfid_eqn :: TyFamInstEqn GhcPs
tfid_eqn = SrcSpanLess (LTyFamInstEqn GhcPs)
TyFamInstEqn GhcPs
eqn' } } }

cvtDec (OpenTypeFamilyD head :: TypeFamilyHead
head)
  = do { (tc' :: Located RdrName
tc', tyvars' :: LHsQTyVars GhcPs
tyvars', result' :: LFamilyResultSig GhcPs
result', injectivity' :: Maybe (LInjectivityAnn GhcPs)
injectivity') <- TypeFamilyHead
-> CvtM
     (Located RdrName, LHsQTyVars GhcPs, LFamilyResultSig GhcPs,
      Maybe (LInjectivityAnn GhcPs))
cvt_tyfam_head TypeFamilyHead
head
       ; SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs))
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM (Maybe a)
returnJustL (SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs)))
-> SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs))
forall a b. (a -> b) -> a -> b
$ XTyClD GhcPs -> TyClDecl GhcPs -> HsDecl GhcPs
forall p. XTyClD p -> TyClDecl p -> HsDecl p
TyClD XTyClD GhcPs
NoExt
noExt (TyClDecl GhcPs -> SrcSpanLess (LHsDecl GhcPs))
-> TyClDecl GhcPs -> SrcSpanLess (LHsDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ XFamDecl GhcPs -> FamilyDecl GhcPs -> TyClDecl GhcPs
forall pass. XFamDecl pass -> FamilyDecl pass -> TyClDecl pass
FamDecl XFamDecl GhcPs
NoExt
noExt (FamilyDecl GhcPs -> TyClDecl GhcPs)
-> FamilyDecl GhcPs -> TyClDecl GhcPs
forall a b. (a -> b) -> a -> b
$
         XCFamilyDecl GhcPs
-> FamilyInfo GhcPs
-> Located (IdP GhcPs)
-> LHsQTyVars GhcPs
-> LexicalFixity
-> LFamilyResultSig GhcPs
-> Maybe (LInjectivityAnn GhcPs)
-> FamilyDecl GhcPs
forall pass.
XCFamilyDecl pass
-> FamilyInfo pass
-> Located (IdP pass)
-> LHsQTyVars pass
-> LexicalFixity
-> LFamilyResultSig pass
-> Maybe (LInjectivityAnn pass)
-> FamilyDecl pass
FamilyDecl XCFamilyDecl GhcPs
NoExt
noExt FamilyInfo GhcPs
forall pass. FamilyInfo pass
OpenTypeFamily Located RdrName
Located (IdP GhcPs)
tc' LHsQTyVars GhcPs
tyvars' LexicalFixity
Prefix LFamilyResultSig GhcPs
result' Maybe (LInjectivityAnn GhcPs)
injectivity'
       }

cvtDec (ClosedTypeFamilyD head :: TypeFamilyHead
head eqns :: [TySynEqn]
eqns)
  = do { (tc' :: Located RdrName
tc', tyvars' :: LHsQTyVars GhcPs
tyvars', result' :: LFamilyResultSig GhcPs
result', injectivity' :: Maybe (LInjectivityAnn GhcPs)
injectivity') <- TypeFamilyHead
-> CvtM
     (Located RdrName, LHsQTyVars GhcPs, LFamilyResultSig GhcPs,
      Maybe (LInjectivityAnn GhcPs))
cvt_tyfam_head TypeFamilyHead
head
       ; [LTyFamInstEqn GhcPs]
eqns' <- (TySynEqn -> CvtM (LTyFamInstEqn GhcPs))
-> [TySynEqn] -> CvtM [LTyFamInstEqn GhcPs]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TySynEqn -> CvtM (LTyFamInstEqn GhcPs)
cvtTySynEqn [TySynEqn]
eqns
       ; SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs))
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM (Maybe a)
returnJustL (SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs)))
-> SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs))
forall a b. (a -> b) -> a -> b
$ XTyClD GhcPs -> TyClDecl GhcPs -> HsDecl GhcPs
forall p. XTyClD p -> TyClDecl p -> HsDecl p
TyClD XTyClD GhcPs
NoExt
noExt (TyClDecl GhcPs -> SrcSpanLess (LHsDecl GhcPs))
-> TyClDecl GhcPs -> SrcSpanLess (LHsDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ XFamDecl GhcPs -> FamilyDecl GhcPs -> TyClDecl GhcPs
forall pass. XFamDecl pass -> FamilyDecl pass -> TyClDecl pass
FamDecl XFamDecl GhcPs
NoExt
noExt (FamilyDecl GhcPs -> TyClDecl GhcPs)
-> FamilyDecl GhcPs -> TyClDecl GhcPs
forall a b. (a -> b) -> a -> b
$
         XCFamilyDecl GhcPs
-> FamilyInfo GhcPs
-> Located (IdP GhcPs)
-> LHsQTyVars GhcPs
-> LexicalFixity
-> LFamilyResultSig GhcPs
-> Maybe (LInjectivityAnn GhcPs)
-> FamilyDecl GhcPs
forall pass.
XCFamilyDecl pass
-> FamilyInfo pass
-> Located (IdP pass)
-> LHsQTyVars pass
-> LexicalFixity
-> LFamilyResultSig pass
-> Maybe (LInjectivityAnn pass)
-> FamilyDecl pass
FamilyDecl XCFamilyDecl GhcPs
NoExt
noExt (Maybe [LTyFamInstEqn GhcPs] -> FamilyInfo GhcPs
forall pass. Maybe [LTyFamInstEqn pass] -> FamilyInfo pass
ClosedTypeFamily ([LTyFamInstEqn GhcPs] -> Maybe [LTyFamInstEqn GhcPs]
forall a. a -> Maybe a
Just [LTyFamInstEqn GhcPs]
eqns')) Located RdrName
Located (IdP GhcPs)
tc' LHsQTyVars GhcPs
tyvars' LexicalFixity
Prefix
                           LFamilyResultSig GhcPs
result' Maybe (LInjectivityAnn GhcPs)
injectivity' }

cvtDec (TH.RoleAnnotD tc :: Name
tc roles :: [Role]
roles)
  = do { Located RdrName
tc' <- Name -> CvtM (Located RdrName)
tconNameL Name
tc
       ; let roles' :: [Located (Maybe Role)]
roles' = (Role -> Located (Maybe Role)) -> [Role] -> [Located (Maybe Role)]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe Role -> Located (Maybe Role)
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (Maybe Role -> Located (Maybe Role))
-> (Role -> Maybe Role) -> Role -> Located (Maybe Role)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Role -> Maybe Role
cvtRole) [Role]
roles
       ; SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs))
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM (Maybe a)
returnJustL (SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs)))
-> SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs))
forall a b. (a -> b) -> a -> b
$ XRoleAnnotD GhcPs -> RoleAnnotDecl GhcPs -> HsDecl GhcPs
forall p. XRoleAnnotD p -> RoleAnnotDecl p -> HsDecl p
Hs.RoleAnnotD XRoleAnnotD GhcPs
NoExt
noExt (XCRoleAnnotDecl GhcPs
-> Located (IdP GhcPs)
-> [Located (Maybe Role)]
-> RoleAnnotDecl GhcPs
forall pass.
XCRoleAnnotDecl pass
-> Located (IdP pass)
-> [Located (Maybe Role)]
-> RoleAnnotDecl pass
RoleAnnotDecl XCRoleAnnotDecl GhcPs
NoExt
noExt Located RdrName
Located (IdP GhcPs)
tc' [Located (Maybe Role)]
roles') }

cvtDec (TH.StandaloneDerivD ds :: Maybe DerivStrategy
ds cxt :: Cxt
cxt ty :: Type
ty)
  = do { LHsContext GhcPs
cxt' <- Cxt -> CvtM (LHsContext GhcPs)
cvtContext Cxt
cxt
       ; Maybe (LDerivStrategy GhcPs)
ds'  <- (DerivStrategy -> CvtM (LDerivStrategy GhcPs))
-> Maybe DerivStrategy -> CvtM (Maybe (LDerivStrategy GhcPs))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse DerivStrategy -> CvtM (LDerivStrategy GhcPs)
cvtDerivStrategy Maybe DerivStrategy
ds
       ; (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc ty' :: SrcSpanLess (LHsType GhcPs)
ty') <- Type -> CvtM (LHsType GhcPs)
cvtType Type
ty
       ; let inst_ty' :: LHsType GhcPs
inst_ty' = Cxt
-> SrcSpan -> LHsContext GhcPs -> LHsType GhcPs -> LHsType GhcPs
mkHsQualTy Cxt
cxt SrcSpan
loc LHsContext GhcPs
cxt' (LHsType GhcPs -> LHsType GhcPs) -> LHsType GhcPs -> LHsType GhcPs
forall a b. (a -> b) -> a -> b
$ SrcSpan -> SrcSpanLess (LHsType GhcPs) -> LHsType GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc SrcSpanLess (LHsType GhcPs)
ty'
       ; SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs))
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM (Maybe a)
returnJustL (SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs)))
-> SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs))
forall a b. (a -> b) -> a -> b
$ XDerivD GhcPs -> DerivDecl GhcPs -> HsDecl GhcPs
forall p. XDerivD p -> DerivDecl p -> HsDecl p
DerivD XDerivD GhcPs
NoExt
noExt (DerivDecl GhcPs -> SrcSpanLess (LHsDecl GhcPs))
-> DerivDecl GhcPs -> SrcSpanLess (LHsDecl GhcPs)
forall a b. (a -> b) -> a -> b
$
         DerivDecl :: forall pass.
XCDerivDecl pass
-> LHsSigWcType pass
-> Maybe (LDerivStrategy pass)
-> Maybe (Located OverlapMode)
-> DerivDecl pass
DerivDecl { deriv_ext :: XCDerivDecl GhcPs
deriv_ext =XCDerivDecl GhcPs
NoExt
noExt
                   , deriv_strategy :: Maybe (LDerivStrategy GhcPs)
deriv_strategy = Maybe (LDerivStrategy GhcPs)
ds'
                   , deriv_type :: LHsSigWcType GhcPs
deriv_type = LHsType GhcPs -> LHsSigWcType GhcPs
mkLHsSigWcType LHsType GhcPs
inst_ty'
                   , deriv_overlap_mode :: Maybe (Located OverlapMode)
deriv_overlap_mode = Maybe (Located OverlapMode)
forall a. Maybe a
Nothing } }

cvtDec (TH.DefaultSigD nm :: Name
nm typ :: Type
typ)
  = do { Located RdrName
nm' <- Name -> CvtM (Located RdrName)
vNameL Name
nm
       ; LHsType GhcPs
ty' <- Type -> CvtM (LHsType GhcPs)
cvtType Type
typ
       ; SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs))
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM (Maybe a)
returnJustL (SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs)))
-> SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs))
forall a b. (a -> b) -> a -> b
$ XSigD GhcPs -> Sig GhcPs -> HsDecl GhcPs
forall p. XSigD p -> Sig p -> HsDecl p
Hs.SigD XSigD GhcPs
NoExt
noExt
                     (Sig GhcPs -> SrcSpanLess (LHsDecl GhcPs))
-> Sig GhcPs -> SrcSpanLess (LHsDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ XClassOpSig GhcPs
-> Bool -> [Located (IdP GhcPs)] -> LHsSigType GhcPs -> Sig GhcPs
forall pass.
XClassOpSig pass
-> Bool -> [Located (IdP pass)] -> LHsSigType pass -> Sig pass
ClassOpSig XClassOpSig GhcPs
NoExt
noExt Bool
True [Located RdrName
Located (IdP GhcPs)
nm'] (LHsType GhcPs -> LHsSigType GhcPs
mkLHsSigType LHsType GhcPs
ty')}

cvtDec (TH.PatSynD nm :: Name
nm args :: PatSynArgs
args dir :: PatSynDir
dir pat :: Pat
pat)
  = do { Located RdrName
nm'   <- Name -> CvtM (Located RdrName)
cNameL Name
nm
       ; HsConDetails
  (Located RdrName) [RecordPatSynField (Located RdrName)]
args' <- PatSynArgs
-> CvtM
     (HsConDetails
        (Located RdrName) [RecordPatSynField (Located RdrName)])
cvtArgs PatSynArgs
args
       ; HsPatSynDir GhcPs
dir'  <- Located RdrName -> PatSynDir -> CvtM (HsPatSynDir GhcPs)
cvtDir Located RdrName
nm' PatSynDir
dir
       ; LPat GhcPs
pat'  <- Pat -> CvtM (LPat GhcPs)
cvtPat Pat
pat
       ; SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs))
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM (Maybe a)
returnJustL (SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs)))
-> SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs))
forall a b. (a -> b) -> a -> b
$ XValD GhcPs -> HsBind GhcPs -> HsDecl GhcPs
forall p. XValD p -> HsBind p -> HsDecl p
Hs.ValD XValD GhcPs
NoExt
noExt (HsBind GhcPs -> SrcSpanLess (LHsDecl GhcPs))
-> HsBind GhcPs -> SrcSpanLess (LHsDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ XPatSynBind GhcPs GhcPs -> PatSynBind GhcPs GhcPs -> HsBind GhcPs
forall idL idR.
XPatSynBind idL idR -> PatSynBind idL idR -> HsBindLR idL idR
PatSynBind XPatSynBind GhcPs GhcPs
NoExt
noExt (PatSynBind GhcPs GhcPs -> HsBind GhcPs)
-> PatSynBind GhcPs GhcPs -> HsBind GhcPs
forall a b. (a -> b) -> a -> b
$
           XPSB GhcPs GhcPs
-> Located (IdP GhcPs)
-> HsPatSynDetails (Located (IdP GhcPs))
-> LPat GhcPs
-> HsPatSynDir GhcPs
-> PatSynBind GhcPs GhcPs
forall idL idR.
XPSB idL idR
-> Located (IdP idL)
-> HsPatSynDetails (Located (IdP idR))
-> LPat idR
-> HsPatSynDir idR
-> PatSynBind idL idR
PSB XPSB GhcPs GhcPs
NoExt
noExt Located RdrName
Located (IdP GhcPs)
nm' HsConDetails
  (Located RdrName) [RecordPatSynField (Located RdrName)]
HsPatSynDetails (Located (IdP GhcPs))
args' LPat GhcPs
pat' HsPatSynDir GhcPs
dir' }
  where
    cvtArgs :: PatSynArgs
-> CvtM
     (HsConDetails
        (Located RdrName) [RecordPatSynField (Located RdrName)])
cvtArgs (TH.PrefixPatSyn args :: [Name]
args) = [Located RdrName]
-> HsConDetails
     (Located RdrName) [RecordPatSynField (Located RdrName)]
forall arg rec. [arg] -> HsConDetails arg rec
Hs.PrefixCon ([Located RdrName]
 -> HsConDetails
      (Located RdrName) [RecordPatSynField (Located RdrName)])
-> CvtM [Located RdrName]
-> CvtM
     (HsConDetails
        (Located RdrName) [RecordPatSynField (Located RdrName)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name -> CvtM (Located RdrName))
-> [Name] -> CvtM [Located RdrName]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> CvtM (Located RdrName)
vNameL [Name]
args
    cvtArgs (TH.InfixPatSyn a1 :: Name
a1 a2 :: Name
a2) = Located RdrName
-> Located RdrName
-> HsConDetails
     (Located RdrName) [RecordPatSynField (Located RdrName)]
forall arg rec. arg -> arg -> HsConDetails arg rec
Hs.InfixCon (Located RdrName
 -> Located RdrName
 -> HsConDetails
      (Located RdrName) [RecordPatSynField (Located RdrName)])
-> CvtM (Located RdrName)
-> CvtM
     (Located RdrName
      -> HsConDetails
           (Located RdrName) [RecordPatSynField (Located RdrName)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> CvtM (Located RdrName)
vNameL Name
a1 CvtM
  (Located RdrName
   -> HsConDetails
        (Located RdrName) [RecordPatSynField (Located RdrName)])
-> CvtM (Located RdrName)
-> CvtM
     (HsConDetails
        (Located RdrName) [RecordPatSynField (Located RdrName)])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Name -> CvtM (Located RdrName)
vNameL Name
a2
    cvtArgs (TH.RecordPatSyn sels :: [Name]
sels)
      = do { [Located RdrName]
sels' <- (Name -> CvtM (Located RdrName))
-> [Name] -> CvtM [Located RdrName]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> CvtM (Located RdrName)
vNameL [Name]
sels
           ; [Located RdrName]
vars' <- (Name -> CvtM (Located RdrName))
-> [Name] -> CvtM [Located RdrName]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Name -> CvtM (Located RdrName)
vNameL (Name -> CvtM (Located RdrName))
-> (Name -> Name) -> Name -> CvtM (Located RdrName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkNameS (String -> Name) -> (Name -> String) -> Name -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase) [Name]
sels
           ; HsConDetails
  (Located RdrName) [RecordPatSynField (Located RdrName)]
-> CvtM
     (HsConDetails
        (Located RdrName) [RecordPatSynField (Located RdrName)])
forall (m :: * -> *) a. Monad m => a -> m a
return (HsConDetails
   (Located RdrName) [RecordPatSynField (Located RdrName)]
 -> CvtM
      (HsConDetails
         (Located RdrName) [RecordPatSynField (Located RdrName)]))
-> HsConDetails
     (Located RdrName) [RecordPatSynField (Located RdrName)]
-> CvtM
     (HsConDetails
        (Located RdrName) [RecordPatSynField (Located RdrName)])
forall a b. (a -> b) -> a -> b
$ [RecordPatSynField (Located RdrName)]
-> HsConDetails
     (Located RdrName) [RecordPatSynField (Located RdrName)]
forall arg rec. rec -> HsConDetails arg rec
Hs.RecCon ([RecordPatSynField (Located RdrName)]
 -> HsConDetails
      (Located RdrName) [RecordPatSynField (Located RdrName)])
-> [RecordPatSynField (Located RdrName)]
-> HsConDetails
     (Located RdrName) [RecordPatSynField (Located RdrName)]
forall a b. (a -> b) -> a -> b
$ (Located RdrName
 -> Located RdrName -> RecordPatSynField (Located RdrName))
-> [Located RdrName]
-> [Located RdrName]
-> [RecordPatSynField (Located RdrName)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Located RdrName
-> Located RdrName -> RecordPatSynField (Located RdrName)
forall a. a -> a -> RecordPatSynField a
RecordPatSynField [Located RdrName]
sels' [Located RdrName]
vars' }

    cvtDir :: Located RdrName -> PatSynDir -> CvtM (HsPatSynDir GhcPs)
cvtDir _ Unidir          = HsPatSynDir GhcPs -> CvtM (HsPatSynDir GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return HsPatSynDir GhcPs
forall id. HsPatSynDir id
Unidirectional
    cvtDir _ ImplBidir       = HsPatSynDir GhcPs -> CvtM (HsPatSynDir GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return HsPatSynDir GhcPs
forall id. HsPatSynDir id
ImplicitBidirectional
    cvtDir n :: Located RdrName
n (ExplBidir cls :: [Clause]
cls) =
      do { [LMatch GhcPs (LHsExpr GhcPs)]
ms <- (Clause -> CvtM (LMatch GhcPs (LHsExpr GhcPs)))
-> [Clause] -> CvtM [LMatch GhcPs (LHsExpr GhcPs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (HsMatchContext RdrName
-> Clause -> CvtM (LMatch GhcPs (LHsExpr GhcPs))
cvtClause (Located RdrName -> HsMatchContext RdrName
forall id. Located id -> HsMatchContext id
mkPrefixFunRhs Located RdrName
n)) [Clause]
cls
         ; HsPatSynDir GhcPs -> CvtM (HsPatSynDir GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsPatSynDir GhcPs -> CvtM (HsPatSynDir GhcPs))
-> HsPatSynDir GhcPs -> CvtM (HsPatSynDir GhcPs)
forall a b. (a -> b) -> a -> b
$ MatchGroup GhcPs (LHsExpr GhcPs) -> HsPatSynDir GhcPs
forall id. MatchGroup id (LHsExpr id) -> HsPatSynDir id
ExplicitBidirectional (MatchGroup GhcPs (LHsExpr GhcPs) -> HsPatSynDir GhcPs)
-> MatchGroup GhcPs (LHsExpr GhcPs) -> HsPatSynDir GhcPs
forall a b. (a -> b) -> a -> b
$ Origin
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> MatchGroup GhcPs (LHsExpr GhcPs)
forall name (body :: * -> *).
(XMG name (Located (body name)) ~ NoExt) =>
Origin
-> [LMatch name (Located (body name))]
-> MatchGroup name (Located (body name))
mkMatchGroup Origin
FromSource [LMatch GhcPs (LHsExpr GhcPs)]
ms }

cvtDec (TH.PatSynSigD nm :: Name
nm ty :: Type
ty)
  = do { Located RdrName
nm' <- Name -> CvtM (Located RdrName)
cNameL Name
nm
       ; LHsType GhcPs
ty' <- Type -> CvtM (LHsType GhcPs)
cvtPatSynSigTy Type
ty
       ; SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs))
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM (Maybe a)
returnJustL (SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs)))
-> SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs))
forall a b. (a -> b) -> a -> b
$ XSigD GhcPs -> Sig GhcPs -> HsDecl GhcPs
forall p. XSigD p -> Sig p -> HsDecl p
Hs.SigD XSigD GhcPs
NoExt
noExt (Sig GhcPs -> SrcSpanLess (LHsDecl GhcPs))
-> Sig GhcPs -> SrcSpanLess (LHsDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ XPatSynSig GhcPs
-> [Located (IdP GhcPs)] -> LHsSigType GhcPs -> Sig GhcPs
forall pass.
XPatSynSig pass
-> [Located (IdP pass)] -> LHsSigType pass -> Sig pass
PatSynSig XPatSynSig GhcPs
NoExt
noExt [Located RdrName
Located (IdP GhcPs)
nm'] (LHsType GhcPs -> LHsSigType GhcPs
mkLHsSigType LHsType GhcPs
ty')}

-- Implicit parameter bindings are handled in cvtLocalDecs and
-- cvtImplicitParamBind. They are not allowed in any other scope, so
-- reaching this case indicates an error.
cvtDec (TH.ImplicitParamBindD _ _)
  = MsgDoc -> CvtM (Maybe (LHsDecl GhcPs))
forall a. MsgDoc -> CvtM a
failWith (String -> MsgDoc
text "Implicit parameter binding only allowed in let or where")

----------------
cvtTySynEqn :: TySynEqn -> CvtM (LTyFamInstEqn GhcPs)
cvtTySynEqn :: TySynEqn -> CvtM (LTyFamInstEqn GhcPs)
cvtTySynEqn (TySynEqn mb_bndrs :: Maybe [TyVarBndr]
mb_bndrs lhs :: Type
lhs rhs :: Type
rhs)
  = do { Maybe [LHsTyVarBndr GhcPs]
mb_bndrs' <- ([TyVarBndr] -> CvtM [LHsTyVarBndr GhcPs])
-> Maybe [TyVarBndr] -> CvtM (Maybe [LHsTyVarBndr GhcPs])
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((TyVarBndr -> CvtM (LHsTyVarBndr GhcPs))
-> [TyVarBndr] -> CvtM [LHsTyVarBndr GhcPs]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TyVarBndr -> CvtM (LHsTyVarBndr GhcPs)
cvt_tv) Maybe [TyVarBndr]
mb_bndrs
       ; (head_ty :: Type
head_ty, args :: HsTyPats GhcPs
args) <- Type -> CvtM (Type, HsTyPats GhcPs)
split_ty_app Type
lhs
       ; case Type
head_ty of
           ConT nm :: Name
nm -> do { Located RdrName
nm' <- Name -> CvtM (Located RdrName)
tconNameL Name
nm
                         ; LHsType GhcPs
rhs' <- Type -> CvtM (LHsType GhcPs)
cvtType Type
rhs
                         ; let args' :: HsTyPats GhcPs
args' = (LHsTypeArg GhcPs -> LHsTypeArg GhcPs)
-> HsTyPats GhcPs -> HsTyPats GhcPs
forall a b. (a -> b) -> [a] -> [b]
map LHsTypeArg GhcPs -> LHsTypeArg GhcPs
wrap_tyarg HsTyPats GhcPs
args
                         ; SrcSpanLess (LTyFamInstEqn GhcPs) -> CvtM (LTyFamInstEqn GhcPs)
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM a
returnL (SrcSpanLess (LTyFamInstEqn GhcPs) -> CvtM (LTyFamInstEqn GhcPs))
-> SrcSpanLess (LTyFamInstEqn GhcPs) -> CvtM (LTyFamInstEqn GhcPs)
forall a b. (a -> b) -> a -> b
$ FamEqn GhcPs (HsTyPats GhcPs) (LHsType GhcPs)
-> SrcSpanLess (LTyFamInstEqn GhcPs)
forall thing. thing -> HsImplicitBndrs GhcPs thing
mkHsImplicitBndrs
                            (FamEqn GhcPs (HsTyPats GhcPs) (LHsType GhcPs)
 -> SrcSpanLess (LTyFamInstEqn GhcPs))
-> FamEqn GhcPs (HsTyPats GhcPs) (LHsType GhcPs)
-> SrcSpanLess (LTyFamInstEqn GhcPs)
forall a b. (a -> b) -> a -> b
$ FamEqn :: forall pass pats rhs.
XCFamEqn pass pats rhs
-> Located (IdP pass)
-> Maybe [LHsTyVarBndr pass]
-> pats
-> LexicalFixity
-> rhs
-> FamEqn pass pats rhs
FamEqn { feqn_ext :: XCFamEqn GhcPs (HsTyPats GhcPs) (LHsType GhcPs)
feqn_ext    = XCFamEqn GhcPs (HsTyPats GhcPs) (LHsType GhcPs)
NoExt
noExt
                                     , feqn_tycon :: Located (IdP GhcPs)
feqn_tycon  = Located RdrName
Located (IdP GhcPs)
nm'
                                     , feqn_bndrs :: Maybe [LHsTyVarBndr GhcPs]
feqn_bndrs  = Maybe [LHsTyVarBndr GhcPs]
mb_bndrs'
                                     , feqn_pats :: HsTyPats GhcPs
feqn_pats   = HsTyPats GhcPs
args'
                                     , feqn_fixity :: LexicalFixity
feqn_fixity = LexicalFixity
Prefix
                                     , feqn_rhs :: LHsType GhcPs
feqn_rhs    = LHsType GhcPs
rhs' } }
           InfixT t1 :: Type
t1 nm :: Name
nm t2 :: Type
t2 -> do { Located RdrName
nm' <- Name -> CvtM (Located RdrName)
tconNameL Name
nm
                                 ; [LHsType GhcPs]
args' <- (Type -> CvtM (LHsType GhcPs)) -> Cxt -> CvtM [LHsType GhcPs]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> CvtM (LHsType GhcPs)
cvtType [Type
t1,Type
t2]
                                 ; LHsType GhcPs
rhs' <- Type -> CvtM (LHsType GhcPs)
cvtType Type
rhs
                                 ; SrcSpanLess (LTyFamInstEqn GhcPs) -> CvtM (LTyFamInstEqn GhcPs)
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM a
returnL (SrcSpanLess (LTyFamInstEqn GhcPs) -> CvtM (LTyFamInstEqn GhcPs))
-> SrcSpanLess (LTyFamInstEqn GhcPs) -> CvtM (LTyFamInstEqn GhcPs)
forall a b. (a -> b) -> a -> b
$ FamEqn GhcPs (HsTyPats GhcPs) (LHsType GhcPs)
-> SrcSpanLess (LTyFamInstEqn GhcPs)
forall thing. thing -> HsImplicitBndrs GhcPs thing
mkHsImplicitBndrs
                                      (FamEqn GhcPs (HsTyPats GhcPs) (LHsType GhcPs)
 -> SrcSpanLess (LTyFamInstEqn GhcPs))
-> FamEqn GhcPs (HsTyPats GhcPs) (LHsType GhcPs)
-> SrcSpanLess (LTyFamInstEqn GhcPs)
forall a b. (a -> b) -> a -> b
$ FamEqn :: forall pass pats rhs.
XCFamEqn pass pats rhs
-> Located (IdP pass)
-> Maybe [LHsTyVarBndr pass]
-> pats
-> LexicalFixity
-> rhs
-> FamEqn pass pats rhs
FamEqn { feqn_ext :: XCFamEqn GhcPs (HsTyPats GhcPs) (LHsType GhcPs)
feqn_ext    = XCFamEqn GhcPs (HsTyPats GhcPs) (LHsType GhcPs)
NoExt
noExt
                                               , feqn_tycon :: Located (IdP GhcPs)
feqn_tycon  = Located RdrName
Located (IdP GhcPs)
nm'
                                               , feqn_bndrs :: Maybe [LHsTyVarBndr GhcPs]
feqn_bndrs  = Maybe [LHsTyVarBndr GhcPs]
mb_bndrs'
                                               , feqn_pats :: HsTyPats GhcPs
feqn_pats   =
                                                ((LHsType GhcPs -> LHsTypeArg GhcPs)
-> [LHsType GhcPs] -> HsTyPats GhcPs
forall a b. (a -> b) -> [a] -> [b]
map LHsType GhcPs -> LHsTypeArg GhcPs
forall tm ty. tm -> HsArg tm ty
HsValArg [LHsType GhcPs]
args') HsTyPats GhcPs -> HsTyPats GhcPs -> HsTyPats GhcPs
forall a. [a] -> [a] -> [a]
++ HsTyPats GhcPs
args
                                               , feqn_fixity :: LexicalFixity
feqn_fixity = LexicalFixity
Hs.Infix
                                               , feqn_rhs :: LHsType GhcPs
feqn_rhs    = LHsType GhcPs
rhs' } }
           _ -> MsgDoc -> CvtM (LTyFamInstEqn GhcPs)
forall a. MsgDoc -> CvtM a
failWith (MsgDoc -> CvtM (LTyFamInstEqn GhcPs))
-> MsgDoc -> CvtM (LTyFamInstEqn GhcPs)
forall a b. (a -> b) -> a -> b
$ String -> MsgDoc
text "Invalid type family instance LHS:"
                          MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text (Type -> String
forall a. Show a => a -> String
show Type
lhs)
        }

----------------
cvt_ci_decs :: MsgDoc -> [TH.Dec]
            -> CvtM (LHsBinds GhcPs,
                     [LSig GhcPs],
                     [LFamilyDecl GhcPs],
                     [LTyFamInstDecl GhcPs],
                     [LDataFamInstDecl GhcPs])
-- Convert the declarations inside a class or instance decl
-- ie signatures, bindings, and associated types
cvt_ci_decs :: MsgDoc
-> [Dec]
-> CvtM
     (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],
      [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs])
cvt_ci_decs doc :: MsgDoc
doc decs :: [Dec]
decs
  = do  { [LHsDecl GhcPs]
decs' <- [Dec] -> CvtM [LHsDecl GhcPs]
cvtDecs [Dec]
decs
        ; let (ats' :: [LTyFamInstDecl GhcPs]
ats', bind_sig_decs' :: [LHsDecl GhcPs]
bind_sig_decs') = (LHsDecl GhcPs -> Either (LTyFamInstDecl GhcPs) (LHsDecl GhcPs))
-> [LHsDecl GhcPs] -> ([LTyFamInstDecl GhcPs], [LHsDecl GhcPs])
forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
partitionWith LHsDecl GhcPs -> Either (LTyFamInstDecl GhcPs) (LHsDecl GhcPs)
is_tyfam_inst [LHsDecl GhcPs]
decs'
        ; let (adts' :: [LDataFamInstDecl GhcPs]
adts', no_ats' :: [LHsDecl GhcPs]
no_ats')       = (LHsDecl GhcPs -> Either (LDataFamInstDecl GhcPs) (LHsDecl GhcPs))
-> [LHsDecl GhcPs] -> ([LDataFamInstDecl GhcPs], [LHsDecl GhcPs])
forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
partitionWith LHsDecl GhcPs -> Either (LDataFamInstDecl GhcPs) (LHsDecl GhcPs)
is_datafam_inst [LHsDecl GhcPs]
bind_sig_decs'
        ; let (sigs' :: [LSig GhcPs]
sigs', prob_binds' :: [LHsDecl GhcPs]
prob_binds')   = (LHsDecl GhcPs -> Either (LSig GhcPs) (LHsDecl GhcPs))
-> [LHsDecl GhcPs] -> ([LSig GhcPs], [LHsDecl GhcPs])
forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
partitionWith LHsDecl GhcPs -> Either (LSig GhcPs) (LHsDecl GhcPs)
is_sig [LHsDecl GhcPs]
no_ats'
        ; let (binds' :: [LHsBind GhcPs]
binds', prob_fams' :: [LHsDecl GhcPs]
prob_fams')   = (LHsDecl GhcPs -> Either (LHsBind GhcPs) (LHsDecl GhcPs))
-> [LHsDecl GhcPs] -> ([LHsBind GhcPs], [LHsDecl GhcPs])
forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
partitionWith LHsDecl GhcPs -> Either (LHsBind GhcPs) (LHsDecl GhcPs)
is_bind [LHsDecl GhcPs]
prob_binds'
        ; let (fams' :: [LFamilyDecl GhcPs]
fams', bads :: [LHsDecl GhcPs]
bads)          = (LHsDecl GhcPs -> Either (LFamilyDecl GhcPs) (LHsDecl GhcPs))
-> [LHsDecl GhcPs] -> ([LFamilyDecl GhcPs], [LHsDecl GhcPs])
forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
partitionWith LHsDecl GhcPs -> Either (LFamilyDecl GhcPs) (LHsDecl GhcPs)
is_fam_decl [LHsDecl GhcPs]
prob_fams'
        ; Bool -> CvtM () -> CvtM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([LHsDecl GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LHsDecl GhcPs]
bads) (MsgDoc -> CvtM ()
forall a. MsgDoc -> CvtM a
failWith (MsgDoc -> [LHsDecl GhcPs] -> MsgDoc
forall a. Outputable a => MsgDoc -> [a] -> MsgDoc
mkBadDecMsg MsgDoc
doc [LHsDecl GhcPs]
bads))
          --We use FromSource as the origin of the bind
          -- because the TH declaration is user-written
        ; (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],
 [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs])
-> CvtM
     (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],
      [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs])
forall (m :: * -> *) a. Monad m => a -> m a
return ([LHsBind GhcPs] -> LHsBinds GhcPs
forall a. [a] -> Bag a
listToBag [LHsBind GhcPs]
binds', [LSig GhcPs]
sigs', [LFamilyDecl GhcPs]
fams', [LTyFamInstDecl GhcPs]
ats', [LDataFamInstDecl GhcPs]
adts') }

----------------
cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr]
             -> CvtM ( LHsContext GhcPs
                     , Located RdrName
                     , LHsQTyVars GhcPs)
cvt_tycl_hdr :: Cxt
-> Name
-> [TyVarBndr]
-> CvtM (LHsContext GhcPs, Located RdrName, LHsQTyVars GhcPs)
cvt_tycl_hdr cxt :: Cxt
cxt tc :: Name
tc tvs :: [TyVarBndr]
tvs
  = do { LHsContext GhcPs
cxt' <- Cxt -> CvtM (LHsContext GhcPs)
cvtContext Cxt
cxt
       ; Located RdrName
tc'  <- Name -> CvtM (Located RdrName)
tconNameL Name
tc
       ; LHsQTyVars GhcPs
tvs' <- [TyVarBndr] -> CvtM (LHsQTyVars GhcPs)
cvtTvs [TyVarBndr]
tvs
       ; (LHsContext GhcPs, Located RdrName, LHsQTyVars GhcPs)
-> CvtM (LHsContext GhcPs, Located RdrName, LHsQTyVars GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsContext GhcPs
cxt', Located RdrName
tc', LHsQTyVars GhcPs
tvs')
       }

cvt_datainst_hdr :: TH.Cxt -> Maybe [TH.TyVarBndr] -> TH.Type
               -> CvtM ( LHsContext GhcPs
                       , Located RdrName
                       , Maybe [LHsTyVarBndr GhcPs]
                       , HsTyPats GhcPs)
cvt_datainst_hdr :: Cxt
-> Maybe [TyVarBndr]
-> Type
-> CvtM
     (LHsContext GhcPs, Located RdrName, Maybe [LHsTyVarBndr GhcPs],
      HsTyPats GhcPs)
cvt_datainst_hdr cxt :: Cxt
cxt bndrs :: Maybe [TyVarBndr]
bndrs tys :: Type
tys
  = do { LHsContext GhcPs
cxt' <- Cxt -> CvtM (LHsContext GhcPs)
cvtContext Cxt
cxt
       ; Maybe [LHsTyVarBndr GhcPs]
bndrs' <- ([TyVarBndr] -> CvtM [LHsTyVarBndr GhcPs])
-> Maybe [TyVarBndr] -> CvtM (Maybe [LHsTyVarBndr GhcPs])
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((TyVarBndr -> CvtM (LHsTyVarBndr GhcPs))
-> [TyVarBndr] -> CvtM [LHsTyVarBndr GhcPs]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TyVarBndr -> CvtM (LHsTyVarBndr GhcPs)
cvt_tv) Maybe [TyVarBndr]
bndrs
       ; (head_ty :: Type
head_ty, args :: HsTyPats GhcPs
args) <- Type -> CvtM (Type, HsTyPats GhcPs)
split_ty_app Type
tys
       ; case Type
head_ty of
          ConT nm :: Name
nm -> do { Located RdrName
nm' <- Name -> CvtM (Located RdrName)
tconNameL Name
nm
                        ; let args' :: HsTyPats GhcPs
args' = (LHsTypeArg GhcPs -> LHsTypeArg GhcPs)
-> HsTyPats GhcPs -> HsTyPats GhcPs
forall a b. (a -> b) -> [a] -> [b]
map LHsTypeArg GhcPs -> LHsTypeArg GhcPs
wrap_tyarg HsTyPats GhcPs
args
                        ; (LHsContext GhcPs, Located RdrName, Maybe [LHsTyVarBndr GhcPs],
 HsTyPats GhcPs)
-> CvtM
     (LHsContext GhcPs, Located RdrName, Maybe [LHsTyVarBndr GhcPs],
      HsTyPats GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsContext GhcPs
cxt', Located RdrName
nm', Maybe [LHsTyVarBndr GhcPs]
bndrs', HsTyPats GhcPs
args') }
          InfixT t1 :: Type
t1 nm :: Name
nm t2 :: Type
t2 -> do { Located RdrName
nm' <- Name -> CvtM (Located RdrName)
tconNameL Name
nm
                                ; [LHsType GhcPs]
args' <- (Type -> CvtM (LHsType GhcPs)) -> Cxt -> CvtM [LHsType GhcPs]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> CvtM (LHsType GhcPs)
cvtType [Type
t1,Type
t2]
                                ; (LHsContext GhcPs, Located RdrName, Maybe [LHsTyVarBndr GhcPs],
 HsTyPats GhcPs)
-> CvtM
     (LHsContext GhcPs, Located RdrName, Maybe [LHsTyVarBndr GhcPs],
      HsTyPats GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsContext GhcPs
cxt', Located RdrName
nm', Maybe [LHsTyVarBndr GhcPs]
bndrs',
                                         (((LHsType GhcPs -> LHsTypeArg GhcPs)
-> [LHsType GhcPs] -> HsTyPats GhcPs
forall a b. (a -> b) -> [a] -> [b]
map LHsType GhcPs -> LHsTypeArg GhcPs
forall tm ty. tm -> HsArg tm ty
HsValArg [LHsType GhcPs]
args') HsTyPats GhcPs -> HsTyPats GhcPs -> HsTyPats GhcPs
forall a. [a] -> [a] -> [a]
++ HsTyPats GhcPs
args)) }
          _ -> MsgDoc
-> CvtM
     (LHsContext GhcPs, Located RdrName, Maybe [LHsTyVarBndr GhcPs],
      HsTyPats GhcPs)
forall a. MsgDoc -> CvtM a
failWith (MsgDoc
 -> CvtM
      (LHsContext GhcPs, Located RdrName, Maybe [LHsTyVarBndr GhcPs],
       HsTyPats GhcPs))
-> MsgDoc
-> CvtM
     (LHsContext GhcPs, Located RdrName, Maybe [LHsTyVarBndr GhcPs],
      HsTyPats GhcPs)
forall a b. (a -> b) -> a -> b
$ String -> MsgDoc
text "Invalid type instance header:"
                          MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text (Type -> String
forall a. Show a => a -> String
show Type
tys) }

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

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

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

is_fam_decl :: LHsDecl GhcPs -> Either (LFamilyDecl GhcPs) (LHsDecl GhcPs)
is_fam_decl :: LHsDecl GhcPs -> Either (LFamilyDecl GhcPs) (LHsDecl GhcPs)
is_fam_decl (LHsDecl GhcPs -> Located (SrcSpanLess (LHsDecl GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc (TyClD _ (FamDecl { tcdFam = d }))) = LFamilyDecl GhcPs -> Either (LFamilyDecl GhcPs) (LHsDecl GhcPs)
forall a b. a -> Either a b
Left (SrcSpan -> SrcSpanLess (LFamilyDecl GhcPs) -> LFamilyDecl GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc SrcSpanLess (LFamilyDecl GhcPs)
FamilyDecl GhcPs
d)
is_fam_decl decl :: LHsDecl GhcPs
decl = LHsDecl GhcPs -> Either (LFamilyDecl GhcPs) (LHsDecl GhcPs)
forall a b. b -> Either a b
Right LHsDecl GhcPs
decl

is_tyfam_inst :: LHsDecl GhcPs -> Either (LTyFamInstDecl GhcPs) (LHsDecl GhcPs)
is_tyfam_inst :: LHsDecl GhcPs -> Either (LTyFamInstDecl GhcPs) (LHsDecl GhcPs)
is_tyfam_inst (LHsDecl GhcPs -> Located (SrcSpanLess (LHsDecl GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc (Hs.InstD _ (TyFamInstD { tfid_inst = d })))
  = LTyFamInstDecl GhcPs
-> Either (LTyFamInstDecl GhcPs) (LHsDecl GhcPs)
forall a b. a -> Either a b
Left (SrcSpan
-> SrcSpanLess (LTyFamInstDecl GhcPs) -> LTyFamInstDecl GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc SrcSpanLess (LTyFamInstDecl GhcPs)
TyFamInstDecl GhcPs
d)
is_tyfam_inst decl :: LHsDecl GhcPs
decl
  = LHsDecl GhcPs -> Either (LTyFamInstDecl GhcPs) (LHsDecl GhcPs)
forall a b. b -> Either a b
Right LHsDecl GhcPs
decl

is_datafam_inst :: LHsDecl GhcPs
                -> Either (LDataFamInstDecl GhcPs) (LHsDecl GhcPs)
is_datafam_inst :: LHsDecl GhcPs -> Either (LDataFamInstDecl GhcPs) (LHsDecl GhcPs)
is_datafam_inst (LHsDecl GhcPs -> Located (SrcSpanLess (LHsDecl GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc (Hs.InstD  _ (DataFamInstD { dfid_inst = d })))
  = LDataFamInstDecl GhcPs
-> Either (LDataFamInstDecl GhcPs) (LHsDecl GhcPs)
forall a b. a -> Either a b
Left (SrcSpan
-> SrcSpanLess (LDataFamInstDecl GhcPs) -> LDataFamInstDecl GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc SrcSpanLess (LDataFamInstDecl GhcPs)
DataFamInstDecl GhcPs
d)
is_datafam_inst decl :: LHsDecl GhcPs
decl
  = LHsDecl GhcPs -> Either (LDataFamInstDecl GhcPs) (LHsDecl GhcPs)
forall a b. b -> Either a b
Right LHsDecl GhcPs
decl

is_sig :: LHsDecl GhcPs -> Either (LSig GhcPs) (LHsDecl GhcPs)
is_sig :: LHsDecl GhcPs -> Either (LSig GhcPs) (LHsDecl GhcPs)
is_sig (LHsDecl GhcPs -> Located (SrcSpanLess (LHsDecl GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc (Hs.SigD _ sig)) = LSig GhcPs -> Either (LSig GhcPs) (LHsDecl GhcPs)
forall a b. a -> Either a b
Left (SrcSpan -> SrcSpanLess (LSig GhcPs) -> LSig GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc SrcSpanLess (LSig GhcPs)
Sig GhcPs
sig)
is_sig decl :: LHsDecl GhcPs
decl                        = LHsDecl GhcPs -> Either (LSig GhcPs) (LHsDecl GhcPs)
forall a b. b -> Either a b
Right LHsDecl GhcPs
decl

is_bind :: LHsDecl GhcPs -> Either (LHsBind GhcPs) (LHsDecl GhcPs)
is_bind :: LHsDecl GhcPs -> Either (LHsBind GhcPs) (LHsDecl GhcPs)
is_bind (LHsDecl GhcPs -> Located (SrcSpanLess (LHsDecl GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc (Hs.ValD _ bind)) = LHsBind GhcPs -> Either (LHsBind GhcPs) (LHsDecl GhcPs)
forall a b. a -> Either a b
Left (SrcSpan -> SrcSpanLess (LHsBind GhcPs) -> LHsBind GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc SrcSpanLess (LHsBind GhcPs)
HsBind GhcPs
bind)
is_bind decl :: LHsDecl GhcPs
decl                         = LHsDecl GhcPs -> Either (LHsBind GhcPs) (LHsDecl GhcPs)
forall a b. b -> Either a b
Right LHsDecl GhcPs
decl

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

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

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

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

cvtConstr :: Con -> CvtM (LConDecl GhcPs)
cvtConstr (NormalC c :: Name
c strtys :: [BangType]
strtys)
  = do  { Located RdrName
c'   <- Name -> CvtM (Located RdrName)
cNameL Name
c
        ; [LHsType GhcPs]
tys' <- (BangType -> CvtM (LHsType GhcPs))
-> [BangType] -> CvtM [LHsType GhcPs]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM BangType -> CvtM (LHsType GhcPs)
cvt_arg [BangType]
strtys
        ; SrcSpanLess (LConDecl GhcPs) -> CvtM (LConDecl GhcPs)
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM a
returnL (SrcSpanLess (LConDecl GhcPs) -> CvtM (LConDecl GhcPs))
-> SrcSpanLess (LConDecl GhcPs) -> CvtM (LConDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ Located RdrName
-> Maybe [LHsTyVarBndr GhcPs]
-> Maybe (LHsContext GhcPs)
-> HsConDeclDetails GhcPs
-> ConDecl GhcPs
mkConDeclH98 Located RdrName
c' Maybe [LHsTyVarBndr GhcPs]
forall a. Maybe a
Nothing Maybe (LHsContext GhcPs)
forall a. Maybe a
Nothing ([LHsType GhcPs] -> HsConDeclDetails GhcPs
forall arg rec. [arg] -> HsConDetails arg rec
PrefixCon [LHsType GhcPs]
tys') }

cvtConstr (RecC c :: Name
c varstrtys :: [VarBangType]
varstrtys)
  = do  { Located RdrName
c'    <- Name -> CvtM (Located RdrName)
cNameL Name
c
        ; [LConDeclField GhcPs]
args' <- (VarBangType -> CvtM (LConDeclField GhcPs))
-> [VarBangType] -> CvtM [LConDeclField GhcPs]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM VarBangType -> CvtM (LConDeclField GhcPs)
cvt_id_arg [VarBangType]
varstrtys
        ; SrcSpanLess (LConDecl GhcPs) -> CvtM (LConDecl GhcPs)
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM a
returnL (SrcSpanLess (LConDecl GhcPs) -> CvtM (LConDecl GhcPs))
-> SrcSpanLess (LConDecl GhcPs) -> CvtM (LConDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ Located RdrName
-> Maybe [LHsTyVarBndr GhcPs]
-> Maybe (LHsContext GhcPs)
-> HsConDeclDetails GhcPs
-> ConDecl GhcPs
mkConDeclH98 Located RdrName
c' Maybe [LHsTyVarBndr GhcPs]
forall a. Maybe a
Nothing Maybe (LHsContext GhcPs)
forall a. Maybe a
Nothing
                                   (Located [LConDeclField GhcPs] -> HsConDeclDetails GhcPs
forall arg rec. rec -> HsConDetails arg rec
RecCon (SrcSpanLess (Located [LConDeclField GhcPs])
-> Located [LConDeclField GhcPs]
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc [LConDeclField GhcPs]
SrcSpanLess (Located [LConDeclField GhcPs])
args')) }

cvtConstr (InfixC st1 :: BangType
st1 c :: Name
c st2 :: BangType
st2)
  = do  { Located RdrName
c'   <- Name -> CvtM (Located RdrName)
cNameL Name
c
        ; LHsType GhcPs
st1' <- BangType -> CvtM (LHsType GhcPs)
cvt_arg BangType
st1
        ; LHsType GhcPs
st2' <- BangType -> CvtM (LHsType GhcPs)
cvt_arg BangType
st2
        ; SrcSpanLess (LConDecl GhcPs) -> CvtM (LConDecl GhcPs)
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM a
returnL (SrcSpanLess (LConDecl GhcPs) -> CvtM (LConDecl GhcPs))
-> SrcSpanLess (LConDecl GhcPs) -> CvtM (LConDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ Located RdrName
-> Maybe [LHsTyVarBndr GhcPs]
-> Maybe (LHsContext GhcPs)
-> HsConDeclDetails GhcPs
-> ConDecl GhcPs
mkConDeclH98 Located RdrName
c' Maybe [LHsTyVarBndr GhcPs]
forall a. Maybe a
Nothing Maybe (LHsContext GhcPs)
forall a. Maybe a
Nothing (LHsType GhcPs -> LHsType GhcPs -> HsConDeclDetails GhcPs
forall arg rec. arg -> arg -> HsConDetails arg rec
InfixCon LHsType GhcPs
st1' LHsType GhcPs
st2') }

cvtConstr (ForallC tvs :: [TyVarBndr]
tvs ctxt :: Cxt
ctxt con :: Con
con)
  = do  { LHsQTyVars GhcPs
tvs'      <- [TyVarBndr] -> CvtM (LHsQTyVars GhcPs)
cvtTvs [TyVarBndr]
tvs
        ; LHsContext GhcPs
ctxt'     <- Cxt -> CvtM (LHsContext GhcPs)
cvtContext Cxt
ctxt
        ; (LConDecl GhcPs -> Located (SrcSpanLess (LConDecl GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ con' :: SrcSpanLess (LConDecl GhcPs)
con')  <- Con -> CvtM (LConDecl GhcPs)
cvtConstr Con
con
        ; SrcSpanLess (LConDecl GhcPs) -> CvtM (LConDecl GhcPs)
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM a
returnL (SrcSpanLess (LConDecl GhcPs) -> CvtM (LConDecl GhcPs))
-> SrcSpanLess (LConDecl GhcPs) -> CvtM (LConDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ LHsQTyVars GhcPs
-> LHsContext GhcPs -> ConDecl GhcPs -> ConDecl GhcPs
add_forall LHsQTyVars GhcPs
tvs' LHsContext GhcPs
ctxt' SrcSpanLess (LConDecl GhcPs)
ConDecl GhcPs
con' }
  where
    add_cxt :: a -> Maybe a -> Maybe a
add_cxt lcxt :: a
lcxt         Nothing           = a -> Maybe a
forall a. a -> Maybe a
Just a
lcxt
    add_cxt (a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc cxt1 :: SrcSpanLess a
cxt1) (Just (a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ cxt2 :: SrcSpanLess a
cxt2))
      = a -> Maybe a
forall a. a -> Maybe a
Just (SrcSpan -> SrcSpanLess a -> a
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc ([a]
SrcSpanLess a
cxt1 [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
SrcSpanLess a
cxt2))

    add_forall :: LHsQTyVars GhcPs
-> LHsContext GhcPs -> ConDecl GhcPs -> ConDecl GhcPs
add_forall tvs' :: LHsQTyVars GhcPs
tvs' cxt' :: LHsContext GhcPs
cxt' con :: ConDecl GhcPs
con@(ConDeclGADT { con_qvars :: forall pass. ConDecl pass -> LHsQTyVars pass
con_qvars = LHsQTyVars GhcPs
qvars, con_mb_cxt :: forall pass. ConDecl pass -> Maybe (LHsContext pass)
con_mb_cxt = Maybe (LHsContext GhcPs)
cxt })
      = ConDecl GhcPs
con { con_forall :: Located Bool
con_forall = SrcSpanLess (Located Bool) -> Located Bool
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (Located Bool) -> Located Bool)
-> SrcSpanLess (Located Bool) -> Located Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not ([LHsTyVarBndr GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LHsTyVarBndr GhcPs]
all_tvs)
            , con_qvars :: LHsQTyVars GhcPs
con_qvars  = [LHsTyVarBndr GhcPs] -> LHsQTyVars GhcPs
mkHsQTvs [LHsTyVarBndr GhcPs]
all_tvs
            , con_mb_cxt :: Maybe (LHsContext GhcPs)
con_mb_cxt = LHsContext GhcPs
-> Maybe (LHsContext GhcPs) -> Maybe (LHsContext GhcPs)
forall a a a.
(HasSrcSpan a, HasSrcSpan a, SrcSpanLess a ~ [a],
 SrcSpanLess a ~ [a]) =>
a -> Maybe a -> Maybe a
add_cxt LHsContext GhcPs
cxt' Maybe (LHsContext GhcPs)
cxt }
      where
        all_tvs :: [LHsTyVarBndr GhcPs]
all_tvs = LHsQTyVars GhcPs -> [LHsTyVarBndr GhcPs]
forall pass. LHsQTyVars pass -> [LHsTyVarBndr pass]
hsQTvExplicit LHsQTyVars GhcPs
tvs' [LHsTyVarBndr GhcPs]
-> [LHsTyVarBndr GhcPs] -> [LHsTyVarBndr GhcPs]
forall a. [a] -> [a] -> [a]
++ LHsQTyVars GhcPs -> [LHsTyVarBndr GhcPs]
forall pass. LHsQTyVars pass -> [LHsTyVarBndr pass]
hsQTvExplicit LHsQTyVars GhcPs
qvars

    add_forall tvs' :: LHsQTyVars GhcPs
tvs' cxt' :: LHsContext GhcPs
cxt' con :: ConDecl GhcPs
con@(ConDeclH98 { con_ex_tvs :: forall pass. ConDecl pass -> [LHsTyVarBndr pass]
con_ex_tvs = [LHsTyVarBndr GhcPs]
ex_tvs, con_mb_cxt :: forall pass. ConDecl pass -> Maybe (LHsContext pass)
con_mb_cxt = Maybe (LHsContext GhcPs)
cxt })
      = ConDecl GhcPs
con { con_forall :: Located Bool
con_forall = SrcSpanLess (Located Bool) -> Located Bool
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (Located Bool) -> Located Bool)
-> SrcSpanLess (Located Bool) -> Located Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not ([LHsTyVarBndr GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LHsTyVarBndr GhcPs]
all_tvs)
            , con_ex_tvs :: [LHsTyVarBndr GhcPs]
con_ex_tvs = [LHsTyVarBndr GhcPs]
all_tvs
            , con_mb_cxt :: Maybe (LHsContext GhcPs)
con_mb_cxt = LHsContext GhcPs
-> Maybe (LHsContext GhcPs) -> Maybe (LHsContext GhcPs)
forall a a a.
(HasSrcSpan a, HasSrcSpan a, SrcSpanLess a ~ [a],
 SrcSpanLess a ~ [a]) =>
a -> Maybe a -> Maybe a
add_cxt LHsContext GhcPs
cxt' Maybe (LHsContext GhcPs)
cxt }
      where
        all_tvs :: [LHsTyVarBndr GhcPs]
all_tvs = LHsQTyVars GhcPs -> [LHsTyVarBndr GhcPs]
forall pass. LHsQTyVars pass -> [LHsTyVarBndr pass]
hsQTvExplicit LHsQTyVars GhcPs
tvs' [LHsTyVarBndr GhcPs]
-> [LHsTyVarBndr GhcPs] -> [LHsTyVarBndr GhcPs]
forall a. [a] -> [a] -> [a]
++ [LHsTyVarBndr GhcPs]
ex_tvs

    add_forall _ _ (XConDecl _) = String -> ConDecl GhcPs
forall a. String -> a
panic "cvtConstr"

cvtConstr (GadtC c :: [Name]
c strtys :: [BangType]
strtys ty :: Type
ty)
  = do  { [Located RdrName]
c'      <- (Name -> CvtM (Located RdrName))
-> [Name] -> CvtM [Located RdrName]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> CvtM (Located RdrName)
cNameL [Name]
c
        ; [LHsType GhcPs]
args    <- (BangType -> CvtM (LHsType GhcPs))
-> [BangType] -> CvtM [LHsType GhcPs]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM BangType -> CvtM (LHsType GhcPs)
cvt_arg [BangType]
strtys
        ; (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ ty' :: SrcSpanLess (LHsType GhcPs)
ty') <- Type -> CvtM (LHsType GhcPs)
cvtType Type
ty
        ; LHsType GhcPs
c_ty    <- [LHsType GhcPs] -> HsType GhcPs -> CvtM (LHsType GhcPs)
mk_arr_apps [LHsType GhcPs]
args SrcSpanLess (LHsType GhcPs)
HsType GhcPs
ty'
        ; SrcSpanLess (LConDecl GhcPs) -> CvtM (LConDecl GhcPs)
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM a
returnL (SrcSpanLess (LConDecl GhcPs) -> CvtM (LConDecl GhcPs))
-> SrcSpanLess (LConDecl GhcPs) -> CvtM (LConDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ (ConDecl GhcPs, [AddAnn]) -> SrcSpanLess (LConDecl GhcPs)
forall a b. (a, b) -> a
fst ((ConDecl GhcPs, [AddAnn]) -> SrcSpanLess (LConDecl GhcPs))
-> (ConDecl GhcPs, [AddAnn]) -> SrcSpanLess (LConDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ [Located RdrName] -> LHsType GhcPs -> (ConDecl GhcPs, [AddAnn])
mkGadtDecl [Located RdrName]
c' LHsType GhcPs
c_ty}

cvtConstr (RecGadtC c :: [Name]
c varstrtys :: [VarBangType]
varstrtys ty :: Type
ty)
  = do  { [Located RdrName]
c'       <- (Name -> CvtM (Located RdrName))
-> [Name] -> CvtM [Located RdrName]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> CvtM (Located RdrName)
cNameL [Name]
c
        ; LHsType GhcPs
ty'      <- Type -> CvtM (LHsType GhcPs)
cvtType Type
ty
        ; [LConDeclField GhcPs]
rec_flds <- (VarBangType -> CvtM (LConDeclField GhcPs))
-> [VarBangType] -> CvtM [LConDeclField GhcPs]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM VarBangType -> CvtM (LConDeclField GhcPs)
cvt_id_arg [VarBangType]
varstrtys
        ; let rec_ty :: LHsType GhcPs
rec_ty = SrcSpanLess (LHsType GhcPs) -> LHsType GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (XFunTy GhcPs -> LHsType GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass.
XFunTy pass -> LHsType pass -> LHsType pass -> HsType pass
HsFunTy XFunTy GhcPs
NoExt
noExt
                                           (SrcSpanLess (LHsType GhcPs) -> LHsType GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LHsType GhcPs) -> LHsType GhcPs)
-> SrcSpanLess (LHsType GhcPs) -> LHsType GhcPs
forall a b. (a -> b) -> a -> b
$ XRecTy GhcPs -> [LConDeclField GhcPs] -> HsType GhcPs
forall pass. XRecTy pass -> [LConDeclField pass] -> HsType pass
HsRecTy XRecTy GhcPs
NoExt
noExt [LConDeclField GhcPs]
rec_flds) LHsType GhcPs
ty')
        ; SrcSpanLess (LConDecl GhcPs) -> CvtM (LConDecl GhcPs)
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM a
returnL (SrcSpanLess (LConDecl GhcPs) -> CvtM (LConDecl GhcPs))
-> SrcSpanLess (LConDecl GhcPs) -> CvtM (LConDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ (ConDecl GhcPs, [AddAnn]) -> SrcSpanLess (LConDecl GhcPs)
forall a b. (a, b) -> a
fst ((ConDecl GhcPs, [AddAnn]) -> SrcSpanLess (LConDecl GhcPs))
-> (ConDecl GhcPs, [AddAnn]) -> SrcSpanLess (LConDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ [Located RdrName] -> LHsType GhcPs -> (ConDecl GhcPs, [AddAnn])
mkGadtDecl [Located RdrName]
c' LHsType GhcPs
rec_ty }

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

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

cvt_arg :: (TH.Bang, TH.Type) -> CvtM (LHsType GhcPs)
cvt_arg :: BangType -> CvtM (LHsType GhcPs)
cvt_arg (Bang su :: SourceUnpackedness
su ss :: SourceStrictness
ss, ty :: Type
ty)
  = do { LHsType GhcPs
ty'' <- Type -> CvtM (LHsType GhcPs)
cvtType Type
ty
       ; let ty' :: LHsType GhcPs
ty' = PprPrec -> LHsType GhcPs -> LHsType GhcPs
forall (p :: Pass).
PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)
parenthesizeHsType PprPrec
appPrec LHsType GhcPs
ty''
             su' :: SrcUnpackedness
su' = SourceUnpackedness -> SrcUnpackedness
cvtSrcUnpackedness SourceUnpackedness
su
             ss' :: SrcStrictness
ss' = SourceStrictness -> SrcStrictness
cvtSrcStrictness SourceStrictness
ss
       ; SrcSpanLess (LHsType GhcPs) -> CvtM (LHsType GhcPs)
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM a
returnL (SrcSpanLess (LHsType GhcPs) -> CvtM (LHsType GhcPs))
-> SrcSpanLess (LHsType GhcPs) -> CvtM (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ XBangTy GhcPs -> HsSrcBang -> LHsType GhcPs -> HsType GhcPs
forall pass.
XBangTy pass -> HsSrcBang -> LHsType pass -> HsType pass
HsBangTy XBangTy GhcPs
NoExt
noExt (SourceText -> SrcUnpackedness -> SrcStrictness -> HsSrcBang
HsSrcBang SourceText
NoSourceText SrcUnpackedness
su' SrcStrictness
ss') LHsType GhcPs
ty' }

cvt_id_arg :: (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField GhcPs)
cvt_id_arg :: VarBangType -> CvtM (LConDeclField GhcPs)
cvt_id_arg (i :: Name
i, str :: Bang
str, ty :: Type
ty)
  = do  { (Located RdrName -> Located (SrcSpanLess (Located RdrName))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L li :: SrcSpan
li i' :: SrcSpanLess (Located RdrName)
i') <- Name -> CvtM (Located RdrName)
vNameL Name
i
        ; LHsType GhcPs
ty' <- BangType -> CvtM (LHsType GhcPs)
cvt_arg (Bang
str,Type
ty)
        ; LConDeclField GhcPs -> CvtM (LConDeclField GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LConDeclField GhcPs -> CvtM (LConDeclField GhcPs))
-> LConDeclField GhcPs -> CvtM (LConDeclField GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpanLess (LConDeclField GhcPs) -> LConDeclField GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (ConDeclField :: forall pass.
XConDeclField pass
-> [LFieldOcc pass]
-> LBangType pass
-> Maybe LHsDocString
-> ConDeclField pass
ConDeclField
                          { cd_fld_ext :: XConDeclField GhcPs
cd_fld_ext = XConDeclField GhcPs
NoExt
noExt
                          , cd_fld_names :: [LFieldOcc GhcPs]
cd_fld_names
                              = [SrcSpan -> SrcSpanLess (LFieldOcc GhcPs) -> LFieldOcc GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
li (SrcSpanLess (LFieldOcc GhcPs) -> LFieldOcc GhcPs)
-> SrcSpanLess (LFieldOcc GhcPs) -> LFieldOcc GhcPs
forall a b. (a -> b) -> a -> b
$ XCFieldOcc GhcPs -> Located RdrName -> FieldOcc GhcPs
forall pass. XCFieldOcc pass -> Located RdrName -> FieldOcc pass
FieldOcc XCFieldOcc GhcPs
NoExt
noExt (SrcSpan -> SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
li SrcSpanLess (Located RdrName)
i')]
                          , cd_fld_type :: LHsType GhcPs
cd_fld_type =  LHsType GhcPs
ty'
                          , cd_fld_doc :: Maybe LHsDocString
cd_fld_doc = Maybe LHsDocString
forall a. Maybe a
Nothing}) }

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

cvt_fundep :: FunDep -> CvtM (LHsFunDep GhcPs)
cvt_fundep :: FunDep -> CvtM (LHsFunDep GhcPs)
cvt_fundep (FunDep xs :: [Name]
xs ys :: [Name]
ys) = do { [Located RdrName]
xs' <- (Name -> CvtM (Located RdrName))
-> [Name] -> CvtM [Located RdrName]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> CvtM (Located RdrName)
tNameL [Name]
xs
                               ; [Located RdrName]
ys' <- (Name -> CvtM (Located RdrName))
-> [Name] -> CvtM [Located RdrName]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> CvtM (Located RdrName)
tNameL [Name]
ys
                               ; SrcSpanLess (Located (FunDep (Located RdrName)))
-> CvtM (Located (FunDep (Located RdrName)))
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM a
returnL ([Located RdrName]
xs', [Located RdrName]
ys') }


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

cvtForD :: Foreign -> CvtM (ForeignDecl GhcPs)
cvtForD :: Foreign -> CvtM (ForeignDecl GhcPs)
cvtForD (ImportF callconv :: Callconv
callconv safety :: Safety
safety from :: String
from nm :: Name
nm ty :: Type
ty)
  -- the prim and javascript calling conventions do not support headers
  -- and are inserted verbatim, analogous to mkImport in RdrHsSyn
  | Callconv
callconv Callconv -> Callconv -> Bool
forall a. Eq a => a -> a -> Bool
== Callconv
TH.Prim Bool -> Bool -> Bool
|| Callconv
callconv Callconv -> Callconv -> Bool
forall a. Eq a => a -> a -> Bool
== Callconv
TH.JavaScript
  = ForeignImport -> CvtM (ForeignDecl GhcPs)
mk_imp (Located CCallConv
-> Located Safety
-> Maybe Header
-> CImportSpec
-> Located SourceText
-> ForeignImport
CImport (SrcSpanLess (Located CCallConv) -> Located CCallConv
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (Callconv -> CCallConv
cvt_conv Callconv
callconv)) (SrcSpanLess (Located Safety) -> Located Safety
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (Located Safety)
Safety
safety') Maybe Header
forall a. Maybe a
Nothing
                    (CCallTarget -> CImportSpec
CFunction (SourceText -> CLabelString -> Maybe UnitId -> Bool -> CCallTarget
StaticTarget (String -> SourceText
SourceText String
from)
                                             (String -> CLabelString
mkFastString String
from) Maybe UnitId
forall a. Maybe a
Nothing
                                             Bool
True))
                    (SrcSpanLess (Located SourceText) -> Located SourceText
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (Located SourceText) -> Located SourceText)
-> SrcSpanLess (Located SourceText) -> Located SourceText
forall a b. (a -> b) -> a -> b
$ String -> SourceText
quotedSourceText String
from))
  | Just impspec :: ForeignImport
impspec <- Located CCallConv
-> Located Safety
-> CLabelString
-> String
-> Located SourceText
-> Maybe ForeignImport
parseCImport (SrcSpanLess (Located CCallConv) -> Located CCallConv
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (Callconv -> CCallConv
cvt_conv Callconv
callconv)) (SrcSpanLess (Located Safety) -> Located Safety
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (Located Safety)
Safety
safety')
                                 (String -> CLabelString
mkFastString (Name -> String
TH.nameBase Name
nm))
                                 String
from (SrcSpanLess (Located SourceText) -> Located SourceText
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (Located SourceText) -> Located SourceText)
-> SrcSpanLess (Located SourceText) -> Located SourceText
forall a b. (a -> b) -> a -> b
$ String -> SourceText
quotedSourceText String
from)
  = ForeignImport -> CvtM (ForeignDecl GhcPs)
mk_imp ForeignImport
impspec
  | Bool
otherwise
  = MsgDoc -> CvtM (ForeignDecl GhcPs)
forall a. MsgDoc -> CvtM a
failWith (MsgDoc -> CvtM (ForeignDecl GhcPs))
-> MsgDoc -> CvtM (ForeignDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ String -> MsgDoc
text (String -> String
forall a. Show a => a -> String
show String
from) MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text "is not a valid ccall impent"
  where
    mk_imp :: ForeignImport -> CvtM (ForeignDecl GhcPs)
mk_imp impspec :: ForeignImport
impspec
      = do { Located RdrName
nm' <- Name -> CvtM (Located RdrName)
vNameL Name
nm
           ; LHsType GhcPs
ty' <- Type -> CvtM (LHsType GhcPs)
cvtType Type
ty
           ; ForeignDecl GhcPs -> CvtM (ForeignDecl GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (ForeignImport :: forall pass.
XForeignImport pass
-> Located (IdP pass)
-> LHsSigType pass
-> ForeignImport
-> ForeignDecl pass
ForeignImport { fd_i_ext :: XForeignImport GhcPs
fd_i_ext = XForeignImport GhcPs
NoExt
noExt
                                   , fd_name :: Located (IdP GhcPs)
fd_name = Located RdrName
Located (IdP GhcPs)
nm'
                                   , fd_sig_ty :: LHsSigType GhcPs
fd_sig_ty = LHsType GhcPs -> LHsSigType GhcPs
mkLHsSigType LHsType GhcPs
ty'
                                   , fd_fi :: ForeignImport
fd_fi = ForeignImport
impspec })
           }
    safety' :: Safety
safety' = case Safety
safety of
                     Unsafe     -> Safety
PlayRisky
                     Safe       -> Safety
PlaySafe
                     Interruptible -> Safety
PlayInterruptible

cvtForD (ExportF callconv :: Callconv
callconv as :: String
as nm :: Name
nm ty :: Type
ty)
  = do  { Located RdrName
nm' <- Name -> CvtM (Located RdrName)
vNameL Name
nm
        ; LHsType GhcPs
ty' <- Type -> CvtM (LHsType GhcPs)
cvtType Type
ty
        ; let e :: ForeignExport
e = Located CExportSpec -> Located SourceText -> ForeignExport
CExport (SrcSpanLess (Located CExportSpec) -> Located CExportSpec
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SourceText -> CLabelString -> CCallConv -> CExportSpec
CExportStatic (String -> SourceText
SourceText String
as)
                                                (String -> CLabelString
mkFastString String
as)
                                                (Callconv -> CCallConv
cvt_conv Callconv
callconv)))
                                                (SrcSpanLess (Located SourceText) -> Located SourceText
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (String -> SourceText
SourceText String
as))
        ; ForeignDecl GhcPs -> CvtM (ForeignDecl GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (ForeignDecl GhcPs -> CvtM (ForeignDecl GhcPs))
-> ForeignDecl GhcPs -> CvtM (ForeignDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ ForeignExport :: forall pass.
XForeignExport pass
-> Located (IdP pass)
-> LHsSigType pass
-> ForeignExport
-> ForeignDecl pass
ForeignExport { fd_e_ext :: XForeignExport GhcPs
fd_e_ext = XForeignExport GhcPs
NoExt
noExt
                                 , fd_name :: Located (IdP GhcPs)
fd_name = Located RdrName
Located (IdP GhcPs)
nm'
                                 , fd_sig_ty :: LHsSigType GhcPs
fd_sig_ty = LHsType GhcPs -> LHsSigType GhcPs
mkLHsSigType LHsType GhcPs
ty'
                                 , fd_fe :: ForeignExport
fd_fe = ForeignExport
e } }

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

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

cvtPragmaD :: Pragma -> CvtM (Maybe (LHsDecl GhcPs))
cvtPragmaD :: Pragma -> CvtM (Maybe (LHsDecl GhcPs))
cvtPragmaD (InlineP nm :: Name
nm inline :: Inline
inline rm :: RuleMatch
rm phases :: Phases
phases)
  = do { Located RdrName
nm' <- Name -> CvtM (Located RdrName)
vNameL Name
nm
       ; let dflt :: Activation
dflt = Inline -> Activation
dfltActivation Inline
inline
       ; let src :: Inline -> String
src TH.NoInline  = "{-# NOINLINE"
             src TH.Inline    = "{-# INLINE"
             src TH.Inlinable = "{-# INLINABLE"
       ; let ip :: InlinePragma
ip   = InlinePragma :: SourceText
-> InlineSpec
-> Maybe Int
-> Activation
-> RuleMatchInfo
-> InlinePragma
InlinePragma { inl_src :: SourceText
inl_src    = String -> SourceText
SourceText (String -> SourceText) -> String -> SourceText
forall a b. (a -> b) -> a -> b
$ Inline -> String
src Inline
inline
                                 , inl_inline :: InlineSpec
inl_inline = Inline -> InlineSpec
cvtInline Inline
inline
                                 , inl_rule :: RuleMatchInfo
inl_rule   = RuleMatch -> RuleMatchInfo
cvtRuleMatch RuleMatch
rm
                                 , inl_act :: Activation
inl_act    = Phases -> Activation -> Activation
cvtPhases Phases
phases Activation
dflt
                                 , inl_sat :: Maybe Int
inl_sat    = Maybe Int
forall a. Maybe a
Nothing }
       ; SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs))
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM (Maybe a)
returnJustL (SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs)))
-> SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs))
forall a b. (a -> b) -> a -> b
$ XSigD GhcPs -> Sig GhcPs -> HsDecl GhcPs
forall p. XSigD p -> Sig p -> HsDecl p
Hs.SigD XSigD GhcPs
NoExt
noExt (Sig GhcPs -> SrcSpanLess (LHsDecl GhcPs))
-> Sig GhcPs -> SrcSpanLess (LHsDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ XInlineSig GhcPs
-> Located (IdP GhcPs) -> InlinePragma -> Sig GhcPs
forall pass.
XInlineSig pass -> Located (IdP pass) -> InlinePragma -> Sig pass
InlineSig XInlineSig GhcPs
NoExt
noExt Located RdrName
Located (IdP GhcPs)
nm' InlinePragma
ip }

cvtPragmaD (SpecialiseP nm :: Name
nm ty :: Type
ty inline :: Maybe Inline
inline phases :: Phases
phases)
  = do { Located RdrName
nm' <- Name -> CvtM (Located RdrName)
vNameL Name
nm
       ; LHsType GhcPs
ty' <- Type -> CvtM (LHsType GhcPs)
cvtType Type
ty
       ; let src :: Inline -> String
src TH.NoInline  = "{-# SPECIALISE NOINLINE"
             src TH.Inline    = "{-# SPECIALISE INLINE"
             src TH.Inlinable = "{-# SPECIALISE INLINE"
       ; let (inline' :: InlineSpec
inline', dflt :: Activation
dflt,srcText :: String
srcText) = case Maybe Inline
inline of
               Just inline1 :: Inline
inline1 -> (Inline -> InlineSpec
cvtInline Inline
inline1, Inline -> Activation
dfltActivation Inline
inline1,
                                Inline -> String
src Inline
inline1)
               Nothing      -> (InlineSpec
NoUserInline,   Activation
AlwaysActive,
                                "{-# SPECIALISE")
       ; let ip :: InlinePragma
ip = InlinePragma :: SourceText
-> InlineSpec
-> Maybe Int
-> Activation
-> RuleMatchInfo
-> InlinePragma
InlinePragma { inl_src :: SourceText
inl_src    = String -> SourceText
SourceText String
srcText
                               , inl_inline :: InlineSpec
inl_inline = InlineSpec
inline'
                               , inl_rule :: RuleMatchInfo
inl_rule   = RuleMatchInfo
Hs.FunLike
                               , inl_act :: Activation
inl_act    = Phases -> Activation -> Activation
cvtPhases Phases
phases Activation
dflt
                               , inl_sat :: Maybe Int
inl_sat    = Maybe Int
forall a. Maybe a
Nothing }
       ; SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs))
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM (Maybe a)
returnJustL (SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs)))
-> SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs))
forall a b. (a -> b) -> a -> b
$ XSigD GhcPs -> Sig GhcPs -> HsDecl GhcPs
forall p. XSigD p -> Sig p -> HsDecl p
Hs.SigD XSigD GhcPs
NoExt
noExt (Sig GhcPs -> SrcSpanLess (LHsDecl GhcPs))
-> Sig GhcPs -> SrcSpanLess (LHsDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ XSpecSig GhcPs
-> Located (IdP GhcPs)
-> [LHsSigType GhcPs]
-> InlinePragma
-> Sig GhcPs
forall pass.
XSpecSig pass
-> Located (IdP pass)
-> [LHsSigType pass]
-> InlinePragma
-> Sig pass
SpecSig XSpecSig GhcPs
NoExt
noExt Located RdrName
Located (IdP GhcPs)
nm' [LHsType GhcPs -> LHsSigType GhcPs
mkLHsSigType LHsType GhcPs
ty'] InlinePragma
ip }

cvtPragmaD (SpecialiseInstP ty :: Type
ty)
  = do { LHsType GhcPs
ty' <- Type -> CvtM (LHsType GhcPs)
cvtType Type
ty
       ; SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs))
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM (Maybe a)
returnJustL (SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs)))
-> SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs))
forall a b. (a -> b) -> a -> b
$ XSigD GhcPs -> Sig GhcPs -> HsDecl GhcPs
forall p. XSigD p -> Sig p -> HsDecl p
Hs.SigD XSigD GhcPs
NoExt
noExt (Sig GhcPs -> SrcSpanLess (LHsDecl GhcPs))
-> Sig GhcPs -> SrcSpanLess (LHsDecl GhcPs)
forall a b. (a -> b) -> a -> b
$
         XSpecInstSig GhcPs -> SourceText -> LHsSigType GhcPs -> Sig GhcPs
forall pass.
XSpecInstSig pass -> SourceText -> LHsSigType pass -> Sig pass
SpecInstSig XSpecInstSig GhcPs
NoExt
noExt (String -> SourceText
SourceText "{-# SPECIALISE") (LHsType GhcPs -> LHsSigType GhcPs
mkLHsSigType LHsType GhcPs
ty') }

cvtPragmaD (RuleP nm :: String
nm ty_bndrs :: Maybe [TyVarBndr]
ty_bndrs tm_bndrs :: [RuleBndr]
tm_bndrs lhs :: Exp
lhs rhs :: Exp
rhs phases :: Phases
phases)
  = do { let nm' :: CLabelString
nm' = String -> CLabelString
mkFastString String
nm
       ; let act :: Activation
act = Phases -> Activation -> Activation
cvtPhases Phases
phases Activation
AlwaysActive
       ; Maybe [LHsTyVarBndr GhcPs]
ty_bndrs' <- ([TyVarBndr] -> CvtM [LHsTyVarBndr GhcPs])
-> Maybe [TyVarBndr] -> CvtM (Maybe [LHsTyVarBndr GhcPs])
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((TyVarBndr -> CvtM (LHsTyVarBndr GhcPs))
-> [TyVarBndr] -> CvtM [LHsTyVarBndr GhcPs]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TyVarBndr -> CvtM (LHsTyVarBndr GhcPs)
cvt_tv) Maybe [TyVarBndr]
ty_bndrs
       ; [LRuleBndr GhcPs]
tm_bndrs' <- (RuleBndr -> CvtM (LRuleBndr GhcPs))
-> [RuleBndr] -> CvtM [LRuleBndr GhcPs]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM RuleBndr -> CvtM (LRuleBndr GhcPs)
cvtRuleBndr [RuleBndr]
tm_bndrs
       ; LHsExpr GhcPs
lhs'   <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
lhs
       ; LHsExpr GhcPs
rhs'   <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
rhs
       ; SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs))
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM (Maybe a)
returnJustL (SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs)))
-> SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs))
forall a b. (a -> b) -> a -> b
$ XRuleD GhcPs -> RuleDecls GhcPs -> HsDecl GhcPs
forall p. XRuleD p -> RuleDecls p -> HsDecl p
Hs.RuleD XRuleD GhcPs
NoExt
noExt
            (RuleDecls GhcPs -> SrcSpanLess (LHsDecl GhcPs))
-> RuleDecls GhcPs -> SrcSpanLess (LHsDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ HsRules :: forall pass.
XCRuleDecls pass
-> SourceText -> [LRuleDecl pass] -> RuleDecls pass
HsRules { rds_ext :: XCRuleDecls GhcPs
rds_ext = XCRuleDecls GhcPs
NoExt
noExt
                      , rds_src :: SourceText
rds_src = String -> SourceText
SourceText "{-# RULES"
                      , rds_rules :: [LRuleDecl GhcPs]
rds_rules = [SrcSpanLess (LRuleDecl GhcPs) -> LRuleDecl GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LRuleDecl GhcPs) -> LRuleDecl GhcPs)
-> SrcSpanLess (LRuleDecl GhcPs) -> LRuleDecl GhcPs
forall a b. (a -> b) -> a -> b
$
                          HsRule :: forall pass.
XHsRule pass
-> Located (SourceText, CLabelString)
-> Activation
-> Maybe [LHsTyVarBndr (NoGhcTc pass)]
-> [LRuleBndr pass]
-> Located (HsExpr pass)
-> Located (HsExpr pass)
-> RuleDecl pass
HsRule { rd_ext :: XHsRule GhcPs
rd_ext  = XHsRule GhcPs
NoExt
noExt
                                 , rd_name :: Located (SourceText, CLabelString)
rd_name = (SrcSpanLess (Located (SourceText, CLabelString))
-> Located (SourceText, CLabelString)
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (String -> SourceText
quotedSourceText String
nm,CLabelString
nm'))
                                 , rd_act :: Activation
rd_act  = Activation
act
                                 , rd_tyvs :: Maybe [LHsTyVarBndr (NoGhcTc GhcPs)]
rd_tyvs = Maybe [LHsTyVarBndr (NoGhcTc GhcPs)]
Maybe [LHsTyVarBndr GhcPs]
ty_bndrs'
                                 , rd_tmvs :: [LRuleBndr GhcPs]
rd_tmvs = [LRuleBndr GhcPs]
tm_bndrs'
                                 , rd_lhs :: LHsExpr GhcPs
rd_lhs  = LHsExpr GhcPs
lhs'
                                 , rd_rhs :: LHsExpr GhcPs
rd_rhs  = LHsExpr GhcPs
rhs' }] }

          }

cvtPragmaD (AnnP target :: AnnTarget
target exp :: Exp
exp)
  = do { LHsExpr GhcPs
exp' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
exp
       ; AnnProvenance RdrName
target' <- case AnnTarget
target of
         ModuleAnnotation  -> AnnProvenance RdrName -> CvtM (AnnProvenance RdrName)
forall (m :: * -> *) a. Monad m => a -> m a
return AnnProvenance RdrName
forall name. AnnProvenance name
ModuleAnnProvenance
         TypeAnnotation n :: Name
n  -> do
           RdrName
n' <- Name -> CvtM RdrName
tconName Name
n
           AnnProvenance RdrName -> CvtM (AnnProvenance RdrName)
forall (m :: * -> *) a. Monad m => a -> m a
return (Located RdrName -> AnnProvenance RdrName
forall name. Located name -> AnnProvenance name
TypeAnnProvenance  (SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (Located RdrName)
RdrName
n'))
         ValueAnnotation n :: Name
n -> do
           RdrName
n' <- Name -> CvtM RdrName
vcName Name
n
           AnnProvenance RdrName -> CvtM (AnnProvenance RdrName)
forall (m :: * -> *) a. Monad m => a -> m a
return (Located RdrName -> AnnProvenance RdrName
forall name. Located name -> AnnProvenance name
ValueAnnProvenance (SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (Located RdrName)
RdrName
n'))
       ; SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs))
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM (Maybe a)
returnJustL (SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs)))
-> SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs))
forall a b. (a -> b) -> a -> b
$ XAnnD GhcPs -> AnnDecl GhcPs -> HsDecl GhcPs
forall p. XAnnD p -> AnnDecl p -> HsDecl p
Hs.AnnD XAnnD GhcPs
NoExt
noExt
                     (AnnDecl GhcPs -> SrcSpanLess (LHsDecl GhcPs))
-> AnnDecl GhcPs -> SrcSpanLess (LHsDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ XHsAnnotation GhcPs
-> SourceText
-> AnnProvenance (IdP GhcPs)
-> LHsExpr GhcPs
-> AnnDecl GhcPs
forall pass.
XHsAnnotation pass
-> SourceText
-> AnnProvenance (IdP pass)
-> Located (HsExpr pass)
-> AnnDecl pass
HsAnnotation XHsAnnotation GhcPs
NoExt
noExt (String -> SourceText
SourceText "{-# ANN") AnnProvenance RdrName
AnnProvenance (IdP GhcPs)
target' LHsExpr GhcPs
exp'
       }

cvtPragmaD (LineP line :: Int
line file :: String
file)
  = do { SrcSpan -> CvtM ()
setL (SrcLoc -> SrcSpan
srcLocSpan (CLabelString -> Int -> Int -> SrcLoc
mkSrcLoc (String -> CLabelString
fsLit String
file) Int
line 1))
       ; Maybe (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (LHsDecl GhcPs)
forall a. Maybe a
Nothing
       }
cvtPragmaD (CompleteP cls :: [Name]
cls mty :: Maybe Name
mty)
  = do { Located [Located RdrName]
cls' <- [Located RdrName] -> Located [Located RdrName]
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc ([Located RdrName] -> Located [Located RdrName])
-> CvtM [Located RdrName] -> CvtM (Located [Located RdrName])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name -> CvtM (Located RdrName))
-> [Name] -> CvtM [Located RdrName]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> CvtM (Located RdrName)
cNameL [Name]
cls
       ; Maybe (Located RdrName)
mty'  <- (Name -> CvtM (Located RdrName))
-> Maybe Name -> CvtM (Maybe (Located RdrName))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Name -> CvtM (Located RdrName)
tconNameL Maybe Name
mty
       ; SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs))
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM (Maybe a)
returnJustL (SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs)))
-> SrcSpanLess (LHsDecl GhcPs) -> CvtM (Maybe (LHsDecl GhcPs))
forall a b. (a -> b) -> a -> b
$ XSigD GhcPs -> Sig GhcPs -> HsDecl GhcPs
forall p. XSigD p -> Sig p -> HsDecl p
Hs.SigD XSigD GhcPs
NoExt
noExt
                   (Sig GhcPs -> SrcSpanLess (LHsDecl GhcPs))
-> Sig GhcPs -> SrcSpanLess (LHsDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ XCompleteMatchSig GhcPs
-> SourceText
-> Located [Located (IdP GhcPs)]
-> Maybe (Located (IdP GhcPs))
-> Sig GhcPs
forall pass.
XCompleteMatchSig pass
-> SourceText
-> Located [Located (IdP pass)]
-> Maybe (Located (IdP pass))
-> Sig pass
CompleteMatchSig XCompleteMatchSig GhcPs
NoExt
noExt SourceText
NoSourceText Located [Located RdrName]
Located [Located (IdP GhcPs)]
cls' Maybe (Located RdrName)
Maybe (Located (IdP GhcPs))
mty' }

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

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

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

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

cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.LRuleBndr GhcPs)
cvtRuleBndr :: RuleBndr -> CvtM (LRuleBndr GhcPs)
cvtRuleBndr (RuleVar n :: Name
n)
  = do { Located RdrName
n' <- Name -> CvtM (Located RdrName)
vNameL Name
n
       ; LRuleBndr GhcPs -> CvtM (LRuleBndr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LRuleBndr GhcPs -> CvtM (LRuleBndr GhcPs))
-> LRuleBndr GhcPs -> CvtM (LRuleBndr GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpanLess (LRuleBndr GhcPs) -> LRuleBndr GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LRuleBndr GhcPs) -> LRuleBndr GhcPs)
-> SrcSpanLess (LRuleBndr GhcPs) -> LRuleBndr GhcPs
forall a b. (a -> b) -> a -> b
$ XCRuleBndr GhcPs -> Located (IdP GhcPs) -> RuleBndr GhcPs
forall pass. XCRuleBndr pass -> Located (IdP pass) -> RuleBndr pass
Hs.RuleBndr XCRuleBndr GhcPs
NoExt
noExt Located RdrName
Located (IdP GhcPs)
n' }
cvtRuleBndr (TypedRuleVar n :: Name
n ty :: Type
ty)
  = do { Located RdrName
n'  <- Name -> CvtM (Located RdrName)
vNameL Name
n
       ; LHsType GhcPs
ty' <- Type -> CvtM (LHsType GhcPs)
cvtType Type
ty
       ; LRuleBndr GhcPs -> CvtM (LRuleBndr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LRuleBndr GhcPs -> CvtM (LRuleBndr GhcPs))
-> LRuleBndr GhcPs -> CvtM (LRuleBndr GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpanLess (LRuleBndr GhcPs) -> LRuleBndr GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LRuleBndr GhcPs) -> LRuleBndr GhcPs)
-> SrcSpanLess (LRuleBndr GhcPs) -> LRuleBndr GhcPs
forall a b. (a -> b) -> a -> b
$ XRuleBndrSig GhcPs
-> Located (IdP GhcPs) -> LHsSigWcType GhcPs -> RuleBndr GhcPs
forall pass.
XRuleBndrSig pass
-> Located (IdP pass) -> LHsSigWcType pass -> RuleBndr pass
Hs.RuleBndrSig XRuleBndrSig GhcPs
NoExt
noExt Located RdrName
Located (IdP GhcPs)
n' (LHsSigWcType GhcPs -> SrcSpanLess (LRuleBndr GhcPs))
-> LHsSigWcType GhcPs -> SrcSpanLess (LRuleBndr GhcPs)
forall a b. (a -> b) -> a -> b
$ LHsType GhcPs -> LHsSigWcType GhcPs
mkLHsSigWcType LHsType GhcPs
ty' }

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

cvtLocalDecs :: MsgDoc -> [TH.Dec] -> CvtM (HsLocalBinds GhcPs)
cvtLocalDecs :: MsgDoc -> [Dec] -> CvtM (HsLocalBinds GhcPs)
cvtLocalDecs doc :: MsgDoc
doc ds :: [Dec]
ds
  = case (Dec -> Either (String, Exp) Dec)
-> [Dec] -> ([(String, Exp)], [Dec])
forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
partitionWith Dec -> Either (String, Exp) Dec
is_ip_bind [Dec]
ds of
      ([], []) -> HsLocalBinds GhcPs -> CvtM (HsLocalBinds GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (XEmptyLocalBinds GhcPs GhcPs -> HsLocalBinds GhcPs
forall idL idR. XEmptyLocalBinds idL idR -> HsLocalBindsLR idL idR
EmptyLocalBinds XEmptyLocalBinds GhcPs GhcPs
NoExt
noExt)
      ([], _) -> do
        [LHsDecl GhcPs]
ds' <- [Dec] -> CvtM [LHsDecl GhcPs]
cvtDecs [Dec]
ds
        let (binds :: [LHsBind GhcPs]
binds, prob_sigs :: [LHsDecl GhcPs]
prob_sigs) = (LHsDecl GhcPs -> Either (LHsBind GhcPs) (LHsDecl GhcPs))
-> [LHsDecl GhcPs] -> ([LHsBind GhcPs], [LHsDecl GhcPs])
forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
partitionWith LHsDecl GhcPs -> Either (LHsBind GhcPs) (LHsDecl GhcPs)
is_bind [LHsDecl GhcPs]
ds'
        let (sigs :: [LSig GhcPs]
sigs, bads :: [LHsDecl GhcPs]
bads) = (LHsDecl GhcPs -> Either (LSig GhcPs) (LHsDecl GhcPs))
-> [LHsDecl GhcPs] -> ([LSig GhcPs], [LHsDecl GhcPs])
forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
partitionWith LHsDecl GhcPs -> Either (LSig GhcPs) (LHsDecl GhcPs)
is_sig [LHsDecl GhcPs]
prob_sigs
        Bool -> CvtM () -> CvtM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([LHsDecl GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LHsDecl GhcPs]
bads) (MsgDoc -> CvtM ()
forall a. MsgDoc -> CvtM a
failWith (MsgDoc -> [LHsDecl GhcPs] -> MsgDoc
forall a. Outputable a => MsgDoc -> [a] -> MsgDoc
mkBadDecMsg MsgDoc
doc [LHsDecl GhcPs]
bads))
        HsLocalBinds GhcPs -> CvtM (HsLocalBinds GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (XHsValBinds GhcPs GhcPs
-> HsValBindsLR GhcPs GhcPs -> HsLocalBinds GhcPs
forall idL idR.
XHsValBinds idL idR
-> HsValBindsLR idL idR -> HsLocalBindsLR idL idR
HsValBinds XHsValBinds GhcPs GhcPs
NoExt
noExt (XValBinds GhcPs GhcPs
-> LHsBinds GhcPs -> [LSig GhcPs] -> HsValBindsLR GhcPs GhcPs
forall idL idR.
XValBinds idL idR
-> LHsBindsLR idL idR -> [LSig idR] -> HsValBindsLR idL idR
ValBinds XValBinds GhcPs GhcPs
NoExt
noExt ([LHsBind GhcPs] -> LHsBinds GhcPs
forall a. [a] -> Bag a
listToBag [LHsBind GhcPs]
binds) [LSig GhcPs]
sigs))
      (ip_binds :: [(String, Exp)]
ip_binds, []) -> do
        [LIPBind GhcPs]
binds <- ((String, Exp) -> CvtM (LIPBind GhcPs))
-> [(String, Exp)] -> CvtM [LIPBind GhcPs]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((String -> Exp -> CvtM (LIPBind GhcPs))
-> (String, Exp) -> CvtM (LIPBind GhcPs)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> Exp -> CvtM (LIPBind GhcPs)
cvtImplicitParamBind) [(String, Exp)]
ip_binds
        HsLocalBinds GhcPs -> CvtM (HsLocalBinds GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (XHsIPBinds GhcPs GhcPs -> HsIPBinds GhcPs -> HsLocalBinds GhcPs
forall idL idR.
XHsIPBinds idL idR -> HsIPBinds idR -> HsLocalBindsLR idL idR
HsIPBinds XHsIPBinds GhcPs GhcPs
NoExt
noExt (XIPBinds GhcPs -> [LIPBind GhcPs] -> HsIPBinds GhcPs
forall id. XIPBinds id -> [LIPBind id] -> HsIPBinds id
IPBinds XIPBinds GhcPs
NoExt
noExt [LIPBind GhcPs]
binds))
      ((_:_), (_:_)) ->
        MsgDoc -> CvtM (HsLocalBinds GhcPs)
forall a. MsgDoc -> CvtM a
failWith (String -> MsgDoc
text "Implicit parameters mixed with other bindings")

cvtClause :: HsMatchContext RdrName
          -> TH.Clause -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))
cvtClause :: HsMatchContext RdrName
-> Clause -> CvtM (LMatch GhcPs (LHsExpr GhcPs))
cvtClause ctxt :: HsMatchContext RdrName
ctxt (Clause ps :: [Pat]
ps body :: Body
body wheres :: [Dec]
wheres)
  = do  { [LPat GhcPs]
ps' <- [Pat] -> CvtM [LPat GhcPs]
cvtPats [Pat]
ps
        ; let pps :: [LPat GhcPs]
pps = (LPat GhcPs -> LPat GhcPs) -> [LPat GhcPs] -> [LPat GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map (PprPrec -> LPat GhcPs -> LPat GhcPs
forall (p :: Pass). PprPrec -> LPat (GhcPass p) -> LPat (GhcPass p)
parenthesizePat PprPrec
appPrec) [LPat GhcPs]
ps'
        ; [LGRHS GhcPs (LHsExpr GhcPs)]
g'  <- Body -> CvtM [LGRHS GhcPs (LHsExpr GhcPs)]
cvtGuard Body
body
        ; HsLocalBinds GhcPs
ds' <- MsgDoc -> [Dec] -> CvtM (HsLocalBinds GhcPs)
cvtLocalDecs (String -> MsgDoc
text "a where clause") [Dec]
wheres
        ; SrcSpanLess (LMatch GhcPs (LHsExpr GhcPs))
-> CvtM (LMatch GhcPs (LHsExpr GhcPs))
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM a
returnL (SrcSpanLess (LMatch GhcPs (LHsExpr GhcPs))
 -> CvtM (LMatch GhcPs (LHsExpr GhcPs)))
-> SrcSpanLess (LMatch GhcPs (LHsExpr GhcPs))
-> CvtM (LMatch GhcPs (LHsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ XCMatch GhcPs (LHsExpr GhcPs)
-> HsMatchContext (NameOrRdrName (IdP GhcPs))
-> [LPat GhcPs]
-> GRHSs GhcPs (LHsExpr GhcPs)
-> Match GhcPs (LHsExpr GhcPs)
forall p body.
XCMatch p body
-> HsMatchContext (NameOrRdrName (IdP p))
-> [LPat p]
-> GRHSs p body
-> Match p body
Hs.Match XCMatch GhcPs (LHsExpr GhcPs)
NoExt
noExt HsMatchContext RdrName
HsMatchContext (NameOrRdrName (IdP GhcPs))
ctxt [LPat GhcPs]
pps (XCGRHSs GhcPs (LHsExpr GhcPs)
-> [LGRHS GhcPs (LHsExpr GhcPs)]
-> LHsLocalBinds GhcPs
-> GRHSs GhcPs (LHsExpr GhcPs)
forall p body.
XCGRHSs p body -> [LGRHS p body] -> LHsLocalBinds p -> GRHSs p body
GRHSs XCGRHSs GhcPs (LHsExpr GhcPs)
NoExt
noExt [LGRHS GhcPs (LHsExpr GhcPs)]
g' (SrcSpanLess (LHsLocalBinds GhcPs) -> LHsLocalBinds GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (LHsLocalBinds GhcPs)
HsLocalBinds GhcPs
ds')) }

cvtImplicitParamBind :: String -> TH.Exp -> CvtM (LIPBind GhcPs)
cvtImplicitParamBind :: String -> Exp -> CvtM (LIPBind GhcPs)
cvtImplicitParamBind n :: String
n e :: Exp
e = do
    Located HsIPName
n' <- CvtM (SrcSpanLess (Located HsIPName)) -> CvtM (Located HsIPName)
forall a. HasSrcSpan a => CvtM (SrcSpanLess a) -> CvtM a
wrapL (String -> CvtM HsIPName
ipName String
n)
    LHsExpr GhcPs
e' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
e
    SrcSpanLess (LIPBind GhcPs) -> CvtM (LIPBind GhcPs)
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM a
returnL (XCIPBind GhcPs
-> Either (Located HsIPName) (IdP GhcPs)
-> LHsExpr GhcPs
-> IPBind GhcPs
forall id.
XCIPBind id
-> Either (Located HsIPName) (IdP id) -> LHsExpr id -> IPBind id
IPBind XCIPBind GhcPs
NoExt
noExt (Located HsIPName -> Either (Located HsIPName) RdrName
forall a b. a -> Either a b
Left Located HsIPName
n') LHsExpr GhcPs
e')

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

cvtl :: TH.Exp -> CvtM (LHsExpr GhcPs)
cvtl :: Exp -> CvtM (LHsExpr GhcPs)
cvtl e :: Exp
e = CvtM (SrcSpanLess (LHsExpr GhcPs)) -> CvtM (LHsExpr GhcPs)
forall a. HasSrcSpan a => CvtM (SrcSpanLess a) -> CvtM a
wrapL (Exp -> CvtM (HsExpr GhcPs)
cvt Exp
e)
  where
    cvt :: Exp -> CvtM (HsExpr GhcPs)
cvt (VarE s :: Name
s)        = do { RdrName
s' <- Name -> CvtM RdrName
vName Name
s; HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcPs -> CvtM (HsExpr GhcPs))
-> HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XVar GhcPs -> Located (IdP GhcPs) -> HsExpr GhcPs
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar XVar GhcPs
NoExt
noExt (SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (Located RdrName)
RdrName
s') }
    cvt (ConE s :: Name
s)        = do { RdrName
s' <- Name -> CvtM RdrName
cName Name
s; HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcPs -> CvtM (HsExpr GhcPs))
-> HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XVar GhcPs -> Located (IdP GhcPs) -> HsExpr GhcPs
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar XVar GhcPs
NoExt
noExt (SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (Located RdrName)
RdrName
s') }
    cvt (LitE l :: Lit
l)
      | Lit -> Bool
overloadedLit Lit
l = (Lit -> CvtM (HsOverLit GhcPs))
-> (HsOverLit GhcPs -> HsExpr GhcPs)
-> (HsOverLit GhcPs -> Bool)
-> CvtM (HsExpr GhcPs)
forall (l :: * -> *).
(Lit -> CvtM (l GhcPs))
-> (l GhcPs -> HsExpr GhcPs)
-> (l GhcPs -> Bool)
-> CvtM (HsExpr GhcPs)
go Lit -> CvtM (HsOverLit GhcPs)
cvtOverLit (XOverLitE GhcPs -> HsOverLit GhcPs -> HsExpr GhcPs
forall p. XOverLitE p -> HsOverLit p -> HsExpr p
HsOverLit XOverLitE GhcPs
NoExt
noExt)
                             (PprPrec -> HsOverLit GhcPs -> Bool
forall x. PprPrec -> HsOverLit x -> Bool
hsOverLitNeedsParens PprPrec
appPrec)
      | Bool
otherwise       = (Lit -> CvtM (HsLit GhcPs))
-> (HsLit GhcPs -> HsExpr GhcPs)
-> (HsLit GhcPs -> Bool)
-> CvtM (HsExpr GhcPs)
forall (l :: * -> *).
(Lit -> CvtM (l GhcPs))
-> (l GhcPs -> HsExpr GhcPs)
-> (l GhcPs -> Bool)
-> CvtM (HsExpr GhcPs)
go Lit -> CvtM (HsLit GhcPs)
cvtLit (XLitE GhcPs -> HsLit GhcPs -> HsExpr GhcPs
forall p. XLitE p -> HsLit p -> HsExpr p
HsLit XLitE GhcPs
NoExt
noExt)
                             (PprPrec -> HsLit GhcPs -> Bool
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 :: (Lit -> CvtM (l GhcPs))
-> (l GhcPs -> HsExpr GhcPs)
-> (l GhcPs -> Bool)
-> CvtM (HsExpr GhcPs)
go cvt_lit :: Lit -> CvtM (l GhcPs)
cvt_lit mk_expr :: l GhcPs -> HsExpr GhcPs
mk_expr is_compound_lit :: l GhcPs -> Bool
is_compound_lit = do
          l GhcPs
l' <- Lit -> CvtM (l GhcPs)
cvt_lit Lit
l
          let e' :: HsExpr GhcPs
e' = l GhcPs -> HsExpr GhcPs
mk_expr l GhcPs
l'
          HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcPs -> CvtM (HsExpr GhcPs))
-> HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ if l GhcPs -> Bool
is_compound_lit l GhcPs
l' then XPar GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar XPar GhcPs
NoExt
noExt (SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (LHsExpr GhcPs)
HsExpr GhcPs
e') else HsExpr GhcPs
e'
    cvt (AppE x :: Exp
x@(LamE _ _) y :: Exp
y) = do { LHsExpr GhcPs
x' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
x; LHsExpr GhcPs
y' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
y
                                   ; HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcPs -> CvtM (HsExpr GhcPs))
-> HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XApp GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp XApp GhcPs
NoExt
noExt (LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkLHsPar LHsExpr GhcPs
x')
                                                          (LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkLHsPar LHsExpr GhcPs
y')}
    cvt (AppE x :: Exp
x y :: Exp
y)            = do { LHsExpr GhcPs
x' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
x; LHsExpr GhcPs
y' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
y
                                   ; HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcPs -> CvtM (HsExpr GhcPs))
-> HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XApp GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp XApp GhcPs
NoExt
noExt (LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkLHsPar LHsExpr GhcPs
x')
                                                          (LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkLHsPar LHsExpr GhcPs
y')}
    cvt (AppTypeE e :: Exp
e t :: Type
t) = do { LHsExpr GhcPs
e' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
e
                            ; LHsType GhcPs
t' <- Type -> CvtM (LHsType GhcPs)
cvtType Type
t
                            ; let tp :: LHsType GhcPs
tp = PprPrec -> LHsType GhcPs -> LHsType GhcPs
forall (p :: Pass).
PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)
parenthesizeHsType PprPrec
appPrec LHsType GhcPs
t'
                            ; HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcPs -> CvtM (HsExpr GhcPs))
-> HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XAppTypeE GhcPs
-> LHsExpr GhcPs -> LHsWcType (NoGhcTc GhcPs) -> HsExpr GhcPs
forall p.
XAppTypeE p -> LHsExpr p -> LHsWcType (NoGhcTc p) -> HsExpr p
HsAppType XAppTypeE GhcPs
NoExt
noExt LHsExpr GhcPs
e'
                                     (LHsWcType (NoGhcTc GhcPs) -> HsExpr GhcPs)
-> LHsWcType (NoGhcTc GhcPs) -> HsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ LHsType GhcPs -> HsWildCardBndrs GhcPs (LHsType GhcPs)
forall thing. thing -> HsWildCardBndrs GhcPs thing
mkHsWildCardBndrs LHsType GhcPs
tp }
    cvt (LamE [] e :: Exp
e)    = Exp -> CvtM (HsExpr GhcPs)
cvt Exp
e -- Degenerate case. We convert the body as its
                               -- own expression to avoid pretty-printing
                               -- oddities that can result from zero-argument
                               -- lambda expressions. See #13856.
    cvt (LamE ps :: [Pat]
ps e :: Exp
e)    = do { [LPat GhcPs]
ps' <- [Pat] -> CvtM [LPat GhcPs]
cvtPats [Pat]
ps; LHsExpr GhcPs
e' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
e
                            ; let pats :: [LPat GhcPs]
pats = (LPat GhcPs -> LPat GhcPs) -> [LPat GhcPs] -> [LPat GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map (PprPrec -> LPat GhcPs -> LPat GhcPs
forall (p :: Pass). PprPrec -> LPat (GhcPass p) -> LPat (GhcPass p)
parenthesizePat PprPrec
appPrec) [LPat GhcPs]
ps'
                            ; HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcPs -> CvtM (HsExpr GhcPs))
-> HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XLam GhcPs -> MatchGroup GhcPs (LHsExpr GhcPs) -> HsExpr GhcPs
forall p. XLam p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLam XLam GhcPs
NoExt
noExt (Origin
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> MatchGroup GhcPs (LHsExpr GhcPs)
forall name (body :: * -> *).
(XMG name (Located (body name)) ~ NoExt) =>
Origin
-> [LMatch name (Located (body name))]
-> MatchGroup name (Located (body name))
mkMatchGroup Origin
FromSource
                                             [HsMatchContext (NameOrRdrName (IdP GhcPs))
-> [LPat GhcPs] -> LHsExpr GhcPs -> LMatch GhcPs (LHsExpr GhcPs)
forall (p :: Pass) (body :: * -> *).
HsMatchContext (NameOrRdrName (IdP (GhcPass p)))
-> [LPat (GhcPass p)]
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkSimpleMatch HsMatchContext (NameOrRdrName (IdP GhcPs))
forall id. HsMatchContext id
LambdaExpr
                                             [LPat GhcPs]
pats LHsExpr GhcPs
e'])}
    cvt (LamCaseE ms :: [Match]
ms)  = do { [LMatch GhcPs (LHsExpr GhcPs)]
ms' <- (Match -> CvtM (LMatch GhcPs (LHsExpr GhcPs)))
-> [Match] -> CvtM [LMatch GhcPs (LHsExpr GhcPs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (HsMatchContext RdrName
-> Match -> CvtM (LMatch GhcPs (LHsExpr GhcPs))
cvtMatch HsMatchContext RdrName
forall id. HsMatchContext id
CaseAlt) [Match]
ms
                            ; HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcPs -> CvtM (HsExpr GhcPs))
-> HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XLamCase GhcPs -> MatchGroup GhcPs (LHsExpr GhcPs) -> HsExpr GhcPs
forall p. XLamCase p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLamCase XLamCase GhcPs
NoExt
noExt
                                                   (Origin
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> MatchGroup GhcPs (LHsExpr GhcPs)
forall name (body :: * -> *).
(XMG name (Located (body name)) ~ NoExt) =>
Origin
-> [LMatch name (Located (body name))]
-> MatchGroup name (Located (body name))
mkMatchGroup Origin
FromSource [LMatch GhcPs (LHsExpr GhcPs)]
ms')
                            }
    cvt (TupE [e :: Exp
e])     = do { LHsExpr GhcPs
e' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
e; HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcPs -> CvtM (HsExpr GhcPs))
-> HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XPar GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar XPar GhcPs
NoExt
noExt LHsExpr GhcPs
e' }
                                 -- Note [Dropping constructors]
                                 -- Singleton tuples treated like nothing (just parens)
    cvt (TupE es :: [Exp]
es)      = do { [LHsExpr GhcPs]
es' <- (Exp -> CvtM (LHsExpr GhcPs)) -> [Exp] -> CvtM [LHsExpr GhcPs]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Exp -> CvtM (LHsExpr GhcPs)
cvtl [Exp]
es
                            ; HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcPs -> CvtM (HsExpr GhcPs))
-> HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XExplicitTuple GhcPs -> [LHsTupArg GhcPs] -> Boxity -> HsExpr GhcPs
forall p. XExplicitTuple p -> [LHsTupArg p] -> Boxity -> HsExpr p
ExplicitTuple XExplicitTuple GhcPs
NoExt
noExt
                                             ((LHsExpr GhcPs -> LHsTupArg GhcPs)
-> [LHsExpr GhcPs] -> [LHsTupArg GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map (HsTupArg GhcPs -> LHsTupArg GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (HsTupArg GhcPs -> LHsTupArg GhcPs)
-> (LHsExpr GhcPs -> HsTupArg GhcPs)
-> LHsExpr GhcPs
-> LHsTupArg GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (XPresent GhcPs -> LHsExpr GhcPs -> HsTupArg GhcPs
forall id. XPresent id -> LHsExpr id -> HsTupArg id
Present XPresent GhcPs
NoExt
noExt)) [LHsExpr GhcPs]
es')
                                                                         Boxity
Boxed }
    cvt (UnboxedTupE es :: [Exp]
es)      = do { [LHsExpr GhcPs]
es' <- (Exp -> CvtM (LHsExpr GhcPs)) -> [Exp] -> CvtM [LHsExpr GhcPs]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Exp -> CvtM (LHsExpr GhcPs)
cvtl [Exp]
es
                                   ; HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcPs -> CvtM (HsExpr GhcPs))
-> HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XExplicitTuple GhcPs -> [LHsTupArg GhcPs] -> Boxity -> HsExpr GhcPs
forall p. XExplicitTuple p -> [LHsTupArg p] -> Boxity -> HsExpr p
ExplicitTuple XExplicitTuple GhcPs
NoExt
noExt
                                           ((LHsExpr GhcPs -> LHsTupArg GhcPs)
-> [LHsExpr GhcPs] -> [LHsTupArg GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map (HsTupArg GhcPs -> LHsTupArg GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (HsTupArg GhcPs -> LHsTupArg GhcPs)
-> (LHsExpr GhcPs -> HsTupArg GhcPs)
-> LHsExpr GhcPs
-> LHsTupArg GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (XPresent GhcPs -> LHsExpr GhcPs -> HsTupArg GhcPs
forall id. XPresent id -> LHsExpr id -> HsTupArg id
Present XPresent GhcPs
NoExt
noExt)) [LHsExpr GhcPs]
es')
                                                                       Boxity
Unboxed }
    cvt (UnboxedSumE e :: Exp
e alt :: Int
alt arity :: Int
arity) = do { LHsExpr GhcPs
e' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
e
                                       ; Int -> Int -> CvtM ()
unboxedSumChecks Int
alt Int
arity
                                       ; HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcPs -> CvtM (HsExpr GhcPs))
-> HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XExplicitSum GhcPs -> Int -> Int -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XExplicitSum p -> Int -> Int -> LHsExpr p -> HsExpr p
ExplicitSum XExplicitSum GhcPs
NoExt
noExt
                                                                   Int
alt Int
arity LHsExpr GhcPs
e'}
    cvt (CondE x :: Exp
x y :: Exp
y z :: Exp
z)  = do { LHsExpr GhcPs
x' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
x; LHsExpr GhcPs
y' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
y; LHsExpr GhcPs
z' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
z;
                            ; HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcPs -> CvtM (HsExpr GhcPs))
-> HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XIf GhcPs
-> Maybe (SyntaxExpr GhcPs)
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> HsExpr GhcPs
forall p.
XIf p
-> Maybe (SyntaxExpr p)
-> LHsExpr p
-> LHsExpr p
-> LHsExpr p
-> HsExpr p
HsIf XIf GhcPs
NoExt
noExt (SyntaxExpr GhcPs -> Maybe (SyntaxExpr GhcPs)
forall a. a -> Maybe a
Just SyntaxExpr GhcPs
forall (p :: Pass). SyntaxExpr (GhcPass p)
noSyntaxExpr) LHsExpr GhcPs
x' LHsExpr GhcPs
y' LHsExpr GhcPs
z' }
    cvt (MultiIfE alts :: [(Guard, Exp)]
alts)
      | [(Guard, Exp)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Guard, Exp)]
alts      = MsgDoc -> CvtM (HsExpr GhcPs)
forall a. MsgDoc -> CvtM a
failWith (String -> MsgDoc
text "Multi-way if-expression with no alternatives")
      | Bool
otherwise      = do { [LGRHS GhcPs (LHsExpr GhcPs)]
alts' <- ((Guard, Exp) -> CvtM (LGRHS GhcPs (LHsExpr GhcPs)))
-> [(Guard, Exp)] -> CvtM [LGRHS GhcPs (LHsExpr GhcPs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Guard, Exp) -> CvtM (LGRHS GhcPs (LHsExpr GhcPs))
cvtpair [(Guard, Exp)]
alts
                            ; HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcPs -> CvtM (HsExpr GhcPs))
-> HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XMultiIf GhcPs -> [LGRHS GhcPs (LHsExpr GhcPs)] -> HsExpr GhcPs
forall p. XMultiIf p -> [LGRHS p (LHsExpr p)] -> HsExpr p
HsMultiIf XMultiIf GhcPs
NoExt
noExt [LGRHS GhcPs (LHsExpr GhcPs)]
alts' }
    cvt (LetE ds :: [Dec]
ds e :: Exp
e)    = do { HsLocalBinds GhcPs
ds' <- MsgDoc -> [Dec] -> CvtM (HsLocalBinds GhcPs)
cvtLocalDecs (String -> MsgDoc
text "a let expression") [Dec]
ds
                            ; LHsExpr GhcPs
e' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
e; HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcPs -> CvtM (HsExpr GhcPs))
-> HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XLet GhcPs -> LHsLocalBinds GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XLet p -> LHsLocalBinds p -> LHsExpr p -> HsExpr p
HsLet XLet GhcPs
NoExt
noExt (SrcSpanLess (LHsLocalBinds GhcPs) -> LHsLocalBinds GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (LHsLocalBinds GhcPs)
HsLocalBinds GhcPs
ds') LHsExpr GhcPs
e'}
    cvt (CaseE e :: Exp
e ms :: [Match]
ms)   = do { LHsExpr GhcPs
e' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
e; [LMatch GhcPs (LHsExpr GhcPs)]
ms' <- (Match -> CvtM (LMatch GhcPs (LHsExpr GhcPs)))
-> [Match] -> CvtM [LMatch GhcPs (LHsExpr GhcPs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (HsMatchContext RdrName
-> Match -> CvtM (LMatch GhcPs (LHsExpr GhcPs))
cvtMatch HsMatchContext RdrName
forall id. HsMatchContext id
CaseAlt) [Match]
ms
                            ; HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcPs -> CvtM (HsExpr GhcPs))
-> HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XCase GhcPs
-> LHsExpr GhcPs
-> MatchGroup GhcPs (LHsExpr GhcPs)
-> HsExpr GhcPs
forall p.
XCase p -> LHsExpr p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsCase XCase GhcPs
NoExt
noExt LHsExpr GhcPs
e'
                                                 (Origin
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> MatchGroup GhcPs (LHsExpr GhcPs)
forall name (body :: * -> *).
(XMG name (Located (body name)) ~ NoExt) =>
Origin
-> [LMatch name (Located (body name))]
-> MatchGroup name (Located (body name))
mkMatchGroup Origin
FromSource [LMatch GhcPs (LHsExpr GhcPs)]
ms') }
    cvt (DoE ss :: [Stmt]
ss)       = HsStmtContext Name -> [Stmt] -> CvtM (HsExpr GhcPs)
cvtHsDo HsStmtContext Name
forall id. HsStmtContext id
DoExpr [Stmt]
ss
    cvt (MDoE ss :: [Stmt]
ss)      = HsStmtContext Name -> [Stmt] -> CvtM (HsExpr GhcPs)
cvtHsDo HsStmtContext Name
forall id. HsStmtContext id
MDoExpr [Stmt]
ss
    cvt (CompE ss :: [Stmt]
ss)     = HsStmtContext Name -> [Stmt] -> CvtM (HsExpr GhcPs)
cvtHsDo HsStmtContext Name
forall id. HsStmtContext id
ListComp [Stmt]
ss
    cvt (ArithSeqE dd :: Range
dd) = do { ArithSeqInfo GhcPs
dd' <- Range -> CvtM (ArithSeqInfo GhcPs)
cvtDD Range
dd
                            ; HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcPs -> CvtM (HsExpr GhcPs))
-> HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XArithSeq GhcPs
-> Maybe (SyntaxExpr GhcPs) -> ArithSeqInfo GhcPs -> HsExpr GhcPs
forall p.
XArithSeq p -> Maybe (SyntaxExpr p) -> ArithSeqInfo p -> HsExpr p
ArithSeq XArithSeq GhcPs
NoExt
noExt Maybe (SyntaxExpr GhcPs)
forall a. Maybe a
Nothing ArithSeqInfo GhcPs
dd' }
    cvt (ListE xs :: [Exp]
xs)
      | Just s :: String
s <- [Exp] -> Maybe String
allCharLs [Exp]
xs       = do { HsLit GhcPs
l' <- Lit -> CvtM (HsLit GhcPs)
cvtLit (String -> Lit
StringL String
s)
                                          ; HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (XLitE GhcPs -> HsLit GhcPs -> HsExpr GhcPs
forall p. XLitE p -> HsLit p -> HsExpr p
HsLit XLitE GhcPs
NoExt
noExt HsLit GhcPs
l') }
             -- Note [Converting strings]
      | Bool
otherwise       = do { [LHsExpr GhcPs]
xs' <- (Exp -> CvtM (LHsExpr GhcPs)) -> [Exp] -> CvtM [LHsExpr GhcPs]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Exp -> CvtM (LHsExpr GhcPs)
cvtl [Exp]
xs
                             ; HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcPs -> CvtM (HsExpr GhcPs))
-> HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XExplicitList GhcPs
-> Maybe (SyntaxExpr GhcPs) -> [LHsExpr GhcPs] -> HsExpr GhcPs
forall p.
XExplicitList p -> Maybe (SyntaxExpr p) -> [LHsExpr p] -> HsExpr p
ExplicitList XExplicitList GhcPs
NoExt
noExt Maybe (SyntaxExpr GhcPs)
forall a. Maybe a
Nothing [LHsExpr GhcPs]
xs'
                             }

    -- Infix expressions
    cvt (InfixE (Just x :: Exp
x) s :: Exp
s (Just y :: Exp
y)) =
      do { LHsExpr GhcPs
x' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
x
         ; LHsExpr GhcPs
s' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
s
         ; LHsExpr GhcPs
y' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
y
         ; let px :: LHsExpr GhcPs
px = PprPrec -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (p :: Pass).
PprPrec -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
parenthesizeHsExpr PprPrec
opPrec LHsExpr GhcPs
x'
               py :: LHsExpr GhcPs
py = PprPrec -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (p :: Pass).
PprPrec -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
parenthesizeHsExpr PprPrec
opPrec LHsExpr GhcPs
y'
         ; (LHsExpr GhcPs -> SrcSpanLess (LHsExpr GhcPs))
-> SrcSpanLess (LHsExpr GhcPs)
-> CvtM (SrcSpanLess (LHsExpr GhcPs))
forall a.
HasSrcSpan a =>
(a -> SrcSpanLess a) -> SrcSpanLess a -> CvtM (SrcSpanLess a)
wrapParL (XPar GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar XPar GhcPs
NoExt
noExt)
           (SrcSpanLess (LHsExpr GhcPs) -> CvtM (HsExpr GhcPs))
-> SrcSpanLess (LHsExpr GhcPs) -> CvtM (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XOpApp GhcPs
-> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp XOpApp GhcPs
NoExt
noExt LHsExpr GhcPs
px LHsExpr GhcPs
s' LHsExpr GhcPs
py }
           -- Parenthesise both arguments and result,
           -- to ensure this operator application does
           -- does not get re-associated
           -- See Note [Operator association]
    cvt (InfixE Nothing  s :: Exp
s (Just y :: Exp
y)) = do { LHsExpr GhcPs
s' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
s; LHsExpr GhcPs
y' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
y
                                          ; (LHsExpr GhcPs -> SrcSpanLess (LHsExpr GhcPs))
-> SrcSpanLess (LHsExpr GhcPs)
-> CvtM (SrcSpanLess (LHsExpr GhcPs))
forall a.
HasSrcSpan a =>
(a -> SrcSpanLess a) -> SrcSpanLess a -> CvtM (SrcSpanLess a)
wrapParL (XPar GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar XPar GhcPs
NoExt
noExt) (SrcSpanLess (LHsExpr GhcPs) -> CvtM (HsExpr GhcPs))
-> SrcSpanLess (LHsExpr GhcPs) -> CvtM (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$
                                                          XSectionR GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XSectionR p -> LHsExpr p -> LHsExpr p -> HsExpr p
SectionR XSectionR GhcPs
NoExt
noExt LHsExpr GhcPs
s' LHsExpr GhcPs
y' }
                                            -- See Note [Sections in HsSyn] in HsExpr
    cvt (InfixE (Just x :: Exp
x) s :: Exp
s Nothing ) = do { LHsExpr GhcPs
x' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
x; LHsExpr GhcPs
s' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
s
                                          ; (LHsExpr GhcPs -> SrcSpanLess (LHsExpr GhcPs))
-> SrcSpanLess (LHsExpr GhcPs)
-> CvtM (SrcSpanLess (LHsExpr GhcPs))
forall a.
HasSrcSpan a =>
(a -> SrcSpanLess a) -> SrcSpanLess a -> CvtM (SrcSpanLess a)
wrapParL (XPar GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar XPar GhcPs
NoExt
noExt) (SrcSpanLess (LHsExpr GhcPs) -> CvtM (HsExpr GhcPs))
-> SrcSpanLess (LHsExpr GhcPs) -> CvtM (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$
                                                          XSectionL GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XSectionL p -> LHsExpr p -> LHsExpr p -> HsExpr p
SectionL XSectionL GhcPs
NoExt
noExt LHsExpr GhcPs
x' LHsExpr GhcPs
s' }

    cvt (InfixE Nothing  s :: Exp
s Nothing ) = do { LHsExpr GhcPs
s' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
s
                                          ; HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcPs -> CvtM (HsExpr GhcPs))
-> HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XPar GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar XPar GhcPs
NoExt
noExt LHsExpr GhcPs
s' }
                                       -- Can I indicate this is an infix thing?
                                       -- Note [Dropping constructors]

    cvt (UInfixE x :: Exp
x s :: Exp
s y :: Exp
y)  = do { LHsExpr GhcPs
x' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
x
                              ; let x'' :: LHsExpr GhcPs
x'' = case LHsExpr GhcPs -> SrcSpanLess (LHsExpr GhcPs)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsExpr GhcPs
x' of
                                            OpApp {} -> LHsExpr GhcPs
x'
                                            _ -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkLHsPar LHsExpr GhcPs
x'
                              ; LHsExpr GhcPs -> Exp -> Exp -> CvtM (HsExpr GhcPs)
cvtOpApp LHsExpr GhcPs
x'' Exp
s Exp
y } --  Note [Converting UInfix]

    cvt (ParensE e :: Exp
e)      = do { LHsExpr GhcPs
e' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
e; HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcPs -> CvtM (HsExpr GhcPs))
-> HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XPar GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar XPar GhcPs
NoExt
noExt LHsExpr GhcPs
e' }
    cvt (SigE e :: Exp
e t :: Type
t)       = do { LHsExpr GhcPs
e' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
e; LHsType GhcPs
t' <- Type -> CvtM (LHsType GhcPs)
cvtType Type
t
                              ; let pe :: LHsExpr GhcPs
pe = PprPrec -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (p :: Pass).
PprPrec -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
parenthesizeHsExpr PprPrec
sigPrec LHsExpr GhcPs
e'
                              ; HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcPs -> CvtM (HsExpr GhcPs))
-> HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XExprWithTySig GhcPs
-> LHsExpr GhcPs -> LHsSigWcType (NoGhcTc GhcPs) -> HsExpr GhcPs
forall p.
XExprWithTySig p
-> LHsExpr p -> LHsSigWcType (NoGhcTc p) -> HsExpr p
ExprWithTySig XExprWithTySig GhcPs
NoExt
noExt LHsExpr GhcPs
pe (LHsType GhcPs -> LHsSigWcType GhcPs
mkLHsSigWcType LHsType GhcPs
t') }
    cvt (RecConE c :: Name
c flds :: [FieldExp]
flds) = do { Located RdrName
c' <- Name -> CvtM (Located RdrName)
cNameL Name
c
                              ; [LHsRecField' (FieldOcc GhcPs) (LHsExpr GhcPs)]
flds' <- (FieldExp -> CvtM (LHsRecField' (FieldOcc GhcPs) (LHsExpr GhcPs)))
-> [FieldExp]
-> CvtM [LHsRecField' (FieldOcc GhcPs) (LHsExpr GhcPs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((RdrName -> FieldOcc GhcPs)
-> FieldExp -> CvtM (LHsRecField' (FieldOcc GhcPs) (LHsExpr GhcPs))
forall t.
(RdrName -> t) -> FieldExp -> CvtM (LHsRecField' t (LHsExpr GhcPs))
cvtFld (Located RdrName -> FieldOcc GhcPs
mkFieldOcc (Located RdrName -> FieldOcc GhcPs)
-> (RdrName -> Located RdrName) -> RdrName -> FieldOcc GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RdrName -> Located RdrName
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc)) [FieldExp]
flds
                              ; HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcPs -> CvtM (HsExpr GhcPs))
-> HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ Located RdrName -> HsRecordBinds GhcPs -> HsExpr GhcPs
mkRdrRecordCon Located RdrName
c' ([LHsRecField' (FieldOcc GhcPs) (LHsExpr GhcPs)]
-> Maybe Int -> HsRecordBinds GhcPs
forall p arg. [LHsRecField p arg] -> Maybe Int -> HsRecFields p arg
HsRecFields [LHsRecField' (FieldOcc GhcPs) (LHsExpr GhcPs)]
flds' Maybe Int
forall a. Maybe a
Nothing) }
    cvt (RecUpdE e :: Exp
e flds :: [FieldExp]
flds) = do { LHsExpr GhcPs
e' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
e
                              ; [LHsRecField' (AmbiguousFieldOcc GhcPs) (LHsExpr GhcPs)]
flds'
                                  <- (FieldExp
 -> CvtM (LHsRecField' (AmbiguousFieldOcc GhcPs) (LHsExpr GhcPs)))
-> [FieldExp]
-> CvtM [LHsRecField' (AmbiguousFieldOcc GhcPs) (LHsExpr GhcPs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((RdrName -> AmbiguousFieldOcc GhcPs)
-> FieldExp
-> CvtM (LHsRecField' (AmbiguousFieldOcc GhcPs) (LHsExpr GhcPs))
forall t.
(RdrName -> t) -> FieldExp -> CvtM (LHsRecField' t (LHsExpr GhcPs))
cvtFld (Located RdrName -> AmbiguousFieldOcc GhcPs
mkAmbiguousFieldOcc (Located RdrName -> AmbiguousFieldOcc GhcPs)
-> (RdrName -> Located RdrName)
-> RdrName
-> AmbiguousFieldOcc GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RdrName -> Located RdrName
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc))
                                           [FieldExp]
flds
                              ; HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcPs -> CvtM (HsExpr GhcPs))
-> HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs
-> [LHsRecField' (AmbiguousFieldOcc GhcPs) (LHsExpr GhcPs)]
-> HsExpr GhcPs
mkRdrRecordUpd LHsExpr GhcPs
e' [LHsRecField' (AmbiguousFieldOcc GhcPs) (LHsExpr GhcPs)]
flds' }
    cvt (StaticE e :: Exp
e)      = (LHsExpr GhcPs -> HsExpr GhcPs)
-> CvtM (LHsExpr GhcPs) -> CvtM (HsExpr GhcPs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (XStatic GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XStatic p -> LHsExpr p -> HsExpr p
HsStatic XStatic GhcPs
NoExt
noExt) (CvtM (LHsExpr GhcPs) -> CvtM (HsExpr GhcPs))
-> CvtM (LHsExpr GhcPs) -> CvtM (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
e
    cvt (UnboundVarE s :: Name
s)  = do -- Use of 'vcName' here instead of 'vName' is
                              -- important, because UnboundVarE may contain
                              -- constructor names - see #14627.
                              { RdrName
s' <- Name -> CvtM RdrName
vcName Name
s
                              ; HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcPs -> CvtM (HsExpr GhcPs))
-> HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XVar GhcPs -> Located (IdP GhcPs) -> HsExpr GhcPs
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar XVar GhcPs
NoExt
noExt (SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (Located RdrName)
RdrName
s') }
    cvt (LabelE s :: String
s)       = do { HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcPs -> CvtM (HsExpr GhcPs))
-> HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XOverLabel GhcPs
-> Maybe (IdP GhcPs) -> CLabelString -> HsExpr GhcPs
forall p. XOverLabel p -> Maybe (IdP p) -> CLabelString -> HsExpr p
HsOverLabel XOverLabel GhcPs
NoExt
noExt Maybe (IdP GhcPs)
forall a. Maybe a
Nothing (String -> CLabelString
fsLit String
s) }
    cvt (ImplicitParamVarE n :: String
n) = do { HsIPName
n' <- String -> CvtM HsIPName
ipName String
n; HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcPs -> CvtM (HsExpr GhcPs))
-> HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XIPVar GhcPs -> HsIPName -> HsExpr GhcPs
forall p. XIPVar p -> HsIPName -> HsExpr p
HsIPVar XIPVar GhcPs
NoExt
noExt HsIPName
n' }

{- Note [Dropping constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When we drop constructors from the input (for instance, when we encounter @TupE [e]@)
we must insert parentheses around the argument. Otherwise, @UInfix@ constructors in @e@
could meet @UInfix@ constructors containing the @TupE [e]@. For example:

  UInfixE x * (TupE [UInfixE y + z])

If we drop the singleton tuple but don't insert parentheses, the @UInfixE@s would meet
and the above expression would be reassociated to

  OpApp (OpApp x * y) + z

which we don't want.
-}

cvtFld :: (RdrName -> t) -> (TH.Name, TH.Exp)
       -> CvtM (LHsRecField' t (LHsExpr GhcPs))
cvtFld :: (RdrName -> t) -> FieldExp -> CvtM (LHsRecField' t (LHsExpr GhcPs))
cvtFld f :: RdrName -> t
f (v :: Name
v,e :: Exp
e)
  = do  { Located RdrName
v' <- Name -> CvtM (Located RdrName)
vNameL Name
v; LHsExpr GhcPs
e' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
e
        ; LHsRecField' t (LHsExpr GhcPs)
-> CvtM (LHsRecField' t (LHsExpr GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanLess (LHsRecField' t (LHsExpr GhcPs))
-> LHsRecField' t (LHsExpr GhcPs)
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LHsRecField' t (LHsExpr GhcPs))
 -> LHsRecField' t (LHsExpr GhcPs))
-> SrcSpanLess (LHsRecField' t (LHsExpr GhcPs))
-> LHsRecField' t (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ HsRecField :: forall id arg. Located id -> arg -> Bool -> HsRecField' id arg
HsRecField { hsRecFieldLbl :: Located t
hsRecFieldLbl = (RdrName -> t) -> Located RdrName -> Located t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RdrName -> t
f Located RdrName
v'
                                     , hsRecFieldArg :: LHsExpr GhcPs
hsRecFieldArg = LHsExpr GhcPs
e'
                                     , hsRecPun :: Bool
hsRecPun      = Bool
False}) }

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

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


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

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

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

Sample input:

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

Sample output:

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

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

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

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

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

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

cvtHsDo :: HsStmtContext Name.Name -> [TH.Stmt] -> CvtM (HsExpr GhcPs)
cvtHsDo :: HsStmtContext Name -> [Stmt] -> CvtM (HsExpr GhcPs)
cvtHsDo do_or_lc :: HsStmtContext Name
do_or_lc stmts :: [Stmt]
stmts
  | [Stmt] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Stmt]
stmts = MsgDoc -> CvtM (HsExpr GhcPs)
forall a. MsgDoc -> CvtM a
failWith (String -> MsgDoc
text "Empty stmt list in do-block")
  | Bool
otherwise
  = do  { [LStmt GhcPs (LHsExpr GhcPs)]
stmts' <- [Stmt] -> CvtM [LStmt GhcPs (LHsExpr GhcPs)]
cvtStmts [Stmt]
stmts
        ; let Just (stmts'' :: [LStmt GhcPs (LHsExpr GhcPs)]
stmts'', last' :: LStmt GhcPs (LHsExpr GhcPs)
last') = [LStmt GhcPs (LHsExpr GhcPs)]
-> Maybe
     ([LStmt GhcPs (LHsExpr GhcPs)], LStmt GhcPs (LHsExpr GhcPs))
forall a. [a] -> Maybe ([a], a)
snocView [LStmt GhcPs (LHsExpr GhcPs)]
stmts'

        ; LStmt GhcPs (LHsExpr GhcPs)
last'' <- case LStmt GhcPs (LHsExpr GhcPs)
last' of
                    (LStmt GhcPs (LHsExpr GhcPs)
-> Located (SrcSpanLess (LStmt GhcPs (LHsExpr GhcPs)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc (BodyStmt _ body _ _))
                      -> LStmt GhcPs (LHsExpr GhcPs) -> CvtM (LStmt GhcPs (LHsExpr GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan
-> SrcSpanLess (LStmt GhcPs (LHsExpr GhcPs))
-> LStmt GhcPs (LHsExpr GhcPs)
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
forall (bodyR :: * -> *) (idR :: Pass) (idL :: Pass).
Located (bodyR (GhcPass idR))
-> StmtLR
     (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR)))
mkLastStmt LHsExpr GhcPs
body))
                    _ -> MsgDoc -> CvtM (LStmt GhcPs (LHsExpr GhcPs))
forall a. MsgDoc -> CvtM a
failWith (LStmt GhcPs (LHsExpr GhcPs) -> MsgDoc
bad_last LStmt GhcPs (LHsExpr GhcPs)
last')

        ; HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcPs -> CvtM (HsExpr GhcPs))
-> HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XDo GhcPs
-> HsStmtContext Name
-> Located [LStmt GhcPs (LHsExpr GhcPs)]
-> HsExpr GhcPs
forall p.
XDo p -> HsStmtContext Name -> Located [ExprLStmt p] -> HsExpr p
HsDo XDo GhcPs
NoExt
noExt HsStmtContext Name
do_or_lc (SrcSpanLess (Located [LStmt GhcPs (LHsExpr GhcPs)])
-> Located [LStmt GhcPs (LHsExpr GhcPs)]
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc ([LStmt GhcPs (LHsExpr GhcPs)]
stmts'' [LStmt GhcPs (LHsExpr GhcPs)]
-> [LStmt GhcPs (LHsExpr GhcPs)] -> [LStmt GhcPs (LHsExpr GhcPs)]
forall a. [a] -> [a] -> [a]
++ [LStmt GhcPs (LHsExpr GhcPs)
last''])) }
  where
    bad_last :: LStmt GhcPs (LHsExpr GhcPs) -> MsgDoc
bad_last stmt :: LStmt GhcPs (LHsExpr GhcPs)
stmt = [MsgDoc] -> MsgDoc
vcat [ String -> MsgDoc
text "Illegal last statement of" MsgDoc -> MsgDoc -> MsgDoc
<+> HsStmtContext Name -> MsgDoc
forall id.
(Outputable id, Outputable (NameOrRdrName id)) =>
HsStmtContext id -> MsgDoc
pprAStmtContext HsStmtContext Name
do_or_lc MsgDoc -> MsgDoc -> MsgDoc
<> MsgDoc
colon
                         , Int -> MsgDoc -> MsgDoc
nest 2 (MsgDoc -> MsgDoc) -> MsgDoc -> MsgDoc
forall a b. (a -> b) -> a -> b
$ LStmt GhcPs (LHsExpr GhcPs) -> MsgDoc
forall a. Outputable a => a -> MsgDoc
Outputable.ppr LStmt GhcPs (LHsExpr GhcPs)
stmt
                         , String -> MsgDoc
text "(It should be an expression.)" ]

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

cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt GhcPs (LHsExpr GhcPs))
cvtStmt :: Stmt -> CvtM (LStmt GhcPs (LHsExpr GhcPs))
cvtStmt (NoBindS e :: Exp
e)    = do { LHsExpr GhcPs
e' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
e; SrcSpanLess (LStmt GhcPs (LHsExpr GhcPs))
-> CvtM (LStmt GhcPs (LHsExpr GhcPs))
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM a
returnL (SrcSpanLess (LStmt GhcPs (LHsExpr GhcPs))
 -> CvtM (LStmt GhcPs (LHsExpr GhcPs)))
-> SrcSpanLess (LStmt GhcPs (LHsExpr GhcPs))
-> CvtM (LStmt GhcPs (LHsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
forall (bodyR :: * -> *) (idL :: Pass).
Located (bodyR GhcPs)
-> StmtLR (GhcPass idL) GhcPs (Located (bodyR GhcPs))
mkBodyStmt LHsExpr GhcPs
e' }
cvtStmt (TH.BindS p :: Pat
p e :: Exp
e) = do { LPat GhcPs
p' <- Pat -> CvtM (LPat GhcPs)
cvtPat Pat
p; LHsExpr GhcPs
e' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
e; SrcSpanLess (LStmt GhcPs (LHsExpr GhcPs))
-> CvtM (LStmt GhcPs (LHsExpr GhcPs))
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM a
returnL (SrcSpanLess (LStmt GhcPs (LHsExpr GhcPs))
 -> CvtM (LStmt GhcPs (LHsExpr GhcPs)))
-> SrcSpanLess (LStmt GhcPs (LHsExpr GhcPs))
-> CvtM (LStmt GhcPs (LHsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ LPat GhcPs -> LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
forall (idL :: Pass) (idR :: Pass) (bodyR :: * -> *).
(XBindStmt
   (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR)))
 ~ NoExt) =>
LPat (GhcPass idL)
-> Located (bodyR (GhcPass idR))
-> StmtLR
     (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR)))
mkBindStmt LPat GhcPs
p' LHsExpr GhcPs
e' }
cvtStmt (TH.LetS ds :: [Dec]
ds)   = do { HsLocalBinds GhcPs
ds' <- MsgDoc -> [Dec] -> CvtM (HsLocalBinds GhcPs)
cvtLocalDecs (String -> MsgDoc
text "a let binding") [Dec]
ds
                            ; SrcSpanLess (LStmt GhcPs (LHsExpr GhcPs))
-> CvtM (LStmt GhcPs (LHsExpr GhcPs))
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM a
returnL (SrcSpanLess (LStmt GhcPs (LHsExpr GhcPs))
 -> CvtM (LStmt GhcPs (LHsExpr GhcPs)))
-> SrcSpanLess (LStmt GhcPs (LHsExpr GhcPs))
-> CvtM (LStmt GhcPs (LHsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ XLetStmt GhcPs GhcPs (LHsExpr GhcPs)
-> LHsLocalBinds GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
forall idL idR body.
XLetStmt idL idR body
-> LHsLocalBindsLR idL idR -> StmtLR idL idR body
LetStmt XLetStmt GhcPs GhcPs (LHsExpr GhcPs)
NoExt
noExt (SrcSpanLess (LHsLocalBinds GhcPs) -> LHsLocalBinds GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (LHsLocalBinds GhcPs)
HsLocalBinds GhcPs
ds') }
cvtStmt (TH.ParS dss :: [[Stmt]]
dss)  = do { [ParStmtBlock GhcPs GhcPs]
dss' <- ([Stmt] -> CvtM (ParStmtBlock GhcPs GhcPs))
-> [[Stmt]] -> CvtM [ParStmtBlock GhcPs GhcPs]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM [Stmt] -> CvtM (ParStmtBlock GhcPs GhcPs)
forall (p :: Pass). [Stmt] -> CvtM (ParStmtBlock GhcPs (GhcPass p))
cvt_one [[Stmt]]
dss
                            ; SrcSpanLess (LStmt GhcPs (LHsExpr GhcPs))
-> CvtM (LStmt GhcPs (LHsExpr GhcPs))
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM a
returnL (SrcSpanLess (LStmt GhcPs (LHsExpr GhcPs))
 -> CvtM (LStmt GhcPs (LHsExpr GhcPs)))
-> SrcSpanLess (LStmt GhcPs (LHsExpr GhcPs))
-> CvtM (LStmt GhcPs (LHsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ XParStmt GhcPs GhcPs (LHsExpr GhcPs)
-> [ParStmtBlock GhcPs GhcPs]
-> HsExpr GhcPs
-> SyntaxExpr GhcPs
-> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
forall idL idR body.
XParStmt idL idR body
-> [ParStmtBlock idL idR]
-> HsExpr idR
-> SyntaxExpr idR
-> StmtLR idL idR body
ParStmt XParStmt GhcPs GhcPs (LHsExpr GhcPs)
NoExt
noExt [ParStmtBlock GhcPs GhcPs]
dss' HsExpr GhcPs
forall (p :: Pass). HsExpr (GhcPass p)
noExpr SyntaxExpr GhcPs
forall (p :: Pass). SyntaxExpr (GhcPass p)
noSyntaxExpr }
  where
    cvt_one :: [Stmt] -> CvtM (ParStmtBlock GhcPs (GhcPass p))
cvt_one ds :: [Stmt]
ds = do { [LStmt GhcPs (LHsExpr GhcPs)]
ds' <- [Stmt] -> CvtM [LStmt GhcPs (LHsExpr GhcPs)]
cvtStmts [Stmt]
ds
                    ; ParStmtBlock GhcPs (GhcPass p)
-> CvtM (ParStmtBlock GhcPs (GhcPass p))
forall (m :: * -> *) a. Monad m => a -> m a
return (XParStmtBlock GhcPs (GhcPass p)
-> [LStmt GhcPs (LHsExpr GhcPs)]
-> [IdP (GhcPass p)]
-> SyntaxExpr (GhcPass p)
-> ParStmtBlock GhcPs (GhcPass p)
forall idL idR.
XParStmtBlock idL idR
-> [ExprLStmt idL]
-> [IdP idR]
-> SyntaxExpr idR
-> ParStmtBlock idL idR
ParStmtBlock XParStmtBlock GhcPs (GhcPass p)
NoExt
noExt [LStmt GhcPs (LHsExpr GhcPs)]
ds' [IdP (GhcPass p)]
forall a. HasCallStack => a
undefined SyntaxExpr (GhcPass p)
forall (p :: Pass). SyntaxExpr (GhcPass p)
noSyntaxExpr) }
cvtStmt (TH.RecS ss :: [Stmt]
ss) = do { [LStmt GhcPs (LHsExpr GhcPs)]
ss' <- (Stmt -> CvtM (LStmt GhcPs (LHsExpr GhcPs)))
-> [Stmt] -> CvtM [LStmt GhcPs (LHsExpr GhcPs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Stmt -> CvtM (LStmt GhcPs (LHsExpr GhcPs))
cvtStmt [Stmt]
ss; SrcSpanLess (LStmt GhcPs (LHsExpr GhcPs))
-> CvtM (LStmt GhcPs (LHsExpr GhcPs))
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM a
returnL ([LStmt GhcPs (LHsExpr GhcPs)] -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
forall (idL :: Pass) bodyR.
[LStmtLR (GhcPass idL) GhcPs bodyR]
-> StmtLR (GhcPass idL) GhcPs bodyR
mkRecStmt [LStmt GhcPs (LHsExpr GhcPs)]
ss') }

cvtMatch :: HsMatchContext RdrName
         -> TH.Match -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))
cvtMatch :: HsMatchContext RdrName
-> Match -> CvtM (LMatch GhcPs (LHsExpr GhcPs))
cvtMatch ctxt :: HsMatchContext RdrName
ctxt (TH.Match p :: Pat
p body :: Body
body decs :: [Dec]
decs)
  = do  { LPat GhcPs
p' <- Pat -> CvtM (LPat GhcPs)
cvtPat Pat
p
        ; let lp :: LPat GhcPs
lp = case LPat GhcPs
p' of
                     (LPat GhcPs -> Located (SrcSpanLess (LPat GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc SigPat{}) -> SrcSpan -> SrcSpanLess (LPat GhcPs) -> LPat GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (XParPat GhcPs -> LPat GhcPs -> LPat GhcPs
forall p. XParPat p -> LPat p -> LPat p
ParPat XParPat GhcPs
NoExt
NoExt LPat GhcPs
p') -- #14875
                     _                    -> LPat GhcPs
p'
        ; [LGRHS GhcPs (LHsExpr GhcPs)]
g' <- Body -> CvtM [LGRHS GhcPs (LHsExpr GhcPs)]
cvtGuard Body
body
        ; HsLocalBinds GhcPs
decs' <- MsgDoc -> [Dec] -> CvtM (HsLocalBinds GhcPs)
cvtLocalDecs (String -> MsgDoc
text "a where clause") [Dec]
decs
        ; SrcSpanLess (LMatch GhcPs (LHsExpr GhcPs))
-> CvtM (LMatch GhcPs (LHsExpr GhcPs))
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM a
returnL (SrcSpanLess (LMatch GhcPs (LHsExpr GhcPs))
 -> CvtM (LMatch GhcPs (LHsExpr GhcPs)))
-> SrcSpanLess (LMatch GhcPs (LHsExpr GhcPs))
-> CvtM (LMatch GhcPs (LHsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ XCMatch GhcPs (LHsExpr GhcPs)
-> HsMatchContext (NameOrRdrName (IdP GhcPs))
-> [LPat GhcPs]
-> GRHSs GhcPs (LHsExpr GhcPs)
-> Match GhcPs (LHsExpr GhcPs)
forall p body.
XCMatch p body
-> HsMatchContext (NameOrRdrName (IdP p))
-> [LPat p]
-> GRHSs p body
-> Match p body
Hs.Match XCMatch GhcPs (LHsExpr GhcPs)
NoExt
noExt HsMatchContext RdrName
HsMatchContext (NameOrRdrName (IdP GhcPs))
ctxt [LPat GhcPs
lp] (XCGRHSs GhcPs (LHsExpr GhcPs)
-> [LGRHS GhcPs (LHsExpr GhcPs)]
-> LHsLocalBinds GhcPs
-> GRHSs GhcPs (LHsExpr GhcPs)
forall p body.
XCGRHSs p body -> [LGRHS p body] -> LHsLocalBinds p -> GRHSs p body
GRHSs XCGRHSs GhcPs (LHsExpr GhcPs)
NoExt
noExt [LGRHS GhcPs (LHsExpr GhcPs)]
g' (SrcSpanLess (LHsLocalBinds GhcPs) -> LHsLocalBinds GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (LHsLocalBinds GhcPs)
HsLocalBinds GhcPs
decs')) }

cvtGuard :: TH.Body -> CvtM [LGRHS GhcPs (LHsExpr GhcPs)]
cvtGuard :: Body -> CvtM [LGRHS GhcPs (LHsExpr GhcPs)]
cvtGuard (GuardedB pairs :: [(Guard, Exp)]
pairs) = ((Guard, Exp) -> CvtM (LGRHS GhcPs (LHsExpr GhcPs)))
-> [(Guard, Exp)] -> CvtM [LGRHS GhcPs (LHsExpr GhcPs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Guard, Exp) -> CvtM (LGRHS GhcPs (LHsExpr GhcPs))
cvtpair [(Guard, Exp)]
pairs
cvtGuard (NormalB e :: Exp
e)      = do { LHsExpr GhcPs
e' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
e
                               ; LGRHS GhcPs (LHsExpr GhcPs)
g' <- SrcSpanLess (LGRHS GhcPs (LHsExpr GhcPs))
-> CvtM (LGRHS GhcPs (LHsExpr GhcPs))
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM a
returnL (SrcSpanLess (LGRHS GhcPs (LHsExpr GhcPs))
 -> CvtM (LGRHS GhcPs (LHsExpr GhcPs)))
-> SrcSpanLess (LGRHS GhcPs (LHsExpr GhcPs))
-> CvtM (LGRHS GhcPs (LHsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ XCGRHS GhcPs (LHsExpr GhcPs)
-> [LStmt GhcPs (LHsExpr GhcPs)]
-> LHsExpr GhcPs
-> GRHS GhcPs (LHsExpr GhcPs)
forall p body.
XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body
GRHS XCGRHS GhcPs (LHsExpr GhcPs)
NoExt
noExt [] LHsExpr GhcPs
e'; [LGRHS GhcPs (LHsExpr GhcPs)] -> CvtM [LGRHS GhcPs (LHsExpr GhcPs)]
forall (m :: * -> *) a. Monad m => a -> m a
return [LGRHS GhcPs (LHsExpr GhcPs)
g'] }

cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS GhcPs (LHsExpr GhcPs))
cvtpair :: (Guard, Exp) -> CvtM (LGRHS GhcPs (LHsExpr GhcPs))
cvtpair (NormalG ge :: Exp
ge,rhs :: Exp
rhs) = do { LHsExpr GhcPs
ge' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
ge; LHsExpr GhcPs
rhs' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
rhs
                              ; LStmt GhcPs (LHsExpr GhcPs)
g' <- SrcSpanLess (LStmt GhcPs (LHsExpr GhcPs))
-> CvtM (LStmt GhcPs (LHsExpr GhcPs))
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM a
returnL (SrcSpanLess (LStmt GhcPs (LHsExpr GhcPs))
 -> CvtM (LStmt GhcPs (LHsExpr GhcPs)))
-> SrcSpanLess (LStmt GhcPs (LHsExpr GhcPs))
-> CvtM (LStmt GhcPs (LHsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
forall (bodyR :: * -> *) (idL :: Pass).
Located (bodyR GhcPs)
-> StmtLR (GhcPass idL) GhcPs (Located (bodyR GhcPs))
mkBodyStmt LHsExpr GhcPs
ge'
                              ; SrcSpanLess (LGRHS GhcPs (LHsExpr GhcPs))
-> CvtM (LGRHS GhcPs (LHsExpr GhcPs))
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM a
returnL (SrcSpanLess (LGRHS GhcPs (LHsExpr GhcPs))
 -> CvtM (LGRHS GhcPs (LHsExpr GhcPs)))
-> SrcSpanLess (LGRHS GhcPs (LHsExpr GhcPs))
-> CvtM (LGRHS GhcPs (LHsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ XCGRHS GhcPs (LHsExpr GhcPs)
-> [LStmt GhcPs (LHsExpr GhcPs)]
-> LHsExpr GhcPs
-> GRHS GhcPs (LHsExpr GhcPs)
forall p body.
XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body
GRHS XCGRHS GhcPs (LHsExpr GhcPs)
NoExt
noExt [LStmt GhcPs (LHsExpr GhcPs)
g'] LHsExpr GhcPs
rhs' }
cvtpair (PatG gs :: [Stmt]
gs,rhs :: Exp
rhs)    = do { [LStmt GhcPs (LHsExpr GhcPs)]
gs' <- [Stmt] -> CvtM [LStmt GhcPs (LHsExpr GhcPs)]
cvtStmts [Stmt]
gs; LHsExpr GhcPs
rhs' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
rhs
                              ; SrcSpanLess (LGRHS GhcPs (LHsExpr GhcPs))
-> CvtM (LGRHS GhcPs (LHsExpr GhcPs))
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM a
returnL (SrcSpanLess (LGRHS GhcPs (LHsExpr GhcPs))
 -> CvtM (LGRHS GhcPs (LHsExpr GhcPs)))
-> SrcSpanLess (LGRHS GhcPs (LHsExpr GhcPs))
-> CvtM (LGRHS GhcPs (LHsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ XCGRHS GhcPs (LHsExpr GhcPs)
-> [LStmt GhcPs (LHsExpr GhcPs)]
-> LHsExpr GhcPs
-> GRHS GhcPs (LHsExpr GhcPs)
forall p body.
XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body
GRHS XCGRHS GhcPs (LHsExpr GhcPs)
NoExt
noExt [LStmt GhcPs (LHsExpr GhcPs)]
gs' LHsExpr GhcPs
rhs' }

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

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

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

cvtLit :: Lit -> CvtM (HsLit GhcPs)
cvtLit :: Lit -> CvtM (HsLit GhcPs)
cvtLit (IntPrimL i :: Integer
i)    = do { Integer -> CvtM ()
forall a. a -> CvtM ()
force Integer
i; HsLit GhcPs -> CvtM (HsLit GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsLit GhcPs -> CvtM (HsLit GhcPs))
-> HsLit GhcPs -> CvtM (HsLit GhcPs)
forall a b. (a -> b) -> a -> b
$ XHsIntPrim GhcPs -> Integer -> HsLit GhcPs
forall x. XHsIntPrim x -> Integer -> HsLit x
HsIntPrim SourceText
XHsIntPrim GhcPs
NoSourceText Integer
i }
cvtLit (WordPrimL w :: Integer
w)   = do { Integer -> CvtM ()
forall a. a -> CvtM ()
force Integer
w; HsLit GhcPs -> CvtM (HsLit GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsLit GhcPs -> CvtM (HsLit GhcPs))
-> HsLit GhcPs -> CvtM (HsLit GhcPs)
forall a b. (a -> b) -> a -> b
$ XHsWordPrim GhcPs -> Integer -> HsLit GhcPs
forall x. XHsWordPrim x -> Integer -> HsLit x
HsWordPrim SourceText
XHsWordPrim GhcPs
NoSourceText Integer
w }
cvtLit (FloatPrimL f :: Rational
f)
  = do { Rational -> CvtM ()
forall a. a -> CvtM ()
force Rational
f; HsLit GhcPs -> CvtM (HsLit GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsLit GhcPs -> CvtM (HsLit GhcPs))
-> HsLit GhcPs -> CvtM (HsLit GhcPs)
forall a b. (a -> b) -> a -> b
$ XHsFloatPrim GhcPs -> FractionalLit -> HsLit GhcPs
forall x. XHsFloatPrim x -> FractionalLit -> HsLit x
HsFloatPrim XHsFloatPrim GhcPs
NoExt
noExt (Rational -> FractionalLit
forall a. Real a => a -> FractionalLit
mkFractionalLit Rational
f) }
cvtLit (DoublePrimL f :: Rational
f)
  = do { Rational -> CvtM ()
forall a. a -> CvtM ()
force Rational
f; HsLit GhcPs -> CvtM (HsLit GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsLit GhcPs -> CvtM (HsLit GhcPs))
-> HsLit GhcPs -> CvtM (HsLit GhcPs)
forall a b. (a -> b) -> a -> b
$ XHsDoublePrim GhcPs -> FractionalLit -> HsLit GhcPs
forall x. XHsDoublePrim x -> FractionalLit -> HsLit x
HsDoublePrim XHsDoublePrim GhcPs
NoExt
noExt (Rational -> FractionalLit
forall a. Real a => a -> FractionalLit
mkFractionalLit Rational
f) }
cvtLit (CharL c :: Char
c)       = do { Char -> CvtM ()
forall a. a -> CvtM ()
force Char
c; HsLit GhcPs -> CvtM (HsLit GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsLit GhcPs -> CvtM (HsLit GhcPs))
-> HsLit GhcPs -> CvtM (HsLit GhcPs)
forall a b. (a -> b) -> a -> b
$ XHsChar GhcPs -> Char -> HsLit GhcPs
forall x. XHsChar x -> Char -> HsLit x
HsChar SourceText
XHsChar GhcPs
NoSourceText Char
c }
cvtLit (CharPrimL c :: Char
c)   = do { Char -> CvtM ()
forall a. a -> CvtM ()
force Char
c; HsLit GhcPs -> CvtM (HsLit GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsLit GhcPs -> CvtM (HsLit GhcPs))
-> HsLit GhcPs -> CvtM (HsLit GhcPs)
forall a b. (a -> b) -> a -> b
$ XHsCharPrim GhcPs -> Char -> HsLit GhcPs
forall x. XHsCharPrim x -> Char -> HsLit x
HsCharPrim SourceText
XHsCharPrim GhcPs
NoSourceText Char
c }
cvtLit (StringL s :: String
s)     = do { let { s' :: CLabelString
s' = String -> CLabelString
mkFastString String
s }
                            ; CLabelString -> CvtM ()
forall a. a -> CvtM ()
force CLabelString
s'
                            ; HsLit GhcPs -> CvtM (HsLit GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsLit GhcPs -> CvtM (HsLit GhcPs))
-> HsLit GhcPs -> CvtM (HsLit GhcPs)
forall a b. (a -> b) -> a -> b
$ XHsString GhcPs -> CLabelString -> HsLit GhcPs
forall x. XHsString x -> CLabelString -> HsLit x
HsString (String -> SourceText
quotedSourceText String
s) CLabelString
s' }
cvtLit (StringPrimL s :: [Word8]
s) = do { let { s' :: ByteString
s' = [Word8] -> ByteString
BS.pack [Word8]
s }
                            ; ByteString -> CvtM ()
forall a. a -> CvtM ()
force ByteString
s'
                            ; HsLit GhcPs -> CvtM (HsLit GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsLit GhcPs -> CvtM (HsLit GhcPs))
-> HsLit GhcPs -> CvtM (HsLit GhcPs)
forall a b. (a -> b) -> a -> b
$ XHsStringPrim GhcPs -> ByteString -> HsLit GhcPs
forall x. XHsStringPrim x -> ByteString -> HsLit x
HsStringPrim SourceText
XHsStringPrim GhcPs
NoSourceText ByteString
s' }
cvtLit _ = String -> CvtM (HsLit GhcPs)
forall a. String -> a
panic "Convert.cvtLit: Unexpected literal"
        -- cvtLit should not be called on IntegerL, RationalL
        -- That precondition is established right here in
        -- Convert.hs, hence panic

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

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

cvtPat :: TH.Pat -> CvtM (Hs.LPat GhcPs)
cvtPat :: Pat -> CvtM (LPat GhcPs)
cvtPat pat :: Pat
pat = CvtM (SrcSpanLess (LPat GhcPs)) -> CvtM (LPat GhcPs)
forall a. HasSrcSpan a => CvtM (SrcSpanLess a) -> CvtM a
wrapL (Pat -> CvtM (LPat GhcPs)
cvtp Pat
pat)

cvtp :: TH.Pat -> CvtM (Hs.Pat GhcPs)
cvtp :: Pat -> CvtM (LPat GhcPs)
cvtp (TH.LitP l :: Lit
l)
  | Lit -> Bool
overloadedLit Lit
l    = do { HsOverLit GhcPs
l' <- Lit -> CvtM (HsOverLit GhcPs)
cvtOverLit Lit
l
                            ; LPat GhcPs -> CvtM (LPat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs) -> LPat GhcPs
mkNPat (SrcSpanLess (Located (HsOverLit GhcPs))
-> Located (HsOverLit GhcPs)
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (Located (HsOverLit GhcPs))
HsOverLit GhcPs
l') Maybe (SyntaxExpr GhcPs)
forall a. Maybe a
Nothing) }
                                  -- Not right for negative patterns;
                                  -- need to think about that!
  | Bool
otherwise          = do { HsLit GhcPs
l' <- Lit -> CvtM (HsLit GhcPs)
cvtLit Lit
l; LPat GhcPs -> CvtM (LPat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LPat GhcPs -> CvtM (LPat GhcPs))
-> LPat GhcPs -> CvtM (LPat GhcPs)
forall a b. (a -> b) -> a -> b
$ XLitPat GhcPs -> HsLit GhcPs -> LPat GhcPs
forall p. XLitPat p -> HsLit p -> LPat p
Hs.LitPat XLitPat GhcPs
NoExt
noExt HsLit GhcPs
l' }
cvtp (TH.VarP s :: Name
s)       = do { RdrName
s' <- Name -> CvtM RdrName
vName Name
s
                            ; LPat GhcPs -> CvtM (LPat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LPat GhcPs -> CvtM (LPat GhcPs))
-> LPat GhcPs -> CvtM (LPat GhcPs)
forall a b. (a -> b) -> a -> b
$ XVarPat GhcPs -> Located (IdP GhcPs) -> LPat GhcPs
forall p. XVarPat p -> Located (IdP p) -> LPat p
Hs.VarPat XVarPat GhcPs
NoExt
noExt (SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (Located RdrName)
RdrName
s') }
cvtp (TupP [p :: Pat
p])        = do { LPat GhcPs
p' <- Pat -> CvtM (LPat GhcPs)
cvtPat Pat
p; LPat GhcPs -> CvtM (LPat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LPat GhcPs -> CvtM (LPat GhcPs))
-> LPat GhcPs -> CvtM (LPat GhcPs)
forall a b. (a -> b) -> a -> b
$ XParPat GhcPs -> LPat GhcPs -> LPat GhcPs
forall p. XParPat p -> LPat p -> LPat p
ParPat XParPat GhcPs
NoExt
noExt LPat GhcPs
p' }
                                         -- Note [Dropping constructors]
cvtp (TupP ps :: [Pat]
ps)         = do { [LPat GhcPs]
ps' <- [Pat] -> CvtM [LPat GhcPs]
cvtPats [Pat]
ps
                            ; LPat GhcPs -> CvtM (LPat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LPat GhcPs -> CvtM (LPat GhcPs))
-> LPat GhcPs -> CvtM (LPat GhcPs)
forall a b. (a -> b) -> a -> b
$ XTuplePat GhcPs -> [LPat GhcPs] -> Boxity -> LPat GhcPs
forall p. XTuplePat p -> [LPat p] -> Boxity -> LPat p
TuplePat XTuplePat GhcPs
NoExt
noExt [LPat GhcPs]
ps' Boxity
Boxed }
cvtp (UnboxedTupP ps :: [Pat]
ps)  = do { [LPat GhcPs]
ps' <- [Pat] -> CvtM [LPat GhcPs]
cvtPats [Pat]
ps
                            ; LPat GhcPs -> CvtM (LPat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LPat GhcPs -> CvtM (LPat GhcPs))
-> LPat GhcPs -> CvtM (LPat GhcPs)
forall a b. (a -> b) -> a -> b
$ XTuplePat GhcPs -> [LPat GhcPs] -> Boxity -> LPat GhcPs
forall p. XTuplePat p -> [LPat p] -> Boxity -> LPat p
TuplePat XTuplePat GhcPs
NoExt
noExt [LPat GhcPs]
ps' Boxity
Unboxed }
cvtp (UnboxedSumP p :: Pat
p alt :: Int
alt arity :: Int
arity)
                       = do { LPat GhcPs
p' <- Pat -> CvtM (LPat GhcPs)
cvtPat Pat
p
                            ; Int -> Int -> CvtM ()
unboxedSumChecks Int
alt Int
arity
                            ; LPat GhcPs -> CvtM (LPat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LPat GhcPs -> CvtM (LPat GhcPs))
-> LPat GhcPs -> CvtM (LPat GhcPs)
forall a b. (a -> b) -> a -> b
$ XSumPat GhcPs -> LPat GhcPs -> Int -> Int -> LPat GhcPs
forall p. XSumPat p -> LPat p -> Int -> Int -> LPat p
SumPat XSumPat GhcPs
NoExt
noExt LPat GhcPs
p' Int
alt Int
arity }
cvtp (ConP s :: Name
s ps :: [Pat]
ps)       = do { Located RdrName
s' <- Name -> CvtM (Located RdrName)
cNameL Name
s; [LPat GhcPs]
ps' <- [Pat] -> CvtM [LPat GhcPs]
cvtPats [Pat]
ps
                            ; let pps :: [LPat GhcPs]
pps = (LPat GhcPs -> LPat GhcPs) -> [LPat GhcPs] -> [LPat GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map (PprPrec -> LPat GhcPs -> LPat GhcPs
forall (p :: Pass). PprPrec -> LPat (GhcPass p) -> LPat (GhcPass p)
parenthesizePat PprPrec
appPrec) [LPat GhcPs]
ps'
                            ; LPat GhcPs -> CvtM (LPat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LPat GhcPs -> CvtM (LPat GhcPs))
-> LPat GhcPs -> CvtM (LPat GhcPs)
forall a b. (a -> b) -> a -> b
$ Located (IdP GhcPs) -> HsConPatDetails GhcPs -> LPat GhcPs
forall p. Located (IdP p) -> HsConPatDetails p -> LPat p
ConPatIn Located RdrName
Located (IdP GhcPs)
s' ([LPat GhcPs] -> HsConPatDetails GhcPs
forall arg rec. [arg] -> HsConDetails arg rec
PrefixCon [LPat GhcPs]
pps) }
cvtp (InfixP p1 :: Pat
p1 s :: Name
s p2 :: Pat
p2)  = do { Located RdrName
s' <- Name -> CvtM (Located RdrName)
cNameL Name
s; LPat GhcPs
p1' <- Pat -> CvtM (LPat GhcPs)
cvtPat Pat
p1; LPat GhcPs
p2' <- Pat -> CvtM (LPat GhcPs)
cvtPat Pat
p2
                            ; (LPat GhcPs -> SrcSpanLess (LPat GhcPs))
-> SrcSpanLess (LPat GhcPs) -> CvtM (SrcSpanLess (LPat GhcPs))
forall a.
HasSrcSpan a =>
(a -> SrcSpanLess a) -> SrcSpanLess a -> CvtM (SrcSpanLess a)
wrapParL (XParPat GhcPs -> LPat GhcPs -> LPat GhcPs
forall p. XParPat p -> LPat p -> LPat p
ParPat XParPat GhcPs
NoExt
noExt) (SrcSpanLess (LPat GhcPs) -> CvtM (LPat GhcPs))
-> SrcSpanLess (LPat GhcPs) -> CvtM (LPat GhcPs)
forall a b. (a -> b) -> a -> b
$
                              Located (IdP GhcPs) -> HsConPatDetails GhcPs -> LPat GhcPs
forall p. Located (IdP p) -> HsConPatDetails p -> LPat p
ConPatIn Located RdrName
Located (IdP GhcPs)
s' (HsConPatDetails GhcPs -> SrcSpanLess (LPat GhcPs))
-> HsConPatDetails GhcPs -> SrcSpanLess (LPat GhcPs)
forall a b. (a -> b) -> a -> b
$
                              LPat GhcPs -> LPat GhcPs -> HsConPatDetails GhcPs
forall arg rec. arg -> arg -> HsConDetails arg rec
InfixCon (PprPrec -> LPat GhcPs -> LPat GhcPs
forall (p :: Pass). PprPrec -> LPat (GhcPass p) -> LPat (GhcPass p)
parenthesizePat PprPrec
opPrec LPat GhcPs
p1')
                                       (PprPrec -> LPat GhcPs -> LPat GhcPs
forall (p :: Pass). PprPrec -> LPat (GhcPass p) -> LPat (GhcPass p)
parenthesizePat PprPrec
opPrec LPat GhcPs
p2') }
                            -- See Note [Operator association]
cvtp (UInfixP p1 :: Pat
p1 s :: Name
s p2 :: Pat
p2) = do { LPat GhcPs
p1' <- Pat -> CvtM (LPat GhcPs)
cvtPat Pat
p1; LPat GhcPs -> Name -> Pat -> CvtM (LPat GhcPs)
cvtOpAppP LPat GhcPs
p1' Name
s Pat
p2 } -- Note [Converting UInfix]
cvtp (ParensP p :: Pat
p)       = do { LPat GhcPs
p' <- Pat -> CvtM (LPat GhcPs)
cvtPat Pat
p;
                            ; case LPat GhcPs -> SrcSpanLess (LPat GhcPs)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LPat GhcPs
p' of  -- may be wrapped ConPatIn
                                ParPat {} -> LPat GhcPs -> CvtM (LPat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LPat GhcPs -> CvtM (LPat GhcPs))
-> LPat GhcPs -> CvtM (LPat GhcPs)
forall a b. (a -> b) -> a -> b
$ LPat GhcPs -> SrcSpanLess (LPat GhcPs)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LPat GhcPs
p'
                                _         -> LPat GhcPs -> CvtM (LPat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LPat GhcPs -> CvtM (LPat GhcPs))
-> LPat GhcPs -> CvtM (LPat GhcPs)
forall a b. (a -> b) -> a -> b
$ XParPat GhcPs -> LPat GhcPs -> LPat GhcPs
forall p. XParPat p -> LPat p -> LPat p
ParPat XParPat GhcPs
NoExt
noExt LPat GhcPs
p' }
cvtp (TildeP p :: Pat
p)        = do { LPat GhcPs
p' <- Pat -> CvtM (LPat GhcPs)
cvtPat Pat
p; LPat GhcPs -> CvtM (LPat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LPat GhcPs -> CvtM (LPat GhcPs))
-> LPat GhcPs -> CvtM (LPat GhcPs)
forall a b. (a -> b) -> a -> b
$ XLazyPat GhcPs -> LPat GhcPs -> LPat GhcPs
forall p. XLazyPat p -> LPat p -> LPat p
LazyPat XLazyPat GhcPs
NoExt
noExt LPat GhcPs
p' }
cvtp (BangP p :: Pat
p)         = do { LPat GhcPs
p' <- Pat -> CvtM (LPat GhcPs)
cvtPat Pat
p; LPat GhcPs -> CvtM (LPat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LPat GhcPs -> CvtM (LPat GhcPs))
-> LPat GhcPs -> CvtM (LPat GhcPs)
forall a b. (a -> b) -> a -> b
$ XBangPat GhcPs -> LPat GhcPs -> LPat GhcPs
forall p. XBangPat p -> LPat p -> LPat p
BangPat XBangPat GhcPs
NoExt
noExt LPat GhcPs
p' }
cvtp (TH.AsP s :: Name
s p :: Pat
p)      = do { Located RdrName
s' <- Name -> CvtM (Located RdrName)
vNameL Name
s; LPat GhcPs
p' <- Pat -> CvtM (LPat GhcPs)
cvtPat Pat
p
                            ; LPat GhcPs -> CvtM (LPat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LPat GhcPs -> CvtM (LPat GhcPs))
-> LPat GhcPs -> CvtM (LPat GhcPs)
forall a b. (a -> b) -> a -> b
$ XAsPat GhcPs -> Located (IdP GhcPs) -> LPat GhcPs -> LPat GhcPs
forall p. XAsPat p -> Located (IdP p) -> LPat p -> LPat p
AsPat XAsPat GhcPs
NoExt
noExt Located RdrName
Located (IdP GhcPs)
s' LPat GhcPs
p' }
cvtp TH.WildP          = LPat GhcPs -> CvtM (LPat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LPat GhcPs -> CvtM (LPat GhcPs))
-> LPat GhcPs -> CvtM (LPat GhcPs)
forall a b. (a -> b) -> a -> b
$ XWildPat GhcPs -> LPat GhcPs
forall p. XWildPat p -> LPat p
WildPat XWildPat GhcPs
NoExt
noExt
cvtp (RecP c :: Name
c fs :: [FieldPat]
fs)       = do { Located RdrName
c' <- Name -> CvtM (Located RdrName)
cNameL Name
c; [LHsRecField GhcPs (LPat GhcPs)]
fs' <- (FieldPat -> CvtM (LHsRecField GhcPs (LPat GhcPs)))
-> [FieldPat] -> CvtM [LHsRecField GhcPs (LPat GhcPs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FieldPat -> CvtM (LHsRecField GhcPs (LPat GhcPs))
cvtPatFld [FieldPat]
fs
                            ; LPat GhcPs -> CvtM (LPat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LPat GhcPs -> CvtM (LPat GhcPs))
-> LPat GhcPs -> CvtM (LPat GhcPs)
forall a b. (a -> b) -> a -> b
$ Located (IdP GhcPs) -> HsConPatDetails GhcPs -> LPat GhcPs
forall p. Located (IdP p) -> HsConPatDetails p -> LPat p
ConPatIn Located RdrName
Located (IdP GhcPs)
c'
                                     (HsConPatDetails GhcPs -> LPat GhcPs)
-> HsConPatDetails GhcPs -> LPat GhcPs
forall a b. (a -> b) -> a -> b
$ HsRecFields GhcPs (LPat GhcPs) -> HsConPatDetails GhcPs
forall arg rec. rec -> HsConDetails arg rec
Hs.RecCon ([LHsRecField GhcPs (LPat GhcPs)]
-> Maybe Int -> HsRecFields GhcPs (LPat GhcPs)
forall p arg. [LHsRecField p arg] -> Maybe Int -> HsRecFields p arg
HsRecFields [LHsRecField GhcPs (LPat GhcPs)]
fs' Maybe Int
forall a. Maybe a
Nothing) }
cvtp (ListP ps :: [Pat]
ps)        = do { [LPat GhcPs]
ps' <- [Pat] -> CvtM [LPat GhcPs]
cvtPats [Pat]
ps
                            ; LPat GhcPs -> CvtM (LPat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return
                                   (LPat GhcPs -> CvtM (LPat GhcPs))
-> LPat GhcPs -> CvtM (LPat GhcPs)
forall a b. (a -> b) -> a -> b
$ XListPat GhcPs -> [LPat GhcPs] -> LPat GhcPs
forall p. XListPat p -> [LPat p] -> LPat p
ListPat XListPat GhcPs
NoExt
noExt [LPat GhcPs]
ps'}
cvtp (SigP p :: Pat
p t :: Type
t)        = do { LPat GhcPs
p' <- Pat -> CvtM (LPat GhcPs)
cvtPat Pat
p; LHsType GhcPs
t' <- Type -> CvtM (LHsType GhcPs)
cvtType Type
t
                            ; LPat GhcPs -> CvtM (LPat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LPat GhcPs -> CvtM (LPat GhcPs))
-> LPat GhcPs -> CvtM (LPat GhcPs)
forall a b. (a -> b) -> a -> b
$ XSigPat GhcPs
-> LPat GhcPs -> LHsSigWcType (NoGhcTc GhcPs) -> LPat GhcPs
forall p. XSigPat p -> LPat p -> LHsSigWcType (NoGhcTc p) -> LPat p
SigPat XSigPat GhcPs
NoExt
noExt LPat GhcPs
p' (LHsType GhcPs -> LHsSigWcType GhcPs
mkLHsSigWcType LHsType GhcPs
t') }
cvtp (ViewP e :: Exp
e p :: Pat
p)       = do { LHsExpr GhcPs
e' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
e; LPat GhcPs
p' <- Pat -> CvtM (LPat GhcPs)
cvtPat Pat
p
                            ; LPat GhcPs -> CvtM (LPat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LPat GhcPs -> CvtM (LPat GhcPs))
-> LPat GhcPs -> CvtM (LPat GhcPs)
forall a b. (a -> b) -> a -> b
$ XViewPat GhcPs -> LHsExpr GhcPs -> LPat GhcPs -> LPat GhcPs
forall p. XViewPat p -> LHsExpr p -> LPat p -> LPat p
ViewPat XViewPat GhcPs
NoExt
noExt LHsExpr GhcPs
e' LPat GhcPs
p'}

cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField GhcPs (LPat GhcPs))
cvtPatFld :: FieldPat -> CvtM (LHsRecField GhcPs (LPat GhcPs))
cvtPatFld (s :: Name
s,p :: Pat
p)
  = do  { (Located RdrName -> Located (SrcSpanLess (Located RdrName))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L ls :: SrcSpan
ls s' :: SrcSpanLess (Located RdrName)
s') <- Name -> CvtM (Located RdrName)
vNameL Name
s
        ; LPat GhcPs
p' <- Pat -> CvtM (LPat GhcPs)
cvtPat Pat
p
        ; LHsRecField GhcPs (LPat GhcPs)
-> CvtM (LHsRecField GhcPs (LPat GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanLess (LHsRecField GhcPs (LPat GhcPs))
-> LHsRecField GhcPs (LPat GhcPs)
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LHsRecField GhcPs (LPat GhcPs))
 -> LHsRecField GhcPs (LPat GhcPs))
-> SrcSpanLess (LHsRecField GhcPs (LPat GhcPs))
-> LHsRecField GhcPs (LPat GhcPs)
forall a b. (a -> b) -> a -> b
$ HsRecField :: forall id arg. Located id -> arg -> Bool -> HsRecField' id arg
HsRecField { hsRecFieldLbl :: LFieldOcc GhcPs
hsRecFieldLbl
                                         = SrcSpan -> SrcSpanLess (LFieldOcc GhcPs) -> LFieldOcc GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
ls (SrcSpanLess (LFieldOcc GhcPs) -> LFieldOcc GhcPs)
-> SrcSpanLess (LFieldOcc GhcPs) -> LFieldOcc GhcPs
forall a b. (a -> b) -> a -> b
$ Located RdrName -> FieldOcc GhcPs
mkFieldOcc (SrcSpan -> SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
ls SrcSpanLess (Located RdrName)
s')
                                     , hsRecFieldArg :: LPat GhcPs
hsRecFieldArg = LPat GhcPs
p'
                                     , hsRecPun :: Bool
hsRecPun      = Bool
False}) }

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

See the @cvtOpApp@ documentation for how this function works.
-}
cvtOpAppP :: Hs.LPat GhcPs -> TH.Name -> TH.Pat -> CvtM (Hs.Pat GhcPs)
cvtOpAppP :: LPat GhcPs -> Name -> Pat -> CvtM (LPat GhcPs)
cvtOpAppP x :: LPat GhcPs
x op1 :: Name
op1 (UInfixP y :: Pat
y op2 :: Name
op2 z :: Pat
z)
  = do { LPat GhcPs
l <- CvtM (SrcSpanLess (LPat GhcPs)) -> CvtM (LPat GhcPs)
forall a. HasSrcSpan a => CvtM (SrcSpanLess a) -> CvtM a
wrapL (CvtM (SrcSpanLess (LPat GhcPs)) -> CvtM (LPat GhcPs))
-> CvtM (SrcSpanLess (LPat GhcPs)) -> CvtM (LPat GhcPs)
forall a b. (a -> b) -> a -> b
$ LPat GhcPs -> Name -> Pat -> CvtM (LPat GhcPs)
cvtOpAppP LPat GhcPs
x Name
op1 Pat
y
       ; LPat GhcPs -> Name -> Pat -> CvtM (LPat GhcPs)
cvtOpAppP LPat GhcPs
l Name
op2 Pat
z }
cvtOpAppP x :: LPat GhcPs
x op :: Name
op y :: Pat
y
  = do { Located RdrName
op' <- Name -> CvtM (Located RdrName)
cNameL Name
op
       ; LPat GhcPs
y' <- Pat -> CvtM (LPat GhcPs)
cvtPat Pat
y
       ; LPat GhcPs -> CvtM (LPat GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (IdP GhcPs) -> HsConPatDetails GhcPs -> LPat GhcPs
forall p. Located (IdP p) -> HsConPatDetails p -> LPat p
ConPatIn Located RdrName
Located (IdP GhcPs)
op' (LPat GhcPs -> LPat GhcPs -> HsConPatDetails GhcPs
forall arg rec. arg -> arg -> HsConDetails arg rec
InfixCon LPat GhcPs
x LPat GhcPs
y')) }

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

cvtTvs :: [TH.TyVarBndr] -> CvtM (LHsQTyVars GhcPs)
cvtTvs :: [TyVarBndr] -> CvtM (LHsQTyVars GhcPs)
cvtTvs tvs :: [TyVarBndr]
tvs = do { [LHsTyVarBndr GhcPs]
tvs' <- (TyVarBndr -> CvtM (LHsTyVarBndr GhcPs))
-> [TyVarBndr] -> CvtM [LHsTyVarBndr GhcPs]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TyVarBndr -> CvtM (LHsTyVarBndr GhcPs)
cvt_tv [TyVarBndr]
tvs; LHsQTyVars GhcPs -> CvtM (LHsQTyVars GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return ([LHsTyVarBndr GhcPs] -> LHsQTyVars GhcPs
mkHsQTvs [LHsTyVarBndr GhcPs]
tvs') }

cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr GhcPs)
cvt_tv :: TyVarBndr -> CvtM (LHsTyVarBndr GhcPs)
cvt_tv (TH.PlainTV nm :: Name
nm)
  = do { Located RdrName
nm' <- Name -> CvtM (Located RdrName)
tNameL Name
nm
       ; SrcSpanLess (LHsTyVarBndr GhcPs) -> CvtM (LHsTyVarBndr GhcPs)
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM a
returnL (SrcSpanLess (LHsTyVarBndr GhcPs) -> CvtM (LHsTyVarBndr GhcPs))
-> SrcSpanLess (LHsTyVarBndr GhcPs) -> CvtM (LHsTyVarBndr GhcPs)
forall a b. (a -> b) -> a -> b
$ XUserTyVar GhcPs -> Located (IdP GhcPs) -> HsTyVarBndr GhcPs
forall pass.
XUserTyVar pass -> Located (IdP pass) -> HsTyVarBndr pass
UserTyVar XUserTyVar GhcPs
NoExt
noExt Located RdrName
Located (IdP GhcPs)
nm' }
cvt_tv (TH.KindedTV nm :: Name
nm ki :: Type
ki)
  = do { Located RdrName
nm' <- Name -> CvtM (Located RdrName)
tNameL Name
nm
       ; LHsType GhcPs
ki' <- Type -> CvtM (LHsType GhcPs)
cvtKind Type
ki
       ; SrcSpanLess (LHsTyVarBndr GhcPs) -> CvtM (LHsTyVarBndr GhcPs)
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM a
returnL (SrcSpanLess (LHsTyVarBndr GhcPs) -> CvtM (LHsTyVarBndr GhcPs))
-> SrcSpanLess (LHsTyVarBndr GhcPs) -> CvtM (LHsTyVarBndr GhcPs)
forall a b. (a -> b) -> a -> b
$ XKindedTyVar GhcPs
-> Located (IdP GhcPs) -> LHsType GhcPs -> HsTyVarBndr GhcPs
forall pass.
XKindedTyVar pass
-> Located (IdP pass) -> LHsKind pass -> HsTyVarBndr pass
KindedTyVar XKindedTyVar GhcPs
NoExt
noExt Located RdrName
Located (IdP GhcPs)
nm' LHsType GhcPs
ki' }

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

cvtContext :: TH.Cxt -> CvtM (LHsContext GhcPs)
cvtContext :: Cxt -> CvtM (LHsContext GhcPs)
cvtContext tys :: Cxt
tys = do { [LHsType GhcPs]
preds' <- (Type -> CvtM (LHsType GhcPs)) -> Cxt -> CvtM [LHsType GhcPs]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> CvtM (LHsType GhcPs)
cvtPred Cxt
tys; SrcSpanLess (LHsContext GhcPs) -> CvtM (LHsContext GhcPs)
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM a
returnL [LHsType GhcPs]
SrcSpanLess (LHsContext GhcPs)
preds' }

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

cvtDerivClause :: TH.DerivClause
               -> CvtM (LHsDerivingClause GhcPs)
cvtDerivClause :: DerivClause -> CvtM (LHsDerivingClause GhcPs)
cvtDerivClause (TH.DerivClause ds :: Maybe DerivStrategy
ds ctxt :: Cxt
ctxt)
  = do { GenLocated SrcSpan [LHsSigType GhcPs]
ctxt' <- ([LHsType GhcPs] -> [LHsSigType GhcPs])
-> LHsContext GhcPs -> GenLocated SrcSpan [LHsSigType GhcPs]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((LHsType GhcPs -> LHsSigType GhcPs)
-> [LHsType GhcPs] -> [LHsSigType GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map LHsType GhcPs -> LHsSigType GhcPs
mkLHsSigType) (LHsContext GhcPs -> GenLocated SrcSpan [LHsSigType GhcPs])
-> CvtM (LHsContext GhcPs)
-> CvtM (GenLocated SrcSpan [LHsSigType GhcPs])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cxt -> CvtM (LHsContext GhcPs)
cvtContext Cxt
ctxt
       ; Maybe (LDerivStrategy GhcPs)
ds'   <- (DerivStrategy -> CvtM (LDerivStrategy GhcPs))
-> Maybe DerivStrategy -> CvtM (Maybe (LDerivStrategy GhcPs))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse DerivStrategy -> CvtM (LDerivStrategy GhcPs)
cvtDerivStrategy Maybe DerivStrategy
ds
       ; SrcSpanLess (LHsDerivingClause GhcPs)
-> CvtM (LHsDerivingClause GhcPs)
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM a
returnL (SrcSpanLess (LHsDerivingClause GhcPs)
 -> CvtM (LHsDerivingClause GhcPs))
-> SrcSpanLess (LHsDerivingClause GhcPs)
-> CvtM (LHsDerivingClause GhcPs)
forall a b. (a -> b) -> a -> b
$ XCHsDerivingClause GhcPs
-> Maybe (LDerivStrategy GhcPs)
-> GenLocated SrcSpan [LHsSigType GhcPs]
-> HsDerivingClause GhcPs
forall pass.
XCHsDerivingClause pass
-> Maybe (LDerivStrategy pass)
-> Located [LHsSigType pass]
-> HsDerivingClause pass
HsDerivingClause XCHsDerivingClause GhcPs
NoExt
noExt Maybe (LDerivStrategy GhcPs)
ds' GenLocated SrcSpan [LHsSigType GhcPs]
ctxt' }

cvtDerivStrategy :: TH.DerivStrategy -> CvtM (Hs.LDerivStrategy GhcPs)
cvtDerivStrategy :: DerivStrategy -> CvtM (LDerivStrategy GhcPs)
cvtDerivStrategy TH.StockStrategy    = SrcSpanLess (LDerivStrategy GhcPs) -> CvtM (LDerivStrategy GhcPs)
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM a
returnL SrcSpanLess (LDerivStrategy GhcPs)
forall pass. DerivStrategy pass
Hs.StockStrategy
cvtDerivStrategy TH.AnyclassStrategy = SrcSpanLess (LDerivStrategy GhcPs) -> CvtM (LDerivStrategy GhcPs)
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM a
returnL SrcSpanLess (LDerivStrategy GhcPs)
forall pass. DerivStrategy pass
Hs.AnyclassStrategy
cvtDerivStrategy TH.NewtypeStrategy  = SrcSpanLess (LDerivStrategy GhcPs) -> CvtM (LDerivStrategy GhcPs)
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM a
returnL SrcSpanLess (LDerivStrategy GhcPs)
forall pass. DerivStrategy pass
Hs.NewtypeStrategy
cvtDerivStrategy (TH.ViaStrategy ty :: Type
ty) = do
  LHsType GhcPs
ty' <- Type -> CvtM (LHsType GhcPs)
cvtType Type
ty
  SrcSpanLess (LDerivStrategy GhcPs) -> CvtM (LDerivStrategy GhcPs)
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM a
returnL (SrcSpanLess (LDerivStrategy GhcPs) -> CvtM (LDerivStrategy GhcPs))
-> SrcSpanLess (LDerivStrategy GhcPs)
-> CvtM (LDerivStrategy GhcPs)
forall a b. (a -> b) -> a -> b
$ XViaStrategy GhcPs -> DerivStrategy GhcPs
forall pass. XViaStrategy pass -> DerivStrategy pass
Hs.ViaStrategy (LHsType GhcPs -> LHsSigType GhcPs
mkLHsSigType LHsType GhcPs
ty')

cvtType :: TH.Type -> CvtM (LHsType GhcPs)
cvtType :: Type -> CvtM (LHsType GhcPs)
cvtType = String -> Type -> CvtM (LHsType GhcPs)
cvtTypeKind "type"

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

       ; case Type
head_ty of
           TupleT n :: Int
n
            | Just normals :: [LHsType GhcPs]
normals <- Maybe [LHsType GhcPs]
m_normals
            , [LHsType GhcPs]
normals [LHsType GhcPs] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthIs` Int
n         -- Saturated
               -> if Int
nInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==1 then LHsType GhcPs -> CvtM (LHsType GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return ([LHsType GhcPs] -> LHsType GhcPs
forall a. [a] -> a
head [LHsType GhcPs]
normals) -- Singleton tuples treated
                                                     -- like nothing (ie just parens)
                          else SrcSpanLess (LHsType GhcPs) -> CvtM (LHsType GhcPs)
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM a
returnL (XTupleTy GhcPs -> HsTupleSort -> [LHsType GhcPs] -> HsType GhcPs
forall pass.
XTupleTy pass -> HsTupleSort -> [LHsType pass] -> HsType pass
HsTupleTy XTupleTy GhcPs
NoExt
noExt
                                        HsTupleSort
HsBoxedOrConstraintTuple [LHsType GhcPs]
normals)
            | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 1
               -> MsgDoc -> CvtM (LHsType GhcPs)
forall a. MsgDoc -> CvtM a
failWith (PtrString -> MsgDoc
ptext (String -> PtrString
sLit ("Illegal 1-tuple " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ty_str String -> String -> String
forall a. [a] -> [a] -> [a]
++ " constructor")))
            | Bool
otherwise
            -> HsType GhcPs -> HsTyPats GhcPs -> CvtM (LHsType GhcPs)
mk_apps
               (XTyVar GhcPs
-> PromotionFlag -> Located (IdP GhcPs) -> HsType GhcPs
forall pass.
XTyVar pass -> PromotionFlag -> Located (IdP pass) -> HsType pass
HsTyVar XTyVar GhcPs
NoExt
noExt PromotionFlag
NotPromoted (SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (TyCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName (Boxity -> Int -> TyCon
tupleTyCon Boxity
Boxed Int
n))))
               HsTyPats GhcPs
tys'
           UnboxedTupleT n :: Int
n
             | Just normals :: [LHsType GhcPs]
normals <- Maybe [LHsType GhcPs]
m_normals
             , [LHsType GhcPs]
normals [LHsType GhcPs] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthIs` Int
n               -- Saturated
             -> SrcSpanLess (LHsType GhcPs) -> CvtM (LHsType GhcPs)
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM a
returnL (XTupleTy GhcPs -> HsTupleSort -> [LHsType GhcPs] -> HsType GhcPs
forall pass.
XTupleTy pass -> HsTupleSort -> [LHsType pass] -> HsType pass
HsTupleTy XTupleTy GhcPs
NoExt
noExt HsTupleSort
HsUnboxedTuple [LHsType GhcPs]
normals)
             | Bool
otherwise
             -> HsType GhcPs -> HsTyPats GhcPs -> CvtM (LHsType GhcPs)
mk_apps
                (XTyVar GhcPs
-> PromotionFlag -> Located (IdP GhcPs) -> HsType GhcPs
forall pass.
XTyVar pass -> PromotionFlag -> Located (IdP pass) -> HsType pass
HsTyVar XTyVar GhcPs
NoExt
noExt PromotionFlag
NotPromoted (SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (TyCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName (Boxity -> Int -> TyCon
tupleTyCon Boxity
Unboxed Int
n))))
                HsTyPats GhcPs
tys'
           UnboxedSumT n :: Int
n
             | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 2
            -> MsgDoc -> CvtM (LHsType GhcPs)
forall a. MsgDoc -> CvtM a
failWith (MsgDoc -> CvtM (LHsType GhcPs)) -> MsgDoc -> CvtM (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$
                   [MsgDoc] -> MsgDoc
vcat [ String -> MsgDoc
text "Illegal sum arity:" MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text (Int -> String
forall a. Show a => a -> String
show Int
n)
                        , Int -> MsgDoc -> MsgDoc
nest 2 (MsgDoc -> MsgDoc) -> MsgDoc -> MsgDoc
forall a b. (a -> b) -> a -> b
$
                            String -> MsgDoc
text "Sums must have an arity of at least 2" ]
             | Just normals :: [LHsType GhcPs]
normals <- Maybe [LHsType GhcPs]
m_normals
             , [LHsType GhcPs]
normals [LHsType GhcPs] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthIs` Int
n -- Saturated
             -> SrcSpanLess (LHsType GhcPs) -> CvtM (LHsType GhcPs)
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM a
returnL (XSumTy GhcPs -> [LHsType GhcPs] -> HsType GhcPs
forall pass. XSumTy pass -> [LHsType pass] -> HsType pass
HsSumTy XSumTy GhcPs
NoExt
noExt [LHsType GhcPs]
normals)
             | Bool
otherwise
             -> HsType GhcPs -> HsTyPats GhcPs -> CvtM (LHsType GhcPs)
mk_apps
                (XTyVar GhcPs
-> PromotionFlag -> Located (IdP GhcPs) -> HsType GhcPs
forall pass.
XTyVar pass -> PromotionFlag -> Located (IdP pass) -> HsType pass
HsTyVar XTyVar GhcPs
NoExt
noExt PromotionFlag
NotPromoted (SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (TyCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName (Int -> TyCon
sumTyCon Int
n))))
                HsTyPats GhcPs
tys'
           ArrowT
             | Just normals :: [LHsType GhcPs]
normals <- Maybe [LHsType GhcPs]
m_normals
             , [x' :: LHsType GhcPs
x',y' :: LHsType GhcPs
y'] <- [LHsType GhcPs]
normals -> do
                 LHsType GhcPs
x'' <- case LHsType GhcPs -> SrcSpanLess (LHsType GhcPs)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsType GhcPs
x' of
                          HsFunTy{}    -> SrcSpanLess (LHsType GhcPs) -> CvtM (LHsType GhcPs)
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM a
returnL (XParTy GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy XParTy GhcPs
NoExt
noExt LHsType GhcPs
x')
                          HsForAllTy{} -> SrcSpanLess (LHsType GhcPs) -> CvtM (LHsType GhcPs)
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM a
returnL (XParTy GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy XParTy GhcPs
NoExt
noExt LHsType GhcPs
x') -- #14646
                          HsQualTy{}   -> SrcSpanLess (LHsType GhcPs) -> CvtM (LHsType GhcPs)
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM a
returnL (XParTy GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy XParTy GhcPs
NoExt
noExt LHsType GhcPs
x') -- #15324
                          _            -> LHsType GhcPs -> CvtM (LHsType GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsType GhcPs -> CvtM (LHsType GhcPs))
-> LHsType GhcPs -> CvtM (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$
                                          PprPrec -> LHsType GhcPs -> LHsType GhcPs
forall (p :: Pass).
PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)
parenthesizeHsType PprPrec
sigPrec LHsType GhcPs
x'
                 let y'' :: LHsType GhcPs
y'' = PprPrec -> LHsType GhcPs -> LHsType GhcPs
forall (p :: Pass).
PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)
parenthesizeHsType PprPrec
sigPrec LHsType GhcPs
y'
                 SrcSpanLess (LHsType GhcPs) -> CvtM (LHsType GhcPs)
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM a
returnL (XFunTy GhcPs -> LHsType GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass.
XFunTy pass -> LHsType pass -> LHsType pass -> HsType pass
HsFunTy XFunTy GhcPs
NoExt
noExt LHsType GhcPs
x'' LHsType GhcPs
y'')
             | Bool
otherwise
             -> HsType GhcPs -> HsTyPats GhcPs -> CvtM (LHsType GhcPs)
mk_apps
                (XTyVar GhcPs
-> PromotionFlag -> Located (IdP GhcPs) -> HsType GhcPs
forall pass.
XTyVar pass -> PromotionFlag -> Located (IdP pass) -> HsType pass
HsTyVar XTyVar GhcPs
NoExt
noExt PromotionFlag
NotPromoted (SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (TyCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName TyCon
funTyCon)))
                HsTyPats GhcPs
tys'
           ListT
             | Just normals :: [LHsType GhcPs]
normals <- Maybe [LHsType GhcPs]
m_normals
             , [x' :: LHsType GhcPs
x'] <- [LHsType GhcPs]
normals -> do
                SrcSpanLess (LHsType GhcPs) -> CvtM (LHsType GhcPs)
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM a
returnL (XListTy GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass. XListTy pass -> LHsType pass -> HsType pass
HsListTy XListTy GhcPs
NoExt
noExt LHsType GhcPs
x')
             | Bool
otherwise
             -> HsType GhcPs -> HsTyPats GhcPs -> CvtM (LHsType GhcPs)
mk_apps
                (XTyVar GhcPs
-> PromotionFlag -> Located (IdP GhcPs) -> HsType GhcPs
forall pass.
XTyVar pass -> PromotionFlag -> Located (IdP pass) -> HsType pass
HsTyVar XTyVar GhcPs
NoExt
noExt PromotionFlag
NotPromoted (SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (TyCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName TyCon
listTyCon)))
                HsTyPats GhcPs
tys'

           VarT nm :: Name
nm -> do { Located RdrName
nm' <- Name -> CvtM (Located RdrName)
tNameL Name
nm
                         ; HsType GhcPs -> HsTyPats GhcPs -> CvtM (LHsType GhcPs)
mk_apps (XTyVar GhcPs
-> PromotionFlag -> Located (IdP GhcPs) -> HsType GhcPs
forall pass.
XTyVar pass -> PromotionFlag -> Located (IdP pass) -> HsType pass
HsTyVar XTyVar GhcPs
NoExt
noExt PromotionFlag
NotPromoted Located RdrName
Located (IdP GhcPs)
nm') HsTyPats GhcPs
tys' }
           ConT nm :: Name
nm -> do { RdrName
nm' <- Name -> CvtM RdrName
tconName Name
nm
                         ; -- ConT can contain both data constructor (i.e.,
                           -- promoted) names and other (i.e, unpromoted)
                           -- names, as opposed to PromotedT, which can only
                           -- contain data constructor names. See #15572.
                           let prom :: PromotionFlag
prom = if RdrName -> Bool
isRdrDataCon RdrName
nm'
                                      then PromotionFlag
IsPromoted
                                      else PromotionFlag
NotPromoted
                         ; HsType GhcPs -> HsTyPats GhcPs -> CvtM (LHsType GhcPs)
mk_apps (XTyVar GhcPs
-> PromotionFlag -> Located (IdP GhcPs) -> HsType GhcPs
forall pass.
XTyVar pass -> PromotionFlag -> Located (IdP pass) -> HsType pass
HsTyVar XTyVar GhcPs
NoExt
noExt PromotionFlag
prom (SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (Located RdrName)
RdrName
nm')) HsTyPats GhcPs
tys'}

           ForallT tvs :: [TyVarBndr]
tvs cxt :: Cxt
cxt ty :: Type
ty
             | HsTyPats GhcPs -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null HsTyPats GhcPs
tys'
             -> do { LHsQTyVars GhcPs
tvs' <- [TyVarBndr] -> CvtM (LHsQTyVars GhcPs)
cvtTvs [TyVarBndr]
tvs
                   ; LHsContext GhcPs
cxt' <- Cxt -> CvtM (LHsContext GhcPs)
cvtContext Cxt
cxt
                   ; let pcxt :: LHsContext GhcPs
pcxt = PprPrec -> LHsContext GhcPs -> LHsContext GhcPs
forall (p :: Pass).
PprPrec -> LHsContext (GhcPass p) -> LHsContext (GhcPass p)
parenthesizeHsContext PprPrec
funPrec LHsContext GhcPs
cxt'
                   ; LHsType GhcPs
ty'  <- Type -> CvtM (LHsType GhcPs)
cvtType Type
ty
                   ; SrcSpan
loc <- CvtM SrcSpan
getL
                   ; let hs_ty :: LHsType GhcPs
hs_ty  = [TyVarBndr]
-> SrcSpan -> LHsQTyVars GhcPs -> LHsType GhcPs -> LHsType GhcPs
mkHsForAllTy [TyVarBndr]
tvs SrcSpan
loc LHsQTyVars GhcPs
tvs' LHsType GhcPs
rho_ty
                         rho_ty :: LHsType GhcPs
rho_ty = Cxt
-> SrcSpan -> LHsContext GhcPs -> LHsType GhcPs -> LHsType GhcPs
mkHsQualTy Cxt
cxt SrcSpan
loc LHsContext GhcPs
pcxt LHsType GhcPs
ty'

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

           SigT ty :: Type
ty ki :: Type
ki
             -> do { LHsType GhcPs
ty' <- Type -> CvtM (LHsType GhcPs)
cvtType Type
ty
                   ; LHsType GhcPs
ki' <- Type -> CvtM (LHsType GhcPs)
cvtKind Type
ki
                   ; HsType GhcPs -> HsTyPats GhcPs -> CvtM (LHsType GhcPs)
mk_apps (XKindSig GhcPs -> LHsType GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass.
XKindSig pass -> LHsType pass -> LHsType pass -> HsType pass
HsKindSig XKindSig GhcPs
NoExt
noExt LHsType GhcPs
ty' LHsType GhcPs
ki') HsTyPats GhcPs
tys'
                   }

           LitT lit :: TyLit
lit
             -> HsType GhcPs -> HsTyPats GhcPs -> CvtM (LHsType GhcPs)
mk_apps (XTyLit GhcPs -> HsTyLit -> HsType GhcPs
forall pass. XTyLit pass -> HsTyLit -> HsType pass
HsTyLit XTyLit GhcPs
NoExt
noExt (TyLit -> HsTyLit
cvtTyLit TyLit
lit)) HsTyPats GhcPs
tys'

           WildCardT
             -> HsType GhcPs -> HsTyPats GhcPs -> CvtM (LHsType GhcPs)
mk_apps HsType GhcPs
mkAnonWildCardTy HsTyPats GhcPs
tys'

           InfixT t1 :: Type
t1 s :: Name
s t2 :: Type
t2
             -> do { RdrName
s'  <- Name -> CvtM RdrName
tconName Name
s
                   ; LHsType GhcPs
t1' <- Type -> CvtM (LHsType GhcPs)
cvtType Type
t1
                   ; LHsType GhcPs
t2' <- Type -> CvtM (LHsType GhcPs)
cvtType Type
t2
                   ; HsType GhcPs -> HsTyPats GhcPs -> CvtM (LHsType GhcPs)
mk_apps
                      (XTyVar GhcPs
-> PromotionFlag -> Located (IdP GhcPs) -> HsType GhcPs
forall pass.
XTyVar pass -> PromotionFlag -> Located (IdP pass) -> HsType pass
HsTyVar XTyVar GhcPs
NoExt
noExt PromotionFlag
NotPromoted (SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (Located RdrName)
RdrName
s'))
                      ([LHsType GhcPs -> LHsTypeArg GhcPs
forall tm ty. tm -> HsArg tm ty
HsValArg LHsType GhcPs
t1', LHsType GhcPs -> LHsTypeArg GhcPs
forall tm ty. tm -> HsArg tm ty
HsValArg LHsType GhcPs
t2'] HsTyPats GhcPs -> HsTyPats GhcPs -> HsTyPats GhcPs
forall a. [a] -> [a] -> [a]
++ HsTyPats GhcPs
tys')
                   }

           UInfixT t1 :: Type
t1 s :: Name
s t2 :: Type
t2
             -> do { LHsType GhcPs
t2' <- Type -> CvtM (LHsType GhcPs)
cvtType Type
t2
                   ; LHsType GhcPs
t <- Type -> Name -> LHsType GhcPs -> CvtM (LHsType GhcPs)
cvtOpAppT Type
t1 Name
s LHsType GhcPs
t2'
                   ; HsType GhcPs -> HsTyPats GhcPs -> CvtM (LHsType GhcPs)
mk_apps (LHsType GhcPs -> SrcSpanLess (LHsType GhcPs)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsType GhcPs
t) HsTyPats GhcPs
tys'
                   } -- Note [Converting UInfix]

           ParensT t :: Type
t
             -> do { LHsType GhcPs
t' <- Type -> CvtM (LHsType GhcPs)
cvtType Type
t
                   ; HsType GhcPs -> HsTyPats GhcPs -> CvtM (LHsType GhcPs)
mk_apps (XParTy GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy XParTy GhcPs
NoExt
noExt LHsType GhcPs
t') HsTyPats GhcPs
tys'
                   }

           PromotedT nm :: Name
nm -> do { RdrName
nm' <- Name -> CvtM RdrName
cName Name
nm
                              ; HsType GhcPs -> HsTyPats GhcPs -> CvtM (LHsType GhcPs)
mk_apps (XTyVar GhcPs
-> PromotionFlag -> Located (IdP GhcPs) -> HsType GhcPs
forall pass.
XTyVar pass -> PromotionFlag -> Located (IdP pass) -> HsType pass
HsTyVar XTyVar GhcPs
NoExt
noExt PromotionFlag
IsPromoted (SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (Located RdrName)
RdrName
nm'))
                                        HsTyPats GhcPs
tys' }
                 -- Promoted data constructor; hence cName

           PromotedTupleT n :: Int
n
              | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 1
              -> MsgDoc -> CvtM (LHsType GhcPs)
forall a. MsgDoc -> CvtM a
failWith (PtrString -> MsgDoc
ptext (String -> PtrString
sLit ("Illegal promoted 1-tuple " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ty_str)))
              | Just normals :: [LHsType GhcPs]
normals <- Maybe [LHsType GhcPs]
m_normals
              , [LHsType GhcPs]
normals [LHsType GhcPs] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthIs` Int
n   -- Saturated
              -> SrcSpanLess (LHsType GhcPs) -> CvtM (LHsType GhcPs)
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM a
returnL (XExplicitTupleTy GhcPs -> [LHsType GhcPs] -> HsType GhcPs
forall pass. XExplicitTupleTy pass -> [LHsType pass] -> HsType pass
HsExplicitTupleTy XExplicitTupleTy GhcPs
NoExt
noExt [LHsType GhcPs]
normals)
              | Bool
otherwise
              -> HsType GhcPs -> HsTyPats GhcPs -> CvtM (LHsType GhcPs)
mk_apps
                 (XTyVar GhcPs
-> PromotionFlag -> Located (IdP GhcPs) -> HsType GhcPs
forall pass.
XTyVar pass -> PromotionFlag -> Located (IdP pass) -> HsType pass
HsTyVar XTyVar GhcPs
NoExt
noExt PromotionFlag
IsPromoted (SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName (Boxity -> Int -> DataCon
tupleDataCon Boxity
Boxed Int
n))))
                 HsTyPats GhcPs
tys'

           PromotedNilT
             -> HsType GhcPs -> HsTyPats GhcPs -> CvtM (LHsType GhcPs)
mk_apps (XExplicitListTy GhcPs
-> PromotionFlag -> [LHsType GhcPs] -> HsType GhcPs
forall pass.
XExplicitListTy pass
-> PromotionFlag -> [LHsType pass] -> HsType pass
HsExplicitListTy XExplicitListTy GhcPs
NoExt
noExt PromotionFlag
IsPromoted []) HsTyPats GhcPs
tys'

           PromotedConsT  -- See Note [Representing concrete syntax in types]
                          -- in Language.Haskell.TH.Syntax
              | Just normals :: [LHsType GhcPs]
normals <- Maybe [LHsType GhcPs]
m_normals
              , [ty1 :: LHsType GhcPs
ty1, LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (HsExplicitListTy _ ip tys2)] <- [LHsType GhcPs]
normals
              -> do
                  SrcSpanLess (LHsType GhcPs) -> CvtM (LHsType GhcPs)
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM a
returnL (XExplicitListTy GhcPs
-> PromotionFlag -> [LHsType GhcPs] -> HsType GhcPs
forall pass.
XExplicitListTy pass
-> PromotionFlag -> [LHsType pass] -> HsType pass
HsExplicitListTy XExplicitListTy GhcPs
NoExt
noExt PromotionFlag
ip (LHsType GhcPs
ty1LHsType GhcPs -> [LHsType GhcPs] -> [LHsType GhcPs]
forall a. a -> [a] -> [a]
:[LHsType GhcPs]
tys2))
              | Bool
otherwise
              -> HsType GhcPs -> HsTyPats GhcPs -> CvtM (LHsType GhcPs)
mk_apps
                 (XTyVar GhcPs
-> PromotionFlag -> Located (IdP GhcPs) -> HsType GhcPs
forall pass.
XTyVar pass -> PromotionFlag -> Located (IdP pass) -> HsType pass
HsTyVar XTyVar GhcPs
NoExt
noExt PromotionFlag
IsPromoted (SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
consDataCon)))
                 HsTyPats GhcPs
tys'

           StarT
             -> HsType GhcPs -> HsTyPats GhcPs -> CvtM (LHsType GhcPs)
mk_apps
                (XTyVar GhcPs
-> PromotionFlag -> Located (IdP GhcPs) -> HsType GhcPs
forall pass.
XTyVar pass -> PromotionFlag -> Located (IdP pass) -> HsType pass
HsTyVar XTyVar GhcPs
NoExt
noExt PromotionFlag
NotPromoted (SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (TyCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName TyCon
liftedTypeKindTyCon)))
                HsTyPats GhcPs
tys'

           ConstraintT
             -> HsType GhcPs -> HsTyPats GhcPs -> CvtM (LHsType GhcPs)
mk_apps
                (XTyVar GhcPs
-> PromotionFlag -> Located (IdP GhcPs) -> HsType GhcPs
forall pass.
XTyVar pass -> PromotionFlag -> Located (IdP pass) -> HsType pass
HsTyVar XTyVar GhcPs
NoExt
noExt PromotionFlag
NotPromoted (SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (TyCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName TyCon
constraintKindTyCon)))
                HsTyPats GhcPs
tys'

           EqualityT
             | Just normals :: [LHsType GhcPs]
normals <- Maybe [LHsType GhcPs]
m_normals
             , [x' :: LHsType GhcPs
x',y' :: LHsType GhcPs
y'] <- [LHsType GhcPs]
normals ->
                   let px :: LHsType GhcPs
px = PprPrec -> LHsType GhcPs -> LHsType GhcPs
forall (p :: Pass).
PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)
parenthesizeHsType PprPrec
opPrec LHsType GhcPs
x'
                       py :: LHsType GhcPs
py = PprPrec -> LHsType GhcPs -> LHsType GhcPs
forall (p :: Pass).
PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)
parenthesizeHsType PprPrec
opPrec LHsType GhcPs
y'
                   in SrcSpanLess (LHsType GhcPs) -> CvtM (LHsType GhcPs)
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM a
returnL (XOpTy GhcPs
-> LHsType GhcPs
-> Located (IdP GhcPs)
-> LHsType GhcPs
-> HsType GhcPs
forall pass.
XOpTy pass
-> LHsType pass
-> Located (IdP pass)
-> LHsType pass
-> HsType pass
HsOpTy XOpTy GhcPs
NoExt
noExt LHsType GhcPs
px (SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (Located RdrName)
RdrName
eqTyCon_RDR) LHsType GhcPs
py)
               -- The long-term goal is to remove the above case entirely and
               -- subsume it under the case for InfixT. See #15815, comment:6,
               -- for more details.

             | Bool
otherwise ->
                   HsType GhcPs -> HsTyPats GhcPs -> CvtM (LHsType GhcPs)
mk_apps (XTyVar GhcPs
-> PromotionFlag -> Located (IdP GhcPs) -> HsType GhcPs
forall pass.
XTyVar pass -> PromotionFlag -> Located (IdP pass) -> HsType pass
HsTyVar XTyVar GhcPs
NoExt
noExt PromotionFlag
NotPromoted
                            (SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (Located RdrName)
RdrName
eqTyCon_RDR)) HsTyPats GhcPs
tys'
           ImplicitParamT n :: String
n t :: Type
t
             -> do { Located HsIPName
n' <- CvtM (SrcSpanLess (Located HsIPName)) -> CvtM (Located HsIPName)
forall a. HasSrcSpan a => CvtM (SrcSpanLess a) -> CvtM a
wrapL (CvtM (SrcSpanLess (Located HsIPName)) -> CvtM (Located HsIPName))
-> CvtM (SrcSpanLess (Located HsIPName)) -> CvtM (Located HsIPName)
forall a b. (a -> b) -> a -> b
$ String -> CvtM HsIPName
ipName String
n
                   ; LHsType GhcPs
t' <- Type -> CvtM (LHsType GhcPs)
cvtType Type
t
                   ; SrcSpanLess (LHsType GhcPs) -> CvtM (LHsType GhcPs)
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM a
returnL (XIParamTy GhcPs
-> Located HsIPName -> LHsType GhcPs -> HsType GhcPs
forall pass.
XIParamTy pass -> Located HsIPName -> LHsType pass -> HsType pass
HsIParamTy XIParamTy GhcPs
NoExt
noExt Located HsIPName
n' LHsType GhcPs
t')
                   }

           _ -> MsgDoc -> CvtM (LHsType GhcPs)
forall a. MsgDoc -> CvtM a
failWith (PtrString -> MsgDoc
ptext (String -> PtrString
sLit ("Malformed " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ty_str)) MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text (Type -> String
forall a. Show a => a -> String
show Type
ty))
    }

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

      go :: [LHsTypeArg GhcPs] -> CvtM (LHsType GhcPs)
      go :: HsTyPats GhcPs -> CvtM (LHsType GhcPs)
go [] = LHsType GhcPs -> CvtM (LHsType GhcPs)
forall (f :: * -> *) a. Applicative f => a -> f a
pure LHsType GhcPs
head_ty'
      go (arg :: LHsTypeArg GhcPs
arg:args :: HsTyPats GhcPs
args) =
        case LHsTypeArg GhcPs
arg of
          HsValArg ty :: LHsType GhcPs
ty  -> do LHsType GhcPs
p_ty <- LHsType GhcPs -> CvtM (LHsType GhcPs)
forall pass.
(XParTy pass ~ NoExt) =>
GenLocated SrcSpan (HsType pass)
-> CvtM (GenLocated SrcSpan (HsType pass))
add_parens LHsType GhcPs
ty
                             HsType GhcPs -> HsTyPats GhcPs -> CvtM (LHsType GhcPs)
mk_apps (XAppTy GhcPs -> LHsType GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass.
XAppTy pass -> LHsType pass -> LHsType pass -> HsType pass
HsAppTy XAppTy GhcPs
NoExt
noExt LHsType GhcPs
phead_ty LHsType GhcPs
p_ty) HsTyPats GhcPs
args
          HsTypeArg l :: SrcSpan
l ki :: LHsType GhcPs
ki -> do LHsType GhcPs
p_ki <- LHsType GhcPs -> CvtM (LHsType GhcPs)
forall pass.
(XParTy pass ~ NoExt) =>
GenLocated SrcSpan (HsType pass)
-> CvtM (GenLocated SrcSpan (HsType pass))
add_parens LHsType GhcPs
ki
                               HsType GhcPs -> HsTyPats GhcPs -> CvtM (LHsType GhcPs)
mk_apps (XAppKindTy GhcPs -> LHsType GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass.
XAppKindTy pass -> LHsType pass -> LHsType pass -> HsType pass
HsAppKindTy SrcSpan
XAppKindTy GhcPs
l LHsType GhcPs
phead_ty LHsType GhcPs
p_ki) HsTyPats GhcPs
args
          HsArgPar _   -> HsType GhcPs -> HsTyPats GhcPs -> CvtM (LHsType GhcPs)
mk_apps (XParTy GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy XParTy GhcPs
NoExt
noExt LHsType GhcPs
phead_ty) HsTyPats GhcPs
args

  HsTyPats GhcPs -> CvtM (LHsType GhcPs)
go HsTyPats GhcPs
type_args
   where
    -- See Note [Adding parens for splices]
    add_parens :: GenLocated SrcSpan (HsType pass)
-> CvtM (GenLocated SrcSpan (HsType pass))
add_parens lt :: GenLocated SrcSpan (HsType pass)
lt@(GenLocated SrcSpan (HsType pass)
-> Located (SrcSpanLess (GenLocated SrcSpan (HsType pass)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ t :: SrcSpanLess (GenLocated SrcSpan (HsType pass))
t)
      | PprPrec -> HsType pass -> Bool
forall pass. PprPrec -> HsType pass -> Bool
hsTypeNeedsParens PprPrec
appPrec SrcSpanLess (GenLocated SrcSpan (HsType pass))
HsType pass
t = SrcSpanLess (GenLocated SrcSpan (HsType pass))
-> CvtM (GenLocated SrcSpan (HsType pass))
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM a
returnL (XParTy pass -> GenLocated SrcSpan (HsType pass) -> HsType pass
forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy XParTy pass
NoExt
noExt GenLocated SrcSpan (HsType pass)
lt)
      | Bool
otherwise                   = GenLocated SrcSpan (HsType pass)
-> CvtM (GenLocated SrcSpan (HsType pass))
forall (m :: * -> *) a. Monad m => a -> m a
return GenLocated SrcSpan (HsType pass)
lt

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

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

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

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

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

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

So scattered through Convert.hs are various points where parens are added.

See (among other closed issued) https://ghc.haskell.org/trac/ghc/ticket/14289
-}
-- ---------------------------------------------------------------------

-- | Constructs an arrow type with a specified return type
mk_arr_apps :: [LHsType GhcPs] -> HsType GhcPs -> CvtM (LHsType GhcPs)
mk_arr_apps :: [LHsType GhcPs] -> HsType GhcPs -> CvtM (LHsType GhcPs)
mk_arr_apps tys :: [LHsType GhcPs]
tys return_ty :: HsType GhcPs
return_ty = (LHsType GhcPs -> HsType GhcPs -> CvtM (HsType GhcPs))
-> HsType GhcPs -> [LHsType GhcPs] -> CvtM (HsType GhcPs)
forall (m :: * -> *) b a.
Monad m =>
(b -> a -> m a) -> a -> [b] -> m a
foldrM LHsType GhcPs -> HsType GhcPs -> CvtM (HsType GhcPs)
go HsType GhcPs
return_ty [LHsType GhcPs]
tys CvtM (HsType GhcPs)
-> (HsType GhcPs -> CvtM (LHsType GhcPs)) -> CvtM (LHsType GhcPs)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HsType GhcPs -> CvtM (LHsType GhcPs)
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM a
returnL
    where go :: LHsType GhcPs -> HsType GhcPs -> CvtM (HsType GhcPs)
          go :: LHsType GhcPs -> HsType GhcPs -> CvtM (HsType GhcPs)
go arg :: LHsType GhcPs
arg ret_ty :: HsType GhcPs
ret_ty = do { LHsType GhcPs
ret_ty_l <- SrcSpanLess (LHsType GhcPs) -> CvtM (LHsType GhcPs)
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM a
returnL SrcSpanLess (LHsType GhcPs)
HsType GhcPs
ret_ty
                             ; HsType GhcPs -> CvtM (HsType GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (XFunTy GhcPs -> LHsType GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass.
XFunTy pass -> LHsType pass -> LHsType pass -> HsType pass
HsFunTy XFunTy GhcPs
NoExt
noExt LHsType GhcPs
arg LHsType GhcPs
ret_ty_l) }

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

cvtTyLit :: TH.TyLit -> HsTyLit
cvtTyLit :: TyLit -> HsTyLit
cvtTyLit (TH.NumTyLit i :: Integer
i) = SourceText -> Integer -> HsTyLit
HsNumTy SourceText
NoSourceText Integer
i
cvtTyLit (TH.StrTyLit s :: String
s) = SourceText -> CLabelString -> HsTyLit
HsStrTy SourceText
NoSourceText (String -> CLabelString
fsLit String
s)

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

See the @cvtOpApp@ documentation for how this function works.
-}
cvtOpAppT :: TH.Type -> TH.Name -> LHsType GhcPs -> CvtM (LHsType GhcPs)
cvtOpAppT :: Type -> Name -> LHsType GhcPs -> CvtM (LHsType GhcPs)
cvtOpAppT (UInfixT x :: Type
x op2 :: Name
op2 y :: Type
y) op1 :: Name
op1 z :: LHsType GhcPs
z
  = do { LHsType GhcPs
l <- Type -> Name -> LHsType GhcPs -> CvtM (LHsType GhcPs)
cvtOpAppT Type
y Name
op1 LHsType GhcPs
z
       ; Type -> Name -> LHsType GhcPs -> CvtM (LHsType GhcPs)
cvtOpAppT Type
x Name
op2 LHsType GhcPs
l }
cvtOpAppT x :: Type
x op :: Name
op y :: LHsType GhcPs
y
  = do { Located RdrName
op' <- Name -> CvtM (Located RdrName)
tconNameL Name
op
       ; LHsType GhcPs
x' <- Type -> CvtM (LHsType GhcPs)
cvtType Type
x
       ; SrcSpanLess (LHsType GhcPs) -> CvtM (LHsType GhcPs)
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM a
returnL (LHsType GhcPs
-> Located (IdP GhcPs) -> LHsType GhcPs -> HsType GhcPs
forall (p :: Pass).
LHsType (GhcPass p)
-> Located (IdP (GhcPass p))
-> LHsType (GhcPass p)
-> HsType (GhcPass p)
mkHsOpTy LHsType GhcPs
x' Located RdrName
Located (IdP GhcPs)
op' LHsType GhcPs
y) }

cvtKind :: TH.Kind -> CvtM (LHsKind GhcPs)
cvtKind :: Type -> CvtM (LHsType GhcPs)
cvtKind = String -> Type -> CvtM (LHsType GhcPs)
cvtTypeKind "kind"

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

-- | Convert type family result signature. Used with both open and closed type
-- families.
cvtFamilyResultSig :: TH.FamilyResultSig -> CvtM (Hs.LFamilyResultSig GhcPs)
cvtFamilyResultSig :: FamilyResultSig -> CvtM (LFamilyResultSig GhcPs)
cvtFamilyResultSig TH.NoSig           = SrcSpanLess (LFamilyResultSig GhcPs)
-> CvtM (LFamilyResultSig GhcPs)
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM a
returnL (XNoSig GhcPs -> FamilyResultSig GhcPs
forall pass. XNoSig pass -> FamilyResultSig pass
Hs.NoSig XNoSig GhcPs
NoExt
noExt)
cvtFamilyResultSig (TH.KindSig ki :: Type
ki)    = do { LHsType GhcPs
ki' <- Type -> CvtM (LHsType GhcPs)
cvtKind Type
ki
                                           ; SrcSpanLess (LFamilyResultSig GhcPs)
-> CvtM (LFamilyResultSig GhcPs)
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM a
returnL (XCKindSig GhcPs -> LHsType GhcPs -> FamilyResultSig GhcPs
forall pass. XCKindSig pass -> LHsKind pass -> FamilyResultSig pass
Hs.KindSig XCKindSig GhcPs
NoExt
noExt  LHsType GhcPs
ki') }
cvtFamilyResultSig (TH.TyVarSig bndr :: TyVarBndr
bndr) = do { LHsTyVarBndr GhcPs
tv <- TyVarBndr -> CvtM (LHsTyVarBndr GhcPs)
cvt_tv TyVarBndr
bndr
                                           ; SrcSpanLess (LFamilyResultSig GhcPs)
-> CvtM (LFamilyResultSig GhcPs)
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM a
returnL (XTyVarSig GhcPs -> LHsTyVarBndr GhcPs -> FamilyResultSig GhcPs
forall pass.
XTyVarSig pass -> LHsTyVarBndr pass -> FamilyResultSig pass
Hs.TyVarSig XTyVarSig GhcPs
NoExt
noExt LHsTyVarBndr GhcPs
tv) }

-- | Convert injectivity annotation of a type family.
cvtInjectivityAnnotation :: TH.InjectivityAnn
                         -> CvtM (Hs.LInjectivityAnn GhcPs)
cvtInjectivityAnnotation :: InjectivityAnn -> CvtM (LInjectivityAnn GhcPs)
cvtInjectivityAnnotation (TH.InjectivityAnn annLHS :: Name
annLHS annRHS :: [Name]
annRHS)
  = do { Located RdrName
annLHS' <- Name -> CvtM (Located RdrName)
tNameL Name
annLHS
       ; [Located RdrName]
annRHS' <- (Name -> CvtM (Located RdrName))
-> [Name] -> CvtM [Located RdrName]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> CvtM (Located RdrName)
tNameL [Name]
annRHS
       ; SrcSpanLess (LInjectivityAnn GhcPs) -> CvtM (LInjectivityAnn GhcPs)
forall a. HasSrcSpan a => SrcSpanLess a -> CvtM a
returnL (Located (IdP GhcPs)
-> [Located (IdP GhcPs)] -> InjectivityAnn GhcPs
forall pass.
Located (IdP pass) -> [Located (IdP pass)] -> InjectivityAnn pass
Hs.InjectivityAnn Located RdrName
Located (IdP GhcPs)
annLHS' [Located RdrName]
[Located (IdP GhcPs)]
annRHS') }

cvtPatSynSigTy :: TH.Type -> CvtM (LHsType GhcPs)
-- pattern synonym types are of peculiar shapes, which is why we treat
-- them separately from regular types;
-- see Note [Pattern synonym type signatures and Template Haskell]
cvtPatSynSigTy :: Type -> CvtM (LHsType GhcPs)
cvtPatSynSigTy (ForallT univs :: [TyVarBndr]
univs reqs :: Cxt
reqs (ForallT exis :: [TyVarBndr]
exis provs :: Cxt
provs ty :: Type
ty))
  | [TyVarBndr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVarBndr]
exis, Cxt -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Cxt
provs = Type -> CvtM (LHsType GhcPs)
cvtType ([TyVarBndr] -> Cxt -> Type -> Type
ForallT [TyVarBndr]
univs Cxt
reqs Type
ty)
  | [TyVarBndr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVarBndr]
univs, Cxt -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Cxt
reqs = do { SrcSpan
l   <- CvtM SrcSpan
getL
                               ; LHsType GhcPs
ty' <- Type -> CvtM (LHsType GhcPs)
cvtType ([TyVarBndr] -> Cxt -> Type -> Type
ForallT [TyVarBndr]
exis Cxt
provs Type
ty)
                               ; LHsType GhcPs -> CvtM (LHsType GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsType GhcPs -> CvtM (LHsType GhcPs))
-> LHsType GhcPs -> CvtM (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> SrcSpanLess (LHsType GhcPs) -> LHsType GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (HsQualTy :: forall pass.
XQualTy pass -> LHsContext pass -> LHsType pass -> HsType pass
HsQualTy { hst_ctxt :: LHsContext GhcPs
hst_ctxt = SrcSpan -> SrcSpanLess (LHsContext GhcPs) -> LHsContext GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l []
                                                         , hst_xqual :: XQualTy GhcPs
hst_xqual = XQualTy GhcPs
NoExt
noExt
                                                         , hst_body :: LHsType GhcPs
hst_body = LHsType GhcPs
ty' }) }
  | Cxt -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Cxt
reqs             = do { SrcSpan
l      <- CvtM SrcSpan
getL
                               ; [LHsTyVarBndr GhcPs]
univs' <- LHsQTyVars GhcPs -> [LHsTyVarBndr GhcPs]
forall pass. LHsQTyVars pass -> [LHsTyVarBndr pass]
hsQTvExplicit (LHsQTyVars GhcPs -> [LHsTyVarBndr GhcPs])
-> CvtM (LHsQTyVars GhcPs) -> CvtM [LHsTyVarBndr GhcPs]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarBndr] -> CvtM (LHsQTyVars GhcPs)
cvtTvs [TyVarBndr]
univs
                               ; LHsType GhcPs
ty'    <- Type -> CvtM (LHsType GhcPs)
cvtType ([TyVarBndr] -> Cxt -> Type -> Type
ForallT [TyVarBndr]
exis Cxt
provs Type
ty)
                               ; let forTy :: HsType GhcPs
forTy = HsForAllTy :: forall pass.
XForAllTy pass
-> [LHsTyVarBndr pass] -> LHsType pass -> HsType pass
HsForAllTy
                                              { hst_bndrs :: [LHsTyVarBndr GhcPs]
hst_bndrs = [LHsTyVarBndr GhcPs]
univs'
                                              , hst_xforall :: XForAllTy GhcPs
hst_xforall = XForAllTy GhcPs
NoExt
noExt
                                              , hst_body :: LHsType GhcPs
hst_body = SrcSpan -> SrcSpanLess (LHsType GhcPs) -> LHsType GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (LHsType GhcPs)
HsType GhcPs
cxtTy }
                                     cxtTy :: HsType GhcPs
cxtTy = HsQualTy :: forall pass.
XQualTy pass -> LHsContext pass -> LHsType pass -> HsType pass
HsQualTy { hst_ctxt :: LHsContext GhcPs
hst_ctxt = SrcSpan -> SrcSpanLess (LHsContext GhcPs) -> LHsContext GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l []
                                                      , hst_xqual :: XQualTy GhcPs
hst_xqual = XQualTy GhcPs
NoExt
noExt
                                                      , hst_body :: LHsType GhcPs
hst_body = LHsType GhcPs
ty' }
                               ; LHsType GhcPs -> CvtM (LHsType GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsType GhcPs -> CvtM (LHsType GhcPs))
-> LHsType GhcPs -> CvtM (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> SrcSpanLess (LHsType GhcPs) -> LHsType GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l SrcSpanLess (LHsType GhcPs)
HsType GhcPs
forTy }
  | Bool
otherwise             = Type -> CvtM (LHsType GhcPs)
cvtType ([TyVarBndr] -> Cxt -> Type -> Type
ForallT [TyVarBndr]
univs Cxt
reqs ([TyVarBndr] -> Cxt -> Type -> Type
ForallT [TyVarBndr]
exis Cxt
provs Type
ty))
cvtPatSynSigTy ty :: Type
ty         = Type -> CvtM (LHsType GhcPs)
cvtType Type
ty

-----------------------------------------------------------
cvtFixity :: TH.Fixity -> Hs.Fixity
cvtFixity :: Fixity -> Fixity
cvtFixity (TH.Fixity prec :: Int
prec dir :: 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 TH.InfixL = FixityDirection
Hs.InfixL
     cvt_dir TH.InfixR = FixityDirection
Hs.InfixR
     cvt_dir TH.InfixN = FixityDirection
Hs.InfixN

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


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

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

-- Checks that are performed when converting unboxed sum expressions and
-- patterns alike.
unboxedSumChecks :: TH.SumAlt -> TH.SumArity -> CvtM ()
unboxedSumChecks :: Int -> Int -> CvtM ()
unboxedSumChecks alt :: Int
alt arity :: Int
arity
    | Int
alt Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
arity
    = MsgDoc -> CvtM ()
forall a. MsgDoc -> CvtM a
failWith (MsgDoc -> CvtM ()) -> MsgDoc -> CvtM ()
forall a b. (a -> b) -> a -> b
$ String -> MsgDoc
text "Sum alternative"    MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text (Int -> String
forall a. Show a => a -> String
show Int
alt)
             MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text "exceeds its arity," MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text (Int -> String
forall a. Show a => a -> String
show Int
arity)
    | Int
alt Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 0
    = MsgDoc -> CvtM ()
forall a. MsgDoc -> CvtM a
failWith (MsgDoc -> CvtM ()) -> MsgDoc -> CvtM ()
forall a b. (a -> b) -> a -> b
$ [MsgDoc] -> MsgDoc
vcat [ String -> MsgDoc
text "Illegal sum alternative:" MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text (Int -> String
forall a. Show a => a -> String
show Int
alt)
                      , Int -> MsgDoc -> MsgDoc
nest 2 (MsgDoc -> MsgDoc) -> MsgDoc -> MsgDoc
forall a b. (a -> b) -> a -> b
$ String -> MsgDoc
text "Sum alternatives must start from 1" ]
    | Int
arity Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 2
    = MsgDoc -> CvtM ()
forall a. MsgDoc -> CvtM a
failWith (MsgDoc -> CvtM ()) -> MsgDoc -> CvtM ()
forall a b. (a -> b) -> a -> b
$ [MsgDoc] -> MsgDoc
vcat [ String -> MsgDoc
text "Illegal sum arity:" MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text (Int -> String
forall a. Show a => a -> String
show Int
arity)
                      , Int -> MsgDoc -> MsgDoc
nest 2 (MsgDoc -> MsgDoc) -> MsgDoc -> MsgDoc
forall a b. (a -> b) -> a -> b
$ String -> MsgDoc
text "Sums must have an arity of at least 2" ]
    | Bool
otherwise
    = () -> CvtM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | If passed an empty list of 'TH.TyVarBndr's, this simply returns the
-- third argument (an 'LHsType'). Otherwise, return an 'HsForAllTy'
-- using the provided 'LHsQTyVars' and 'LHsType'.
mkHsForAllTy :: [TH.TyVarBndr]
             -- ^ The original Template Haskell type variable binders
             -> SrcSpan
             -- ^ The location of the returned 'LHsType' if it needs an
             --   explicit forall
             -> LHsQTyVars GhcPs
             -- ^ The converted type variable binders
             -> LHsType GhcPs
             -- ^ The converted rho type
             -> LHsType GhcPs
             -- ^ The complete type, quantified with a forall if necessary
mkHsForAllTy :: [TyVarBndr]
-> SrcSpan -> LHsQTyVars GhcPs -> LHsType GhcPs -> LHsType GhcPs
mkHsForAllTy tvs :: [TyVarBndr]
tvs loc :: SrcSpan
loc tvs' :: LHsQTyVars GhcPs
tvs' rho_ty :: LHsType GhcPs
rho_ty
  | [TyVarBndr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVarBndr]
tvs  = LHsType GhcPs
rho_ty
  | Bool
otherwise = SrcSpan -> SrcSpanLess (LHsType GhcPs) -> LHsType GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (SrcSpanLess (LHsType GhcPs) -> LHsType GhcPs)
-> SrcSpanLess (LHsType GhcPs) -> LHsType GhcPs
forall a b. (a -> b) -> a -> b
$ HsForAllTy :: forall pass.
XForAllTy pass
-> [LHsTyVarBndr pass] -> LHsType pass -> HsType pass
HsForAllTy { hst_bndrs :: [LHsTyVarBndr GhcPs]
hst_bndrs = LHsQTyVars GhcPs -> [LHsTyVarBndr GhcPs]
forall pass. LHsQTyVars pass -> [LHsTyVarBndr pass]
hsQTvExplicit LHsQTyVars GhcPs
tvs'
                                    , hst_xforall :: XForAllTy GhcPs
hst_xforall = XForAllTy GhcPs
NoExt
noExt
                                    , hst_body :: LHsType GhcPs
hst_body = LHsType GhcPs
rho_ty }

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

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

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

-- variable names
vNameL, cNameL, vcNameL, tNameL, tconNameL :: TH.Name -> CvtM (Located RdrName)
vName,  cName,  vcName,  tName,  tconName  :: TH.Name -> CvtM RdrName

-- Variable names
vNameL :: Name -> CvtM (Located RdrName)
vNameL n :: Name
n = CvtM (SrcSpanLess (Located RdrName)) -> CvtM (Located RdrName)
forall a. HasSrcSpan a => CvtM (SrcSpanLess a) -> CvtM a
wrapL (Name -> CvtM RdrName
vName Name
n)
vName :: Name -> CvtM RdrName
vName n :: Name
n = NameSpace -> Name -> CvtM RdrName
cvtName NameSpace
OccName.varName Name
n

-- Constructor function names; this is Haskell source, hence srcDataName
cNameL :: Name -> CvtM (Located RdrName)
cNameL n :: Name
n = CvtM (SrcSpanLess (Located RdrName)) -> CvtM (Located RdrName)
forall a. HasSrcSpan a => CvtM (SrcSpanLess a) -> CvtM a
wrapL (Name -> CvtM RdrName
cName Name
n)
cName :: Name -> CvtM RdrName
cName n :: Name
n = NameSpace -> Name -> CvtM RdrName
cvtName NameSpace
OccName.dataName Name
n

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

-- Type variable names
tNameL :: Name -> CvtM (Located RdrName)
tNameL n :: Name
n = CvtM (SrcSpanLess (Located RdrName)) -> CvtM (Located RdrName)
forall a. HasSrcSpan a => CvtM (SrcSpanLess a) -> CvtM a
wrapL (Name -> CvtM RdrName
tName Name
n)
tName :: Name -> CvtM RdrName
tName n :: Name
n = NameSpace -> Name -> CvtM RdrName
cvtName NameSpace
OccName.tvName Name
n

-- Type Constructor names
tconNameL :: Name -> CvtM (Located RdrName)
tconNameL n :: Name
n = CvtM (SrcSpanLess (Located RdrName)) -> CvtM (Located RdrName)
forall a. HasSrcSpan a => CvtM (SrcSpanLess a) -> CvtM a
wrapL (Name -> CvtM RdrName
tconName Name
n)
tconName :: Name -> CvtM RdrName
tconName n :: Name
n = NameSpace -> Name -> CvtM RdrName
cvtName NameSpace
OccName.tcClsName Name
n

ipName :: String -> CvtM HsIPName
ipName :: String -> CvtM HsIPName
ipName n :: String
n
  = do { Bool -> CvtM () -> CvtM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String -> Bool
okVarOcc String
n) (MsgDoc -> CvtM ()
forall a. MsgDoc -> CvtM a
failWith (NameSpace -> String -> MsgDoc
badOcc NameSpace
OccName.varName String
n))
       ; HsIPName -> CvtM HsIPName
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 ctxt_ns :: NameSpace
ctxt_ns (TH.Name occ :: OccName
occ flavour :: NameFlavour
flavour)
  | Bool -> Bool
not (NameSpace -> String -> Bool
okOcc NameSpace
ctxt_ns String
occ_str) = MsgDoc -> CvtM RdrName
forall a. MsgDoc -> CvtM a
failWith (NameSpace -> String -> MsgDoc
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
       ; RdrName -> CvtM ()
forall a. a -> CvtM ()
force RdrName
rdr_name
       ; RdrName -> CvtM RdrName
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 ns :: NameSpace
ns str :: String
str
  | NameSpace -> Bool
OccName.isVarNameSpace NameSpace
ns     = String -> Bool
okVarOcc String
str
  | NameSpace -> Bool
OccName.isDataConNameSpace NameSpace
ns = String -> Bool
okConOcc String
str
  | Bool
otherwise                     = String -> Bool
okTcOcc  String
str

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

badOcc :: OccName.NameSpace -> String -> SDoc
badOcc :: NameSpace -> String -> MsgDoc
badOcc ctxt_ns :: NameSpace
ctxt_ns occ :: String
occ
  = String -> MsgDoc
text "Illegal" MsgDoc -> MsgDoc -> MsgDoc
<+> NameSpace -> MsgDoc
pprNameSpace NameSpace
ctxt_ns
        MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text "name:" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (String -> MsgDoc
text String
occ)

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

-- Return an unqualified exact RdrName if we're dealing with built-in syntax.
-- See Trac #13776.
thOrigRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName
thOrigRdrName :: String -> NameSpace -> PkgName -> ModName -> RdrName
thOrigRdrName occ :: String
occ th_ns :: NameSpace
th_ns pkg :: PkgName
pkg mod :: 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 -> Name -> RdrName
nameRdrName Name
name
       Nothing   -> (Module -> OccName -> RdrName
mkOrig (Module -> OccName -> RdrName) -> Module -> OccName -> RdrName
forall a b. (a -> b) -> a -> b
$! (UnitId -> ModuleName -> Module
mkModule (PkgName -> UnitId
mk_pkg PkgName
pkg) (ModName -> ModuleName
mk_mod ModName
mod))) (OccName -> RdrName) -> OccName -> RdrName
forall a b. (a -> b) -> a -> b
$! OccName
occ'

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

-- The packing and unpacking is rather turgid :-(
mk_occ :: OccName.NameSpace -> String -> OccName.OccName
mk_occ :: NameSpace -> String -> OccName
mk_occ ns :: NameSpace
ns occ :: 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 TH.DataName  = NameSpace
OccName.dataName
mk_ghc_ns TH.TcClsName = NameSpace
OccName.tcClsName
mk_ghc_ns TH.VarName   = NameSpace
OccName.varName

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

mk_pkg :: TH.PkgName -> UnitId
mk_pkg :: PkgName -> UnitId
mk_pkg pkg :: PkgName
pkg = String -> UnitId
stringToUnitId (PkgName -> String
TH.pkgString PkgName
pkg)

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

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

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

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

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

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

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

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

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

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

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

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

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

In general, the type signature of a pattern synonym

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

is of the form

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

with the following parts:

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

Due to the two forall quantifiers and constraint contexts (either of
which might be empty), pattern synonym type signatures are treated
specially in `deSugar/DsMeta.hs`, `hsSyn/Convert.hs`, and
`typecheck/TcSplice.hs`:

   (a) When desugaring a pattern synonym from HsSyn to TH.Dec in
       `deSugar/DsMeta.hs`, we represent its *full* type signature in TH, i.e.:

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

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

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

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

   (c) When reifying a pattern synonym in `typecheck/TcSplice.hs`, we always
       return its *full* type, i.e.:

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

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

-}