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


This module converts Template Haskell syntax into Hs syntax
-}

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

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

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

import GHC.Prelude

import GHC.Hs as Hs
import GHC.Builtin.Names
import GHC.Types.Name.Reader
import qualified GHC.Types.Name as Name
import GHC.Unit.Module
import GHC.Parser.PostProcess
import GHC.Types.Name.Occurrence as OccName
import GHC.Types.SrcLoc
import GHC.Core.Type as Hs
import qualified GHC.Core.Coercion as Coercion ( Role(..) )
import GHC.Builtin.Types
import GHC.Types.Basic as Hs
import GHC.Types.ForeignCall
import GHC.Types.Unique
import GHC.Utils.Error
import GHC.Data.Bag
import GHC.Utils.Lexeme
import GHC.Utils.Misc
import GHC.Data.FastString
import GHC.Utils.Outputable as Outputable
import GHC.Parser.Annotation (IsUnicodeSyntax(..))

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

import Data.Maybe( catMaybes, isNothing )
import Language.Haskell.TH as TH hiding (sigP)
import Language.Haskell.TH.Syntax as TH
import Foreign.ForeignPtr
import Foreign.Ptr
import System.IO.Unsafe

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

convertToHsDecls :: Origin -> SrcSpan -> [TH.Dec] -> Either MsgDoc [LHsDecl GhcPs]
convertToHsDecls :: Origin -> SrcSpan -> [Dec] -> Either MsgDoc [LHsDecl GhcPs]
convertToHsDecls Origin
origin SrcSpan
loc [Dec]
ds = Origin
-> SrcSpan -> CvtM [LHsDecl GhcPs] -> Either MsgDoc [LHsDecl GhcPs]
forall a. Origin -> SrcSpan -> CvtM a -> Either MsgDoc a
initCvt Origin
origin 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 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 String
"declaration" Dec
d (Dec -> CvtM (Maybe (LHsDecl GhcPs))
cvtDec Dec
d)

convertToHsExpr :: Origin -> SrcSpan -> TH.Exp -> Either MsgDoc (LHsExpr GhcPs)
convertToHsExpr :: Origin -> SrcSpan -> Exp -> Either MsgDoc (LHsExpr GhcPs)
convertToHsExpr Origin
origin SrcSpan
loc Exp
e
  = Origin
-> SrcSpan -> CvtM (LHsExpr GhcPs) -> Either MsgDoc (LHsExpr GhcPs)
forall a. Origin -> SrcSpan -> CvtM a -> Either MsgDoc a
initCvt Origin
origin 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 String
"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 :: Origin -> SrcSpan -> TH.Pat -> Either MsgDoc (LPat GhcPs)
convertToPat :: Origin -> SrcSpan -> Pat -> Either MsgDoc (LPat GhcPs)
convertToPat Origin
origin SrcSpan
loc Pat
p
  = Origin
-> SrcSpan
-> CvtM (Located (Pat GhcPs))
-> Either MsgDoc (Located (Pat GhcPs))
forall a. Origin -> SrcSpan -> CvtM a -> Either MsgDoc a
initCvt Origin
origin SrcSpan
loc (CvtM (Located (Pat GhcPs)) -> Either MsgDoc (Located (Pat GhcPs)))
-> CvtM (Located (Pat GhcPs))
-> Either MsgDoc (Located (Pat GhcPs))
forall a b. (a -> b) -> a -> b
$ String
-> Pat -> CvtM (Located (Pat GhcPs)) -> CvtM (Located (Pat GhcPs))
forall a b. (Show a, Ppr a) => String -> a -> CvtM b -> CvtM b
wrapMsg String
"pattern" Pat
p (CvtM (Located (Pat GhcPs)) -> CvtM (Located (Pat GhcPs)))
-> CvtM (Located (Pat GhcPs)) -> CvtM (Located (Pat GhcPs))
forall a b. (a -> b) -> a -> b
$ Pat -> CvtM (LPat GhcPs)
cvtPat Pat
p

convertToHsType :: Origin -> SrcSpan -> TH.Type -> Either MsgDoc (LHsType GhcPs)
convertToHsType :: Origin -> SrcSpan -> Type -> Either MsgDoc (LHsType GhcPs)
convertToHsType Origin
origin SrcSpan
loc Type
t
  = Origin
-> SrcSpan -> CvtM (LHsType GhcPs) -> Either MsgDoc (LHsType GhcPs)
forall a. Origin -> SrcSpan -> CvtM a -> Either MsgDoc a
initCvt Origin
origin 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 String
"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 { forall a. CvtM a -> Origin -> SrcSpan -> Either MsgDoc (SrcSpan, a)
unCvtM :: Origin -> SrcSpan -> Either MsgDoc (SrcSpan, a) }
    deriving ((forall a b. (a -> b) -> CvtM a -> CvtM b)
-> (forall a b. a -> CvtM b -> CvtM a) -> Functor CvtM
forall a b. a -> CvtM b -> CvtM a
forall a b. (a -> b) -> CvtM a -> CvtM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> CvtM b -> CvtM a
$c<$ :: forall a b. a -> CvtM b -> CvtM a
fmap :: forall a b. (a -> b) -> CvtM a -> CvtM b
$cfmap :: forall a b. (a -> b) -> CvtM a -> CvtM b
Functor)
        -- Push down the Origin (that is configurable by
        -- -fenable-th-splice-warnings) and source location;
        -- Can fail, with a single error message

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

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

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

initCvt :: Origin -> SrcSpan -> CvtM a -> Either MsgDoc a
initCvt :: forall a. Origin -> SrcSpan -> CvtM a -> Either MsgDoc a
initCvt Origin
origin SrcSpan
loc (CvtM Origin -> 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 (Origin -> SrcSpan -> Either MsgDoc (SrcSpan, a)
m Origin
origin SrcSpan
loc)

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

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

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

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

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

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

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

wrapMsg :: (Show a, TH.Ppr a) => String -> a -> CvtM b -> CvtM b
-- E.g  wrapMsg "declaration" dec thing
wrapMsg :: forall a b. (Show a, Ppr a) => String -> a -> CvtM b -> CvtM b
wrapMsg String
what a
item (CvtM Origin -> SrcSpan -> Either MsgDoc (SrcSpan, b)
m)
  = (Origin -> SrcSpan -> Either MsgDoc (SrcSpan, b)) -> CvtM b
forall a.
(Origin -> SrcSpan -> Either MsgDoc (SrcSpan, a)) -> CvtM a
CvtM ((Origin -> SrcSpan -> Either MsgDoc (SrcSpan, b)) -> CvtM b)
-> (Origin -> SrcSpan -> Either MsgDoc (SrcSpan, b)) -> CvtM b
forall a b. (a -> b) -> a -> b
$ \Origin
origin SrcSpan
loc -> case Origin -> SrcSpan -> Either MsgDoc (SrcSpan, b)
m Origin
origin SrcSpan
loc of
      Left MsgDoc
err -> MsgDoc -> Either MsgDoc (SrcSpan, b)
forall a b. a -> Either a b
Left (MsgDoc
err MsgDoc -> MsgDoc -> MsgDoc
$$ MsgDoc
msg)
      Right (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 :: MsgDoc
msg = MsgDoc -> Int -> MsgDoc -> MsgDoc
hang (String -> MsgDoc
text String
"When splicing a TH" MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text String
what MsgDoc -> MsgDoc -> MsgDoc
<> MsgDoc
colon)
                 Int
2 ((Bool -> MsgDoc) -> MsgDoc
getPprDebug ((Bool -> MsgDoc) -> MsgDoc) -> (Bool -> MsgDoc) -> MsgDoc
forall a b. (a -> b) -> a -> b
$ \case
                     Bool
True  -> String -> MsgDoc
text (a -> String
forall a. Show a => a -> String
show a
item)
                     Bool
False -> String -> MsgDoc
text (a -> String
forall a. Ppr a => a -> String
pprint a
item))

wrapL :: CvtM a -> CvtM (Located a)
wrapL :: forall a. CvtM a -> CvtM (Located a)
wrapL (CvtM Origin -> SrcSpan -> Either MsgDoc (SrcSpan, a)
m) = (Origin
 -> SrcSpan -> Either MsgDoc (SrcSpan, GenLocated SrcSpan a))
-> CvtM (GenLocated SrcSpan a)
forall a.
(Origin -> SrcSpan -> Either MsgDoc (SrcSpan, a)) -> CvtM a
CvtM ((Origin
  -> SrcSpan -> Either MsgDoc (SrcSpan, GenLocated SrcSpan a))
 -> CvtM (GenLocated SrcSpan a))
-> (Origin
    -> SrcSpan -> Either MsgDoc (SrcSpan, GenLocated SrcSpan a))
-> CvtM (GenLocated SrcSpan a)
forall a b. (a -> b) -> a -> b
$ \Origin
origin SrcSpan
loc -> case Origin -> SrcSpan -> Either MsgDoc (SrcSpan, a)
m Origin
origin SrcSpan
loc of
  Left MsgDoc
err -> MsgDoc -> Either MsgDoc (SrcSpan, GenLocated SrcSpan a)
forall a b. a -> Either a b
Left MsgDoc
err
  Right (SrcSpan
loc', a
v) -> (SrcSpan, GenLocated SrcSpan a)
-> Either MsgDoc (SrcSpan, GenLocated SrcSpan a)
forall a b. b -> Either a b
Right (SrcSpan
loc', SrcSpan -> a -> GenLocated SrcSpan a
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc 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 Body
body [Dec]
ds)
  | TH.VarP Name
s <- Pat
pat
  = do  { Located RdrName
s' <- Name -> CvtM (Located RdrName)
vNameL Name
s
        ; LMatch GhcPs (LHsExpr GhcPs)
cl' <- HsMatchContext GhcPs
-> Clause -> CvtM (LMatch GhcPs (LHsExpr GhcPs))
cvtClause (LIdP GhcPs -> HsMatchContext GhcPs
forall p. LIdP p -> HsMatchContext p
mkPrefixFunRhs Located RdrName
LIdP GhcPs
s') ([Pat] -> Body -> [Dec] -> Clause
Clause [] Body
body [Dec]
ds)
        ; Origin
th_origin <- CvtM Origin
getOrigin
        ; HsDecl GhcPs -> CvtM (Maybe (LHsDecl GhcPs))
forall a. a -> CvtM (Maybe (Located a))
returnJustL (HsDecl GhcPs -> CvtM (Maybe (LHsDecl GhcPs)))
-> HsDecl 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 NoExtField
XValD GhcPs
noExtField (HsBind GhcPs -> HsDecl GhcPs) -> HsBind GhcPs -> HsDecl GhcPs
forall a b. (a -> b) -> a -> b
$ Origin
-> Located RdrName
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> HsBind GhcPs
mkFunBind Origin
th_origin Located RdrName
s' [LMatch GhcPs (LHsExpr GhcPs)
cl'] }

  | Bool
otherwise
  = do  { Located (Pat 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 String
"a where clause") [Dec]
ds
        ; HsDecl GhcPs -> CvtM (Maybe (LHsDecl GhcPs))
forall a. a -> CvtM (Maybe (Located a))
returnJustL (HsDecl GhcPs -> CvtM (Maybe (LHsDecl GhcPs)))
-> HsDecl 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 NoExtField
XValD GhcPs
noExtField (HsBind GhcPs -> HsDecl GhcPs) -> HsBind GhcPs -> HsDecl 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 = Located (Pat GhcPs)
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 NoExtField
XCGRHSs GhcPs (LHsExpr GhcPs)
noExtField [LGRHS GhcPs (LHsExpr GhcPs)]
body' (HsLocalBinds GhcPs -> LHsLocalBinds GhcPs
forall e. e -> Located e
noLoc HsLocalBinds GhcPs
ds')
                  , pat_ext :: XPatBind GhcPs GhcPs
pat_ext = NoExtField
XPatBind GhcPs GhcPs
noExtField
                  , pat_ticks :: ([Tickish Id], [[Tickish Id]])
pat_ticks = ([],[]) } }

cvtDec (TH.FunD Name
nm [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 String
"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 String
"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 GhcPs
-> Clause -> CvtM (LMatch GhcPs (LHsExpr GhcPs))
cvtClause (LIdP GhcPs -> HsMatchContext GhcPs
forall p. LIdP p -> HsMatchContext p
mkPrefixFunRhs Located RdrName
LIdP GhcPs
nm')) [Clause]
cls
        ; Origin
th_origin <- CvtM Origin
getOrigin
        ; HsDecl GhcPs -> CvtM (Maybe (LHsDecl GhcPs))
forall a. a -> CvtM (Maybe (Located a))
returnJustL (HsDecl GhcPs -> CvtM (Maybe (LHsDecl GhcPs)))
-> HsDecl 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 NoExtField
XValD GhcPs
noExtField (HsBind GhcPs -> HsDecl GhcPs) -> HsBind GhcPs -> HsDecl GhcPs
forall a b. (a -> b) -> a -> b
$ Origin
-> Located RdrName
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> HsBind GhcPs
mkFunBind Origin
th_origin Located RdrName
nm' [LMatch GhcPs (LHsExpr GhcPs)]
cls' }

cvtDec (TH.SigD Name
nm Type
typ)
  = do  { Located RdrName
nm' <- Name -> CvtM (Located RdrName)
vNameL Name
nm
        ; LHsType GhcPs
ty' <- Type -> CvtM (LHsType GhcPs)
cvtType Type
typ
        ; HsDecl GhcPs -> CvtM (Maybe (LHsDecl GhcPs))
forall a. a -> CvtM (Maybe (Located a))
returnJustL (HsDecl GhcPs -> CvtM (Maybe (LHsDecl GhcPs)))
-> HsDecl 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 NoExtField
XSigD GhcPs
noExtField
                                    (XTypeSig GhcPs -> [LIdP GhcPs] -> LHsSigWcType GhcPs -> Sig GhcPs
forall pass.
XTypeSig pass
-> [Located (IdP pass)] -> LHsSigWcType pass -> Sig pass
TypeSig NoExtField
XTypeSig GhcPs
noExtField [Located RdrName
LIdP GhcPs
nm'] (LHsType GhcPs -> LHsSigWcType GhcPs
mkLHsSigWcType LHsType GhcPs
ty')) }

cvtDec (TH.KiSigD Name
nm Type
ki)
  = do  { Located RdrName
nm' <- Name -> CvtM (Located RdrName)
tconNameL Name
nm
        ; LHsType GhcPs
ki' <- Type -> CvtM (LHsType GhcPs)
cvtType Type
ki
        ; let sig' :: StandaloneKindSig GhcPs
sig' = XStandaloneKindSig GhcPs
-> LIdP GhcPs -> LHsSigType GhcPs -> StandaloneKindSig GhcPs
forall pass.
XStandaloneKindSig pass
-> Located (IdP pass) -> LHsSigType pass -> StandaloneKindSig pass
StandaloneKindSig NoExtField
XStandaloneKindSig GhcPs
noExtField Located RdrName
LIdP GhcPs
nm' (LHsType GhcPs -> LHsSigType GhcPs
mkLHsSigType LHsType GhcPs
ki')
        ; HsDecl GhcPs -> CvtM (Maybe (LHsDecl GhcPs))
forall a. a -> CvtM (Maybe (Located a))
returnJustL (HsDecl GhcPs -> CvtM (Maybe (LHsDecl GhcPs)))
-> HsDecl GhcPs -> CvtM (Maybe (LHsDecl GhcPs))
forall a b. (a -> b) -> a -> b
$ XKindSigD GhcPs -> StandaloneKindSig GhcPs -> HsDecl GhcPs
forall p. XKindSigD p -> StandaloneKindSig p -> HsDecl p
Hs.KindSigD NoExtField
XKindSigD GhcPs
noExtField StandaloneKindSig GhcPs
sig' }

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

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

cvtDec (TySynD Name
tc [TyVarBndr ()]
tvs Type
rhs)
  = do  { (LHsContext GhcPs
_, Located RdrName
tc', 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
        ; HsDecl GhcPs -> CvtM (Maybe (LHsDecl GhcPs))
forall a. a -> CvtM (Maybe (Located a))
returnJustL (HsDecl GhcPs -> CvtM (Maybe (LHsDecl GhcPs)))
-> HsDecl 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 NoExtField
XTyClD GhcPs
noExtField (TyClDecl GhcPs -> HsDecl GhcPs) -> TyClDecl GhcPs -> HsDecl 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 = NoExtField
XSynDecl GhcPs
noExtField, tcdLName :: LIdP GhcPs
tcdLName = Located RdrName
LIdP GhcPs
tc', tcdTyVars :: LHsQTyVars GhcPs
tcdTyVars = LHsQTyVars GhcPs
tvs'
                  , tcdFixity :: LexicalFixity
tcdFixity = LexicalFixity
Prefix
                  , tcdRhs :: LHsType GhcPs
tcdRhs = LHsType GhcPs
rhs' } }

cvtDec (DataD Cxt
ctxt Name
tc [TyVarBndr ()]
tvs Maybe Type
ksig [Con]
constrs [DerivClause]
derivs)
  = do  { let isGadtCon :: Con -> Bool
isGadtCon (GadtC    [Name]
_ [BangType]
_ Type
_) = Bool
True
              isGadtCon (RecGadtC [Name]
_ [VarBangType]
_ Type
_) = Bool
True
              isGadtCon (ForallC  [TyVarBndr Specificity]
_ Cxt
_ Con
c) = Con -> Bool
isGadtCon Con
c
              isGadtCon Con
_                = Bool
False
              isGadtDecl :: Bool
isGadtDecl  = (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 String
"Cannot mix GADT constructors with Haskell 98"
                        MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text String
"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 String
"Kind signatures are only allowed on GADTs"))
        ; (LHsContext GhcPs
ctxt', Located RdrName
tc', 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 = NoExtField
XCHsDataDefn GhcPs
noExtField
                                , 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' }
        ; HsDecl GhcPs -> CvtM (Maybe (LHsDecl GhcPs))
forall a. a -> CvtM (Maybe (Located a))
returnJustL (HsDecl GhcPs -> CvtM (Maybe (LHsDecl GhcPs)))
-> HsDecl 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 NoExtField
XTyClD GhcPs
noExtField (TyClDecl GhcPs -> HsDecl GhcPs) -> TyClDecl GhcPs -> HsDecl GhcPs
forall a b. (a -> b) -> a -> b
$
          DataDecl :: forall pass.
XDataDecl pass
-> Located (IdP pass)
-> LHsQTyVars pass
-> LexicalFixity
-> HsDataDefn pass
-> TyClDecl pass
DataDecl { tcdDExt :: XDataDecl GhcPs
tcdDExt = NoExtField
XDataDecl GhcPs
noExtField
                   , tcdLName :: LIdP GhcPs
tcdLName = Located RdrName
LIdP GhcPs
tc', tcdTyVars :: LHsQTyVars GhcPs
tcdTyVars = LHsQTyVars GhcPs
tvs'
                   , tcdFixity :: LexicalFixity
tcdFixity = LexicalFixity
Prefix
                   , tcdDataDefn :: HsDataDefn GhcPs
tcdDataDefn = HsDataDefn GhcPs
defn } }

cvtDec (NewtypeD Cxt
ctxt Name
tc [TyVarBndr ()]
tvs Maybe Type
ksig Con
constr [DerivClause]
derivs)
  = do  { (LHsContext GhcPs
ctxt', Located RdrName
tc', 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 = NoExtField
XCHsDataDefn GhcPs
noExtField
                                , 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' }
        ; HsDecl GhcPs -> CvtM (Maybe (LHsDecl GhcPs))
forall a. a -> CvtM (Maybe (Located a))
returnJustL (HsDecl GhcPs -> CvtM (Maybe (LHsDecl GhcPs)))
-> HsDecl 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 NoExtField
XTyClD GhcPs
noExtField (TyClDecl GhcPs -> HsDecl GhcPs) -> TyClDecl GhcPs -> HsDecl GhcPs
forall a b. (a -> b) -> a -> b
$
          DataDecl :: forall pass.
XDataDecl pass
-> Located (IdP pass)
-> LHsQTyVars pass
-> LexicalFixity
-> HsDataDefn pass
-> TyClDecl pass
DataDecl { tcdDExt :: XDataDecl GhcPs
tcdDExt = NoExtField
XDataDecl GhcPs
noExtField
                   , tcdLName :: LIdP GhcPs
tcdLName = Located RdrName
LIdP GhcPs
tc', tcdTyVars :: LHsQTyVars GhcPs
tcdTyVars = LHsQTyVars GhcPs
tvs'
                   , tcdFixity :: LexicalFixity
tcdFixity = LexicalFixity
Prefix
                   , tcdDataDefn :: HsDataDefn GhcPs
tcdDataDefn = HsDataDefn GhcPs
defn } }

cvtDec (ClassD Cxt
ctxt Name
cl [TyVarBndr ()]
tvs [FunDep]
fds [Dec]
decs)
  = do  { (LHsContext GhcPs
cxt', Located RdrName
tc', 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
        ; (LHsBinds GhcPs
binds', [LSig GhcPs]
sigs', [LFamilyDecl GhcPs]
fams', [LTyFamInstDecl GhcPs]
at_defs', [LDataFamInstDecl GhcPs]
adts') <- MsgDoc
-> [Dec]
-> CvtM
     (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],
      [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs])
cvt_ci_decs (String -> MsgDoc
text String
"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 String
"Default data instance declarations"
                     MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text String
"are not allowed:")
                   MsgDoc -> MsgDoc -> MsgDoc
$$ ([LDataFamInstDecl GhcPs] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
Outputable.ppr [LDataFamInstDecl GhcPs]
adts'))
        ; HsDecl GhcPs -> CvtM (Maybe (LHsDecl GhcPs))
forall a. a -> CvtM (Maybe (Located a))
returnJustL (HsDecl GhcPs -> CvtM (Maybe (LHsDecl GhcPs)))
-> HsDecl 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 NoExtField
XTyClD GhcPs
noExtField (TyClDecl GhcPs -> HsDecl GhcPs) -> TyClDecl GhcPs -> HsDecl 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]
-> [LTyFamDefltDecl pass]
-> [LDocDecl]
-> TyClDecl pass
ClassDecl { tcdCExt :: XClassDecl GhcPs
tcdCExt = LayoutInfo
XClassDecl GhcPs
NoLayoutInfo
                    , tcdCtxt :: LHsContext GhcPs
tcdCtxt = LHsContext GhcPs
cxt', tcdLName :: LIdP GhcPs
tcdLName = Located RdrName
LIdP 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 :: [LTyFamInstDecl GhcPs]
tcdATDefs = [LTyFamInstDecl GhcPs]
at_defs', tcdDocs :: [LDocDecl]
tcdDocs = [] }
                              -- no docs in TH ^^
        }

cvtDec (InstanceD Maybe Overlap
o Cxt
ctxt Type
ty [Dec]
decs)
  = do  { let doc :: MsgDoc
doc = String -> MsgDoc
text String
"an instance declaration"
        ; (LHsBinds GhcPs
binds', [LSig GhcPs]
sigs', [LFamilyDecl GhcPs]
fams', [LTyFamInstDecl GhcPs]
ats', [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' <- PprPrec -> Cxt -> CvtM (LHsContext GhcPs)
cvtContext PprPrec
funPrec Cxt
ctxt
        ; (L SrcSpan
loc HsType 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 -> HsType GhcPs -> LHsType GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc HsType GhcPs
ty'
        ; HsDecl GhcPs -> CvtM (Maybe (LHsDecl GhcPs))
forall a. a -> CvtM (Maybe (Located a))
returnJustL (HsDecl GhcPs -> CvtM (Maybe (LHsDecl GhcPs)))
-> HsDecl 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 NoExtField
XInstD GhcPs
noExtField (InstDecl GhcPs -> HsDecl GhcPs) -> InstDecl GhcPs -> HsDecl GhcPs
forall a b. (a -> b) -> a -> b
$ XClsInstD GhcPs -> ClsInstDecl GhcPs -> InstDecl GhcPs
forall pass. XClsInstD pass -> ClsInstDecl pass -> InstDecl pass
ClsInstD NoExtField
XClsInstD GhcPs
noExtField (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 = NoExtField
XCClsInstDecl GhcPs
noExtField, 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 -> OverlapMode -> Located OverlapMode
forall l e. l -> e -> GenLocated l e
L 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 Overlap
pragma =
    case Overlap
pragma of
      Overlap
TH.Overlaps      -> SourceText -> OverlapMode
Hs.Overlaps     (String -> SourceText
SourceText String
"OVERLAPS")
      Overlap
TH.Overlappable  -> SourceText -> OverlapMode
Hs.Overlappable (String -> SourceText
SourceText String
"OVERLAPPABLE")
      Overlap
TH.Overlapping   -> SourceText -> OverlapMode
Hs.Overlapping  (String -> SourceText
SourceText String
"OVERLAPPING")
      Overlap
TH.Incoherent    -> SourceText -> OverlapMode
Hs.Incoherent   (String -> SourceText
SourceText String
"INCOHERENT")




cvtDec (ForeignD Foreign
ford)
  = do { ForeignDecl GhcPs
ford' <- Foreign -> CvtM (ForeignDecl GhcPs)
cvtForD Foreign
ford
       ; HsDecl GhcPs -> CvtM (Maybe (LHsDecl GhcPs))
forall a. a -> CvtM (Maybe (Located a))
returnJustL (HsDecl GhcPs -> CvtM (Maybe (LHsDecl GhcPs)))
-> HsDecl 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 NoExtField
XForD GhcPs
noExtField ForeignDecl GhcPs
ford' }

cvtDec (DataFamilyD Name
tc [TyVarBndr ()]
tvs Maybe Type
kind)
  = do { (LHsContext GhcPs
_, Located RdrName
tc', 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
       ; HsDecl GhcPs -> CvtM (Maybe (LHsDecl GhcPs))
forall a. a -> CvtM (Maybe (Located a))
returnJustL (HsDecl GhcPs -> CvtM (Maybe (LHsDecl GhcPs)))
-> HsDecl 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 NoExtField
XTyClD GhcPs
noExtField (TyClDecl GhcPs -> HsDecl GhcPs) -> TyClDecl GhcPs -> HsDecl GhcPs
forall a b. (a -> b) -> a -> b
$ XFamDecl GhcPs -> FamilyDecl GhcPs -> TyClDecl GhcPs
forall pass. XFamDecl pass -> FamilyDecl pass -> TyClDecl pass
FamDecl NoExtField
XFamDecl GhcPs
noExtField (FamilyDecl GhcPs -> TyClDecl GhcPs)
-> FamilyDecl GhcPs -> TyClDecl GhcPs
forall a b. (a -> b) -> a -> b
$
         XCFamilyDecl GhcPs
-> FamilyInfo GhcPs
-> LIdP 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 NoExtField
XCFamilyDecl GhcPs
noExtField FamilyInfo GhcPs
forall pass. FamilyInfo pass
DataFamily Located RdrName
LIdP GhcPs
tc' LHsQTyVars GhcPs
tvs' LexicalFixity
Prefix LFamilyResultSig GhcPs
result Maybe (LInjectivityAnn GhcPs)
forall a. Maybe a
Nothing }

cvtDec (DataInstD Cxt
ctxt Maybe [TyVarBndr ()]
bndrs Type
tys Maybe Type
ksig [Con]
constrs [DerivClause]
derivs)
  = do { (LHsContext GhcPs
ctxt', Located RdrName
tc', Maybe [LHsTyVarBndr () GhcPs]
bndrs', 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 = NoExtField
XCHsDataDefn GhcPs
noExtField
                               , 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' }

       ; HsDecl GhcPs -> CvtM (Maybe (LHsDecl GhcPs))
forall a. a -> CvtM (Maybe (Located a))
returnJustL (HsDecl GhcPs -> CvtM (Maybe (LHsDecl GhcPs)))
-> HsDecl 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 NoExtField
XInstD GhcPs
noExtField (InstDecl GhcPs -> HsDecl GhcPs) -> InstDecl GhcPs -> HsDecl GhcPs
forall a b. (a -> b) -> a -> b
$ DataFamInstD :: forall pass.
XDataFamInstD pass -> DataFamInstDecl pass -> InstDecl pass
DataFamInstD
           { dfid_ext :: XDataFamInstD GhcPs
dfid_ext = NoExtField
XDataFamInstD GhcPs
noExtField
           , 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 (HsDataDefn GhcPs)
-> FamInstEqn GhcPs (HsDataDefn GhcPs)
forall thing. thing -> HsImplicitBndrs GhcPs thing
mkHsImplicitBndrs (FamEqn GhcPs (HsDataDefn GhcPs)
 -> FamInstEqn GhcPs (HsDataDefn GhcPs))
-> FamEqn GhcPs (HsDataDefn GhcPs)
-> FamInstEqn GhcPs (HsDataDefn GhcPs)
forall a b. (a -> b) -> a -> b
$
                           FamEqn :: forall pass rhs.
XCFamEqn pass rhs
-> Located (IdP pass)
-> Maybe [LHsTyVarBndr () pass]
-> HsTyPats pass
-> LexicalFixity
-> rhs
-> FamEqn pass rhs
FamEqn { feqn_ext :: XCFamEqn GhcPs (HsDataDefn GhcPs)
feqn_ext = NoExtField
XCFamEqn GhcPs (HsDataDefn GhcPs)
noExtField
                                  , feqn_tycon :: LIdP GhcPs
feqn_tycon = Located RdrName
LIdP 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 Cxt
ctxt Maybe [TyVarBndr ()]
bndrs Type
tys Maybe Type
ksig Con
constr [DerivClause]
derivs)
  = do { (LHsContext GhcPs
ctxt', Located RdrName
tc', Maybe [LHsTyVarBndr () GhcPs]
bndrs', 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 = NoExtField
XCHsDataDefn GhcPs
noExtField
                               , 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' }
       ; HsDecl GhcPs -> CvtM (Maybe (LHsDecl GhcPs))
forall a. a -> CvtM (Maybe (Located a))
returnJustL (HsDecl GhcPs -> CvtM (Maybe (LHsDecl GhcPs)))
-> HsDecl 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 NoExtField
XInstD GhcPs
noExtField (InstDecl GhcPs -> HsDecl GhcPs) -> InstDecl GhcPs -> HsDecl GhcPs
forall a b. (a -> b) -> a -> b
$ DataFamInstD :: forall pass.
XDataFamInstD pass -> DataFamInstDecl pass -> InstDecl pass
DataFamInstD
           { dfid_ext :: XDataFamInstD GhcPs
dfid_ext = NoExtField
XDataFamInstD GhcPs
noExtField
           , 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 (HsDataDefn GhcPs)
-> FamInstEqn GhcPs (HsDataDefn GhcPs)
forall thing. thing -> HsImplicitBndrs GhcPs thing
mkHsImplicitBndrs (FamEqn GhcPs (HsDataDefn GhcPs)
 -> FamInstEqn GhcPs (HsDataDefn GhcPs))
-> FamEqn GhcPs (HsDataDefn GhcPs)
-> FamInstEqn GhcPs (HsDataDefn GhcPs)
forall a b. (a -> b) -> a -> b
$
                           FamEqn :: forall pass rhs.
XCFamEqn pass rhs
-> Located (IdP pass)
-> Maybe [LHsTyVarBndr () pass]
-> HsTyPats pass
-> LexicalFixity
-> rhs
-> FamEqn pass rhs
FamEqn { feqn_ext :: XCFamEqn GhcPs (HsDataDefn GhcPs)
feqn_ext = NoExtField
XCFamEqn GhcPs (HsDataDefn GhcPs)
noExtField
                                  , feqn_tycon :: LIdP GhcPs
feqn_tycon = Located RdrName
LIdP 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 TySynEqn
eqn)
  = do  { (L SrcSpan
_ TyFamInstEqn GhcPs
eqn') <- TySynEqn -> CvtM (GenLocated SrcSpan (TyFamInstEqn GhcPs))
cvtTySynEqn TySynEqn
eqn
        ; HsDecl GhcPs -> CvtM (Maybe (LHsDecl GhcPs))
forall a. a -> CvtM (Maybe (Located a))
returnJustL (HsDecl GhcPs -> CvtM (Maybe (LHsDecl GhcPs)))
-> HsDecl 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 NoExtField
XInstD GhcPs
noExtField (InstDecl GhcPs -> HsDecl GhcPs) -> InstDecl GhcPs -> HsDecl GhcPs
forall a b. (a -> b) -> a -> b
$ TyFamInstD :: forall pass.
XTyFamInstD pass -> TyFamInstDecl pass -> InstDecl pass
TyFamInstD
            { tfid_ext :: XTyFamInstD GhcPs
tfid_ext = NoExtField
XTyFamInstD GhcPs
noExtField
            , tfid_inst :: TyFamInstDecl GhcPs
tfid_inst = TyFamInstDecl :: forall pass. TyFamInstEqn pass -> TyFamInstDecl pass
TyFamInstDecl { tfid_eqn :: TyFamInstEqn GhcPs
tfid_eqn = TyFamInstEqn GhcPs
eqn' } } }

cvtDec (OpenTypeFamilyD TypeFamilyHead
head)
  = do { (Located RdrName
tc', LHsQTyVars GhcPs
tyvars', LFamilyResultSig GhcPs
result', Maybe (LInjectivityAnn GhcPs)
injectivity') <- TypeFamilyHead
-> CvtM
     (Located RdrName, LHsQTyVars GhcPs, LFamilyResultSig GhcPs,
      Maybe (LInjectivityAnn GhcPs))
cvt_tyfam_head TypeFamilyHead
head
       ; HsDecl GhcPs -> CvtM (Maybe (LHsDecl GhcPs))
forall a. a -> CvtM (Maybe (Located a))
returnJustL (HsDecl GhcPs -> CvtM (Maybe (LHsDecl GhcPs)))
-> HsDecl 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 NoExtField
XTyClD GhcPs
noExtField (TyClDecl GhcPs -> HsDecl GhcPs) -> TyClDecl GhcPs -> HsDecl GhcPs
forall a b. (a -> b) -> a -> b
$ XFamDecl GhcPs -> FamilyDecl GhcPs -> TyClDecl GhcPs
forall pass. XFamDecl pass -> FamilyDecl pass -> TyClDecl pass
FamDecl NoExtField
XFamDecl GhcPs
noExtField (FamilyDecl GhcPs -> TyClDecl GhcPs)
-> FamilyDecl GhcPs -> TyClDecl GhcPs
forall a b. (a -> b) -> a -> b
$
         XCFamilyDecl GhcPs
-> FamilyInfo GhcPs
-> LIdP 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 NoExtField
XCFamilyDecl GhcPs
noExtField FamilyInfo GhcPs
forall pass. FamilyInfo pass
OpenTypeFamily Located RdrName
LIdP GhcPs
tc' LHsQTyVars GhcPs
tyvars' LexicalFixity
Prefix LFamilyResultSig GhcPs
result' Maybe (LInjectivityAnn GhcPs)
injectivity'
       }

cvtDec (ClosedTypeFamilyD TypeFamilyHead
head [TySynEqn]
eqns)
  = do { (Located RdrName
tc', LHsQTyVars GhcPs
tyvars', LFamilyResultSig GhcPs
result', Maybe (LInjectivityAnn GhcPs)
injectivity') <- TypeFamilyHead
-> CvtM
     (Located RdrName, LHsQTyVars GhcPs, LFamilyResultSig GhcPs,
      Maybe (LInjectivityAnn GhcPs))
cvt_tyfam_head TypeFamilyHead
head
       ; [GenLocated SrcSpan (TyFamInstEqn GhcPs)]
eqns' <- (TySynEqn -> CvtM (GenLocated SrcSpan (TyFamInstEqn GhcPs)))
-> [TySynEqn] -> CvtM [GenLocated SrcSpan (TyFamInstEqn GhcPs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TySynEqn -> CvtM (GenLocated SrcSpan (TyFamInstEqn GhcPs))
cvtTySynEqn [TySynEqn]
eqns
       ; HsDecl GhcPs -> CvtM (Maybe (LHsDecl GhcPs))
forall a. a -> CvtM (Maybe (Located a))
returnJustL (HsDecl GhcPs -> CvtM (Maybe (LHsDecl GhcPs)))
-> HsDecl 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 NoExtField
XTyClD GhcPs
noExtField (TyClDecl GhcPs -> HsDecl GhcPs) -> TyClDecl GhcPs -> HsDecl GhcPs
forall a b. (a -> b) -> a -> b
$ XFamDecl GhcPs -> FamilyDecl GhcPs -> TyClDecl GhcPs
forall pass. XFamDecl pass -> FamilyDecl pass -> TyClDecl pass
FamDecl NoExtField
XFamDecl GhcPs
noExtField (FamilyDecl GhcPs -> TyClDecl GhcPs)
-> FamilyDecl GhcPs -> TyClDecl GhcPs
forall a b. (a -> b) -> a -> b
$
         XCFamilyDecl GhcPs
-> FamilyInfo GhcPs
-> LIdP 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 NoExtField
XCFamilyDecl GhcPs
noExtField (Maybe [GenLocated SrcSpan (TyFamInstEqn GhcPs)] -> FamilyInfo GhcPs
forall pass. Maybe [LTyFamInstEqn pass] -> FamilyInfo pass
ClosedTypeFamily ([GenLocated SrcSpan (TyFamInstEqn GhcPs)]
-> Maybe [GenLocated SrcSpan (TyFamInstEqn GhcPs)]
forall a. a -> Maybe a
Just [GenLocated SrcSpan (TyFamInstEqn GhcPs)]
eqns')) Located RdrName
LIdP GhcPs
tc' LHsQTyVars GhcPs
tyvars' LexicalFixity
Prefix
                           LFamilyResultSig GhcPs
result' Maybe (LInjectivityAnn GhcPs)
injectivity' }

cvtDec (TH.RoleAnnotD Name
tc [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 e. e -> Located e
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
       ; HsDecl GhcPs -> CvtM (Maybe (LHsDecl GhcPs))
forall a. a -> CvtM (Maybe (Located a))
returnJustL (HsDecl GhcPs -> CvtM (Maybe (LHsDecl GhcPs)))
-> HsDecl 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 NoExtField
XRoleAnnotD GhcPs
noExtField (XCRoleAnnotDecl GhcPs
-> LIdP GhcPs -> [Located (Maybe Role)] -> RoleAnnotDecl GhcPs
forall pass.
XCRoleAnnotDecl pass
-> Located (IdP pass)
-> [Located (Maybe Role)]
-> RoleAnnotDecl pass
RoleAnnotDecl NoExtField
XCRoleAnnotDecl GhcPs
noExtField Located RdrName
LIdP GhcPs
tc' [Located (Maybe Role)]
roles') }

cvtDec (TH.StandaloneDerivD Maybe DerivStrategy
ds Cxt
cxt Type
ty)
  = do { LHsContext GhcPs
cxt' <- PprPrec -> Cxt -> CvtM (LHsContext GhcPs)
cvtContext PprPrec
funPrec 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
       ; (L SrcSpan
loc HsType 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 -> HsType GhcPs -> LHsType GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc HsType GhcPs
ty'
       ; HsDecl GhcPs -> CvtM (Maybe (LHsDecl GhcPs))
forall a. a -> CvtM (Maybe (Located a))
returnJustL (HsDecl GhcPs -> CvtM (Maybe (LHsDecl GhcPs)))
-> HsDecl 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 NoExtField
XDerivD GhcPs
noExtField (DerivDecl GhcPs -> HsDecl GhcPs)
-> DerivDecl GhcPs -> HsDecl 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 =NoExtField
XCDerivDecl GhcPs
noExtField
                   , 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 Name
nm Type
typ)
  = do { Located RdrName
nm' <- Name -> CvtM (Located RdrName)
vNameL Name
nm
       ; LHsType GhcPs
ty' <- Type -> CvtM (LHsType GhcPs)
cvtType Type
typ
       ; HsDecl GhcPs -> CvtM (Maybe (LHsDecl GhcPs))
forall a. a -> CvtM (Maybe (Located a))
returnJustL (HsDecl GhcPs -> CvtM (Maybe (LHsDecl GhcPs)))
-> HsDecl 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 NoExtField
XSigD GhcPs
noExtField
                     (Sig GhcPs -> HsDecl GhcPs) -> Sig GhcPs -> HsDecl GhcPs
forall a b. (a -> b) -> a -> b
$ XClassOpSig GhcPs
-> Bool -> [LIdP GhcPs] -> LHsSigType GhcPs -> Sig GhcPs
forall pass.
XClassOpSig pass
-> Bool -> [Located (IdP pass)] -> LHsSigType pass -> Sig pass
ClassOpSig NoExtField
XClassOpSig GhcPs
noExtField Bool
True [Located RdrName
LIdP GhcPs
nm'] (LHsType GhcPs -> LHsSigType GhcPs
mkLHsSigType LHsType GhcPs
ty')}

cvtDec (TH.PatSynD Name
nm PatSynArgs
args PatSynDir
dir 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
       ; Located (Pat GhcPs)
pat'  <- Pat -> CvtM (LPat GhcPs)
cvtPat Pat
pat
       ; HsDecl GhcPs -> CvtM (Maybe (LHsDecl GhcPs))
forall a. a -> CvtM (Maybe (Located a))
returnJustL (HsDecl GhcPs -> CvtM (Maybe (LHsDecl GhcPs)))
-> HsDecl 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 NoExtField
XValD GhcPs
noExtField (HsBind GhcPs -> HsDecl GhcPs) -> HsBind GhcPs -> HsDecl 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 NoExtField
XPatSynBind GhcPs GhcPs
noExtField (PatSynBind GhcPs GhcPs -> HsBind GhcPs)
-> PatSynBind GhcPs GhcPs -> HsBind GhcPs
forall a b. (a -> b) -> a -> b
$
           XPSB GhcPs GhcPs
-> LIdP GhcPs
-> HsPatSynDetails (LIdP 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 NoExtField
XPSB GhcPs GhcPs
noExtField Located RdrName
LIdP GhcPs
nm' HsConDetails
  (Located RdrName) [RecordPatSynField (Located RdrName)]
HsPatSynDetails (LIdP GhcPs)
args' Located (Pat GhcPs)
LPat GhcPs
pat' HsPatSynDir GhcPs
dir' }
  where
    cvtArgs :: PatSynArgs
-> CvtM
     (HsConDetails
        (Located RdrName) [RecordPatSynField (Located RdrName)])
cvtArgs (TH.PrefixPatSyn [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 Name
a1 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 [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 Located RdrName
_ PatSynDir
Unidir          = HsPatSynDir GhcPs -> CvtM (HsPatSynDir GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return HsPatSynDir GhcPs
forall id. HsPatSynDir id
Unidirectional
    cvtDir Located RdrName
_ PatSynDir
ImplBidir       = HsPatSynDir GhcPs -> CvtM (HsPatSynDir GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return HsPatSynDir GhcPs
forall id. HsPatSynDir id
ImplicitBidirectional
    cvtDir Located RdrName
n (ExplBidir [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 GhcPs
-> Clause -> CvtM (LMatch GhcPs (LHsExpr GhcPs))
cvtClause (LIdP GhcPs -> HsMatchContext GhcPs
forall p. LIdP p -> HsMatchContext p
mkPrefixFunRhs Located RdrName
LIdP GhcPs
n)) [Clause]
cls
         ; Origin
th_origin <- CvtM Origin
getOrigin
         ; 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)) ~ NoExtField) =>
Origin
-> [LMatch name (Located (body name))]
-> MatchGroup name (Located (body name))
mkMatchGroup Origin
th_origin [LMatch GhcPs (LHsExpr GhcPs)]
ms }

cvtDec (TH.PatSynSigD Name
nm Type
ty)
  = do { Located RdrName
nm' <- Name -> CvtM (Located RdrName)
cNameL Name
nm
       ; LHsType GhcPs
ty' <- Type -> CvtM (LHsType GhcPs)
cvtPatSynSigTy Type
ty
       ; HsDecl GhcPs -> CvtM (Maybe (LHsDecl GhcPs))
forall a. a -> CvtM (Maybe (Located a))
returnJustL (HsDecl GhcPs -> CvtM (Maybe (LHsDecl GhcPs)))
-> HsDecl 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 NoExtField
XSigD GhcPs
noExtField (Sig GhcPs -> HsDecl GhcPs) -> Sig GhcPs -> HsDecl GhcPs
forall a b. (a -> b) -> a -> b
$ XPatSynSig GhcPs -> [LIdP GhcPs] -> LHsSigType GhcPs -> Sig GhcPs
forall pass.
XPatSynSig pass
-> [Located (IdP pass)] -> LHsSigType pass -> Sig pass
PatSynSig NoExtField
XPatSynSig GhcPs
noExtField [Located RdrName
LIdP 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 String
_ Exp
_)
  = MsgDoc -> CvtM (Maybe (LHsDecl GhcPs))
forall a. MsgDoc -> CvtM a
failWith (String -> MsgDoc
text String
"Implicit parameter binding only allowed in let or where")

----------------
cvtTySynEqn :: TySynEqn -> CvtM (LTyFamInstEqn GhcPs)
cvtTySynEqn :: TySynEqn -> CvtM (GenLocated SrcSpan (TyFamInstEqn GhcPs))
cvtTySynEqn (TySynEqn Maybe [TyVarBndr ()]
mb_bndrs Type
lhs 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)
forall flag flag'.
CvtFlag flag flag' =>
TyVarBndr flag -> CvtM (LHsTyVarBndr flag' GhcPs)
cvt_tv) Maybe [TyVarBndr ()]
mb_bndrs
       ; (Type
head_ty, HsTyPats GhcPs
args) <- Type -> CvtM (Type, HsTyPats GhcPs)
split_ty_app Type
lhs
       ; case Type
head_ty of
           ConT 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
                         ; TyFamInstEqn GhcPs
-> CvtM (GenLocated SrcSpan (TyFamInstEqn GhcPs))
forall a. a -> CvtM (Located a)
returnL (TyFamInstEqn GhcPs
 -> CvtM (GenLocated SrcSpan (TyFamInstEqn GhcPs)))
-> TyFamInstEqn GhcPs
-> CvtM (GenLocated SrcSpan (TyFamInstEqn GhcPs))
forall a b. (a -> b) -> a -> b
$ FamEqn GhcPs (LHsType GhcPs) -> TyFamInstEqn GhcPs
forall thing. thing -> HsImplicitBndrs GhcPs thing
mkHsImplicitBndrs
                            (FamEqn GhcPs (LHsType GhcPs) -> TyFamInstEqn GhcPs)
-> FamEqn GhcPs (LHsType GhcPs) -> TyFamInstEqn GhcPs
forall a b. (a -> b) -> a -> b
$ FamEqn :: forall pass rhs.
XCFamEqn pass rhs
-> Located (IdP pass)
-> Maybe [LHsTyVarBndr () pass]
-> HsTyPats pass
-> LexicalFixity
-> rhs
-> FamEqn pass rhs
FamEqn { feqn_ext :: XCFamEqn GhcPs (LHsType GhcPs)
feqn_ext    = NoExtField
XCFamEqn GhcPs (LHsType GhcPs)
noExtField
                                     , feqn_tycon :: LIdP GhcPs
feqn_tycon  = Located RdrName
LIdP 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 Type
t1 Name
nm 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
                                 ; TyFamInstEqn GhcPs
-> CvtM (GenLocated SrcSpan (TyFamInstEqn GhcPs))
forall a. a -> CvtM (Located a)
returnL (TyFamInstEqn GhcPs
 -> CvtM (GenLocated SrcSpan (TyFamInstEqn GhcPs)))
-> TyFamInstEqn GhcPs
-> CvtM (GenLocated SrcSpan (TyFamInstEqn GhcPs))
forall a b. (a -> b) -> a -> b
$ FamEqn GhcPs (LHsType GhcPs) -> TyFamInstEqn GhcPs
forall thing. thing -> HsImplicitBndrs GhcPs thing
mkHsImplicitBndrs
                                      (FamEqn GhcPs (LHsType GhcPs) -> TyFamInstEqn GhcPs)
-> FamEqn GhcPs (LHsType GhcPs) -> TyFamInstEqn GhcPs
forall a b. (a -> b) -> a -> b
$ FamEqn :: forall pass rhs.
XCFamEqn pass rhs
-> Located (IdP pass)
-> Maybe [LHsTyVarBndr () pass]
-> HsTyPats pass
-> LexicalFixity
-> rhs
-> FamEqn pass rhs
FamEqn { feqn_ext :: XCFamEqn GhcPs (LHsType GhcPs)
feqn_ext    = NoExtField
XCFamEqn GhcPs (LHsType GhcPs)
noExtField
                                               , feqn_tycon :: LIdP GhcPs
feqn_tycon  = Located RdrName
LIdP 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' } }
           Type
_ -> MsgDoc -> CvtM (GenLocated SrcSpan (TyFamInstEqn GhcPs))
forall a. MsgDoc -> CvtM a
failWith (MsgDoc -> CvtM (GenLocated SrcSpan (TyFamInstEqn GhcPs)))
-> MsgDoc -> CvtM (GenLocated SrcSpan (TyFamInstEqn GhcPs))
forall a b. (a -> b) -> a -> b
$ String -> MsgDoc
text String
"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 MsgDoc
doc [Dec]
decs
  = do  { [LHsDecl GhcPs]
decs' <- [Dec] -> CvtM [LHsDecl GhcPs]
cvtDecs [Dec]
decs
        ; let ([LTyFamInstDecl GhcPs]
ats', [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 ([LDataFamInstDecl GhcPs]
adts', [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 ([LSig GhcPs]
sigs', [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 ([LHsBind GhcPs]
binds', [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 ([LFamilyDecl GhcPs]
fams', [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))
        ; (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 Name
tc [TyVarBndr ()]
tvs
  = do { LHsContext GhcPs
cxt' <- PprPrec -> Cxt -> CvtM (LHsContext GhcPs)
cvtContext PprPrec
funPrec Cxt
cxt
       ; Located RdrName
tc'  <- Name -> CvtM (Located RdrName)
tconNameL Name
tc
       ; [LHsTyVarBndr () GhcPs]
tvs' <- [TyVarBndr ()] -> CvtM [LHsTyVarBndr () GhcPs]
forall flag flag'.
CvtFlag flag flag' =>
[TyVarBndr flag] -> CvtM [LHsTyVarBndr flag' 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', [LHsTyVarBndr () GhcPs] -> LHsQTyVars GhcPs
mkHsQTvs [LHsTyVarBndr () 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 Maybe [TyVarBndr ()]
bndrs Type
tys
  = do { LHsContext GhcPs
cxt' <- PprPrec -> Cxt -> CvtM (LHsContext GhcPs)
cvtContext PprPrec
funPrec 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)
forall flag flag'.
CvtFlag flag flag' =>
TyVarBndr flag -> CvtM (LHsTyVarBndr flag' GhcPs)
cvt_tv) Maybe [TyVarBndr ()]
bndrs
       ; (Type
head_ty, HsTyPats GhcPs
args) <- Type -> CvtM (Type, HsTyPats GhcPs)
split_ty_app Type
tys
       ; case Type
head_ty of
          ConT 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 Type
t1 Name
nm 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)) }
          Type
_ -> 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 String
"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 Name
tc [TyVarBndr ()]
tyvars FamilyResultSig
result Maybe InjectivityAnn
injectivity)
  = do {(LHsContext GhcPs
_, Located RdrName
tc', 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 (L SrcSpan
loc (TyClD XTyClD GhcPs
_ (FamDecl { tcdFam :: forall pass. TyClDecl pass -> FamilyDecl pass
tcdFam = FamilyDecl GhcPs
d }))) = LFamilyDecl GhcPs -> Either (LFamilyDecl GhcPs) (LHsDecl GhcPs)
forall a b. a -> Either a b
Left (SrcSpan -> FamilyDecl GhcPs -> LFamilyDecl GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc FamilyDecl GhcPs
d)
is_fam_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 (L SrcSpan
loc (Hs.InstD XInstD GhcPs
_ (TyFamInstD { tfid_inst :: forall pass. InstDecl pass -> TyFamInstDecl pass
tfid_inst = TyFamInstDecl GhcPs
d })))
  = LTyFamInstDecl GhcPs
-> Either (LTyFamInstDecl GhcPs) (LHsDecl GhcPs)
forall a b. a -> Either a b
Left (SrcSpan -> TyFamInstDecl GhcPs -> LTyFamInstDecl GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc TyFamInstDecl GhcPs
d)
is_tyfam_inst 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 (L SrcSpan
loc (Hs.InstD  XInstD GhcPs
_ (DataFamInstD { dfid_inst :: forall pass. InstDecl pass -> DataFamInstDecl pass
dfid_inst = DataFamInstDecl GhcPs
d })))
  = LDataFamInstDecl GhcPs
-> Either (LDataFamInstDecl GhcPs) (LHsDecl GhcPs)
forall a b. a -> Either a b
Left (SrcSpan -> DataFamInstDecl GhcPs -> LDataFamInstDecl GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc DataFamInstDecl GhcPs
d)
is_datafam_inst 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 (L SrcSpan
loc (Hs.SigD XSigD GhcPs
_ Sig GhcPs
sig)) = LSig GhcPs -> Either (LSig GhcPs) (LHsDecl GhcPs)
forall a b. a -> Either a b
Left (SrcSpan -> Sig GhcPs -> LSig GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc Sig GhcPs
sig)
is_sig 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 (L SrcSpan
loc (Hs.ValD XValD GhcPs
_ HsBind GhcPs
bind)) = LHsBind GhcPs -> Either (LHsBind GhcPs) (LHsDecl GhcPs)
forall a b. a -> Either a b
Left (SrcSpan -> HsBind GhcPs -> LHsBind GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc HsBind GhcPs
bind)
is_bind 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 String
n Exp
e) = (String, Exp) -> Either (String, Exp) Dec
forall a b. a -> Either a b
Left (String
n, Exp
e)
is_ip_bind Dec
decl             = Dec -> Either (String, Exp) Dec
forall a b. b -> Either a b
Right Dec
decl

mkBadDecMsg :: Outputable a => MsgDoc -> [a] -> MsgDoc
mkBadDecMsg :: forall a. Outputable a => MsgDoc -> [a] -> MsgDoc
mkBadDecMsg MsgDoc
doc [a]
bads
  = [MsgDoc] -> MsgDoc
sep [ String -> MsgDoc
text String
"Illegal declaration(s) in" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc
doc MsgDoc -> MsgDoc -> MsgDoc
<> MsgDoc
colon
        , Int -> MsgDoc -> MsgDoc
nest Int
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 Name
c [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
        ; ConDecl GhcPs -> CvtM (LConDecl GhcPs)
forall a. a -> CvtM (Located a)
returnL (ConDecl GhcPs -> CvtM (LConDecl GhcPs))
-> ConDecl GhcPs -> CvtM (LConDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ Located RdrName
-> Maybe [LHsTyVarBndr Specificity GhcPs]
-> Maybe (LHsContext GhcPs)
-> HsConDeclDetails GhcPs
-> ConDecl GhcPs
mkConDeclH98 Located RdrName
c' Maybe [LHsTyVarBndr Specificity GhcPs]
forall a. Maybe a
Nothing Maybe (LHsContext GhcPs)
forall a. Maybe a
Nothing ([HsScaled GhcPs (LHsType GhcPs)] -> HsConDeclDetails GhcPs
forall arg rec. [arg] -> HsConDetails arg rec
PrefixCon ((LHsType GhcPs -> HsScaled GhcPs (LHsType GhcPs))
-> [LHsType GhcPs] -> [HsScaled GhcPs (LHsType GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map LHsType GhcPs -> HsScaled GhcPs (LHsType GhcPs)
forall a pass. a -> HsScaled pass a
hsLinear [LHsType GhcPs]
tys')) }

cvtConstr (RecC Name
c [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
        ; ConDecl GhcPs -> CvtM (LConDecl GhcPs)
forall a. a -> CvtM (Located a)
returnL (ConDecl GhcPs -> CvtM (LConDecl GhcPs))
-> ConDecl GhcPs -> CvtM (LConDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ Located RdrName
-> Maybe [LHsTyVarBndr Specificity GhcPs]
-> Maybe (LHsContext GhcPs)
-> HsConDeclDetails GhcPs
-> ConDecl GhcPs
mkConDeclH98 Located RdrName
c' Maybe [LHsTyVarBndr Specificity 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 ([LConDeclField GhcPs] -> Located [LConDeclField GhcPs]
forall e. e -> Located e
noLoc [LConDeclField GhcPs]
args')) }

cvtConstr (InfixC BangType
st1 Name
c 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
        ; ConDecl GhcPs -> CvtM (LConDecl GhcPs)
forall a. a -> CvtM (Located a)
returnL (ConDecl GhcPs -> CvtM (LConDecl GhcPs))
-> ConDecl GhcPs -> CvtM (LConDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ Located RdrName
-> Maybe [LHsTyVarBndr Specificity GhcPs]
-> Maybe (LHsContext GhcPs)
-> HsConDeclDetails GhcPs
-> ConDecl GhcPs
mkConDeclH98 Located RdrName
c' Maybe [LHsTyVarBndr Specificity GhcPs]
forall a. Maybe a
Nothing Maybe (LHsContext GhcPs)
forall a. Maybe a
Nothing (HsScaled GhcPs (LHsType GhcPs)
-> HsScaled GhcPs (LHsType GhcPs) -> HsConDeclDetails GhcPs
forall arg rec. arg -> arg -> HsConDetails arg rec
InfixCon (LHsType GhcPs -> HsScaled GhcPs (LHsType GhcPs)
forall a pass. a -> HsScaled pass a
hsLinear LHsType GhcPs
st1')
                                                              (LHsType GhcPs -> HsScaled GhcPs (LHsType GhcPs)
forall a pass. a -> HsScaled pass a
hsLinear LHsType GhcPs
st2')) }

cvtConstr (ForallC [TyVarBndr Specificity]
tvs Cxt
ctxt Con
con)
  = do  { [LHsTyVarBndr Specificity GhcPs]
tvs'      <- [TyVarBndr Specificity] -> CvtM [LHsTyVarBndr Specificity GhcPs]
forall flag flag'.
CvtFlag flag flag' =>
[TyVarBndr flag] -> CvtM [LHsTyVarBndr flag' GhcPs]
cvtTvs [TyVarBndr Specificity]
tvs
        ; LHsContext GhcPs
ctxt'     <- PprPrec -> Cxt -> CvtM (LHsContext GhcPs)
cvtContext PprPrec
funPrec Cxt
ctxt
        ; L SrcSpan
_ ConDecl GhcPs
con'  <- Con -> CvtM (LConDecl GhcPs)
cvtConstr Con
con
        ; ConDecl GhcPs -> CvtM (LConDecl GhcPs)
forall a. a -> CvtM (Located a)
returnL (ConDecl GhcPs -> CvtM (LConDecl GhcPs))
-> ConDecl GhcPs -> CvtM (LConDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ [LHsTyVarBndr Specificity GhcPs]
-> LHsContext GhcPs -> ConDecl GhcPs -> ConDecl GhcPs
add_forall [LHsTyVarBndr Specificity GhcPs]
tvs' LHsContext GhcPs
ctxt' ConDecl GhcPs
con' }
  where
    add_cxt :: GenLocated l [a]
-> Maybe (GenLocated l [a]) -> Maybe (GenLocated l [a])
add_cxt GenLocated l [a]
lcxt         Maybe (GenLocated l [a])
Nothing           = GenLocated l [a] -> Maybe (GenLocated l [a])
forall a. a -> Maybe a
Just GenLocated l [a]
lcxt
    add_cxt (L l
loc [a]
cxt1) (Just (L l
_ [a]
cxt2))
      = GenLocated l [a] -> Maybe (GenLocated l [a])
forall a. a -> Maybe a
Just (l -> [a] -> GenLocated l [a]
forall l e. l -> e -> GenLocated l e
L l
loc ([a]
cxt1 [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
cxt2))

    add_forall :: [LHsTyVarBndr Hs.Specificity GhcPs] -> LHsContext GhcPs
               -> ConDecl GhcPs -> ConDecl GhcPs
    add_forall :: [LHsTyVarBndr Specificity GhcPs]
-> LHsContext GhcPs -> ConDecl GhcPs -> ConDecl GhcPs
add_forall [LHsTyVarBndr Specificity GhcPs]
tvs' LHsContext GhcPs
cxt' con :: ConDecl GhcPs
con@(ConDeclGADT { con_qvars :: forall pass. ConDecl pass -> [LHsTyVarBndr Specificity pass]
con_qvars = [LHsTyVarBndr Specificity 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 = Bool -> Located Bool
forall e. e -> Located e
noLoc (Bool -> Located Bool) -> Bool -> Located Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not ([LHsTyVarBndr Specificity GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LHsTyVarBndr Specificity GhcPs]
all_tvs)
            , con_qvars :: [LHsTyVarBndr Specificity GhcPs]
con_qvars  = [LHsTyVarBndr Specificity GhcPs]
all_tvs
            , con_mb_cxt :: Maybe (LHsContext GhcPs)
con_mb_cxt = LHsContext GhcPs
-> Maybe (LHsContext GhcPs) -> Maybe (LHsContext GhcPs)
forall {l} {a} {l}.
GenLocated l [a]
-> Maybe (GenLocated l [a]) -> Maybe (GenLocated l [a])
add_cxt LHsContext GhcPs
cxt' Maybe (LHsContext GhcPs)
cxt }
      where
        all_tvs :: [LHsTyVarBndr Specificity GhcPs]
all_tvs = [LHsTyVarBndr Specificity GhcPs]
tvs' [LHsTyVarBndr Specificity GhcPs]
-> [LHsTyVarBndr Specificity GhcPs]
-> [LHsTyVarBndr Specificity GhcPs]
forall a. [a] -> [a] -> [a]
++ [LHsTyVarBndr Specificity GhcPs]
qvars

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

cvtConstr (GadtC [] [BangType]
_strtys Type
_ty)
  = MsgDoc -> CvtM (LConDecl GhcPs)
forall a. MsgDoc -> CvtM a
failWith (String -> MsgDoc
text String
"GadtC must have at least one constructor name")

cvtConstr (GadtC [Name]
c [BangType]
strtys 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
ty'     <- Type -> CvtM (LHsType GhcPs)
cvtType Type
ty
        ; ConDecl GhcPs -> CvtM (LConDecl GhcPs)
forall a. a -> CvtM (Located a)
returnL (ConDecl GhcPs -> CvtM (LConDecl GhcPs))
-> ConDecl GhcPs -> CvtM (LConDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ [Located RdrName]
-> HsConDeclDetails GhcPs -> LHsType GhcPs -> ConDecl GhcPs
mk_gadt_decl [Located RdrName]
c' ([HsScaled GhcPs (LHsType GhcPs)] -> HsConDeclDetails GhcPs
forall arg rec. [arg] -> HsConDetails arg rec
PrefixCon ([HsScaled GhcPs (LHsType GhcPs)] -> HsConDeclDetails GhcPs)
-> [HsScaled GhcPs (LHsType GhcPs)] -> HsConDeclDetails GhcPs
forall a b. (a -> b) -> a -> b
$ (LHsType GhcPs -> HsScaled GhcPs (LHsType GhcPs))
-> [LHsType GhcPs] -> [HsScaled GhcPs (LHsType GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map LHsType GhcPs -> HsScaled GhcPs (LHsType GhcPs)
forall a pass. a -> HsScaled pass a
hsLinear [LHsType GhcPs]
args) LHsType GhcPs
ty'}

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

cvtConstr (RecGadtC [Name]
c [VarBangType]
varstrtys 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
        ; ConDecl GhcPs -> CvtM (LConDecl GhcPs)
forall a. a -> CvtM (Located a)
returnL (ConDecl GhcPs -> CvtM (LConDecl GhcPs))
-> ConDecl GhcPs -> CvtM (LConDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ [Located RdrName]
-> HsConDeclDetails GhcPs -> LHsType GhcPs -> ConDecl GhcPs
mk_gadt_decl [Located RdrName]
c' (Located [LConDeclField GhcPs] -> HsConDeclDetails GhcPs
forall arg rec. rec -> HsConDetails arg rec
RecCon (Located [LConDeclField GhcPs] -> HsConDeclDetails GhcPs)
-> Located [LConDeclField GhcPs] -> HsConDeclDetails GhcPs
forall a b. (a -> b) -> a -> b
$ [LConDeclField GhcPs] -> Located [LConDeclField GhcPs]
forall e. e -> Located e
noLoc [LConDeclField GhcPs]
rec_flds) LHsType GhcPs
ty' }

mk_gadt_decl :: [Located RdrName] -> HsConDeclDetails GhcPs -> LHsType GhcPs
             -> ConDecl GhcPs
mk_gadt_decl :: [Located RdrName]
-> HsConDeclDetails GhcPs -> LHsType GhcPs -> ConDecl GhcPs
mk_gadt_decl [Located RdrName]
names HsConDeclDetails GhcPs
args LHsType GhcPs
res_ty
  = ConDeclGADT :: forall pass.
XConDeclGADT pass
-> [Located (IdP pass)]
-> Located Bool
-> [LHsTyVarBndr Specificity pass]
-> Maybe (LHsContext pass)
-> HsConDeclDetails pass
-> LHsType pass
-> Maybe LHsDocString
-> ConDecl pass
ConDeclGADT { con_g_ext :: XConDeclGADT GhcPs
con_g_ext  = NoExtField
XConDeclGADT GhcPs
noExtField
                , con_names :: [LIdP GhcPs]
con_names  = [Located RdrName]
[LIdP GhcPs]
names
                , con_forall :: Located Bool
con_forall = Bool -> Located Bool
forall e. e -> Located e
noLoc Bool
False
                , con_qvars :: [LHsTyVarBndr Specificity GhcPs]
con_qvars  = []
                , con_mb_cxt :: Maybe (LHsContext GhcPs)
con_mb_cxt = Maybe (LHsContext GhcPs)
forall a. Maybe a
Nothing
                , con_args :: HsConDeclDetails GhcPs
con_args   = HsConDeclDetails GhcPs
args
                , con_res_ty :: LHsType GhcPs
con_res_ty = LHsType GhcPs
res_ty
                , con_doc :: Maybe LHsDocString
con_doc    = Maybe LHsDocString
forall a. Maybe a
Nothing }

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

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

cvt_arg :: (TH.Bang, TH.Type) -> CvtM (LHsType GhcPs)
cvt_arg :: BangType -> CvtM (LHsType GhcPs)
cvt_arg (Bang SourceUnpackedness
su SourceStrictness
ss, Type
ty)
  = do { 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
       ; HsType GhcPs -> CvtM (LHsType GhcPs)
forall a. a -> CvtM (Located a)
returnL (HsType GhcPs -> CvtM (LHsType GhcPs))
-> HsType 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 NoExtField
XBangTy GhcPs
noExtField (SourceText -> SrcUnpackedness -> SrcStrictness -> HsSrcBang
HsSrcBang SourceText
NoSourceText SrcUnpackedness
su' SrcStrictness
ss') LHsType GhcPs
ty' }

cvt_id_arg :: (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField GhcPs)
cvt_id_arg :: VarBangType -> CvtM (LConDeclField GhcPs)
cvt_id_arg (Name
i, Bang
str, Type
ty)
  = do  { L SrcSpan
li 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
$ ConDeclField GhcPs -> LConDeclField GhcPs
forall e. e -> Located e
noLoc (ConDeclField :: forall pass.
XConDeclField pass
-> [LFieldOcc pass]
-> LBangType pass
-> Maybe LHsDocString
-> ConDeclField pass
ConDeclField
                          { cd_fld_ext :: XConDeclField GhcPs
cd_fld_ext = NoExtField
XConDeclField GhcPs
noExtField
                          , cd_fld_names :: [LFieldOcc GhcPs]
cd_fld_names
                              = [SrcSpan -> FieldOcc GhcPs -> LFieldOcc GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
li (FieldOcc GhcPs -> LFieldOcc GhcPs)
-> FieldOcc 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 NoExtField
XCFieldOcc GhcPs
noExtField (SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
li 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 [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
                  ; [LHsDerivingClause GhcPs] -> CvtM (HsDeriving GhcPs)
forall a. a -> CvtM (Located a)
returnL [LHsDerivingClause GhcPs]
cs' }

cvt_fundep :: FunDep -> CvtM (LHsFunDep GhcPs)
cvt_fundep :: FunDep -> CvtM (LHsFunDep GhcPs)
cvt_fundep (FunDep [Name]
xs [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
                               ; FunDep (Located RdrName)
-> CvtM (Located (FunDep (Located RdrName)))
forall a. a -> CvtM (Located a)
returnL ([Located RdrName]
xs', [Located RdrName]
ys') }


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

cvtForD :: Foreign -> CvtM (ForeignDecl GhcPs)
cvtForD :: Foreign -> CvtM (ForeignDecl GhcPs)
cvtForD (ImportF Callconv
callconv Safety
safety String
from Name
nm Type
ty)
  -- the prim and javascript calling conventions do not support headers
  -- and are inserted verbatim, analogous to mkImport in GHC.Parser.PostProcess
  | Callconv
callconv 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 (CCallConv -> Located CCallConv
forall e. e -> Located e
noLoc (Callconv -> CCallConv
cvt_conv Callconv
callconv)) (Safety -> Located Safety
forall e. e -> Located e
noLoc Safety
safety') Maybe Header
forall a. Maybe a
Nothing
                    (CCallTarget -> CImportSpec
CFunction (SourceText -> CLabelString -> Maybe Unit -> Bool -> CCallTarget
StaticTarget (String -> SourceText
SourceText String
from)
                                             (String -> CLabelString
mkFastString String
from) Maybe Unit
forall a. Maybe a
Nothing
                                             Bool
True))
                    (SourceText -> Located SourceText
forall e. e -> Located e
noLoc (SourceText -> Located SourceText)
-> SourceText -> Located SourceText
forall a b. (a -> b) -> a -> b
$ String -> SourceText
quotedSourceText String
from))
  | Just ForeignImport
impspec <- Located CCallConv
-> Located Safety
-> CLabelString
-> String
-> Located SourceText
-> Maybe ForeignImport
parseCImport (CCallConv -> Located CCallConv
forall e. e -> Located e
noLoc (Callconv -> CCallConv
cvt_conv Callconv
callconv)) (Safety -> Located Safety
forall e. e -> Located e
noLoc Safety
safety')
                                 (String -> CLabelString
mkFastString (Name -> String
TH.nameBase Name
nm))
                                 String
from (SourceText -> Located SourceText
forall e. e -> Located e
noLoc (SourceText -> Located SourceText)
-> 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 String
"is not a valid ccall impent"
  where
    mk_imp :: ForeignImport -> CvtM (ForeignDecl GhcPs)
mk_imp 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 = NoExtField
XForeignImport GhcPs
noExtField
                                   , fd_name :: LIdP GhcPs
fd_name = Located RdrName
LIdP 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
                     Safety
Unsafe     -> Safety
PlayRisky
                     Safety
Safe       -> Safety
PlaySafe
                     Safety
Interruptible -> Safety
PlayInterruptible

cvtForD (ExportF Callconv
callconv String
as Name
nm 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 (CExportSpec -> Located CExportSpec
forall e. e -> Located e
noLoc (SourceText -> CLabelString -> CCallConv -> CExportSpec
CExportStatic (String -> SourceText
SourceText String
as)
                                                (String -> CLabelString
mkFastString String
as)
                                                (Callconv -> CCallConv
cvt_conv Callconv
callconv)))
                                                (SourceText -> Located SourceText
forall e. e -> Located e
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 = NoExtField
XForeignExport GhcPs
noExtField
                                 , fd_name :: LIdP GhcPs
fd_name = Located RdrName
LIdP 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 Callconv
TH.CCall      = CCallConv
CCallConv
cvt_conv Callconv
TH.StdCall    = CCallConv
StdCallConv
cvt_conv Callconv
TH.CApi       = CCallConv
CApiConv
cvt_conv Callconv
TH.Prim       = CCallConv
PrimCallConv
cvt_conv Callconv
TH.JavaScript = CCallConv
JavaScriptCallConv

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

cvtPragmaD :: Pragma -> CvtM (Maybe (LHsDecl GhcPs))
cvtPragmaD :: Pragma -> CvtM (Maybe (LHsDecl GhcPs))
cvtPragmaD (InlineP Name
nm Inline
inline RuleMatch
rm Phases
phases)
  = do { Located RdrName
nm' <- Name -> CvtM (Located RdrName)
vNameL Name
nm
       ; let dflt :: Activation
dflt = Inline -> Activation
dfltActivation Inline
inline
       ; let src :: Inline -> String
src Inline
TH.NoInline  = String
"{-# NOINLINE"
             src Inline
TH.Inline    = String
"{-# INLINE"
             src Inline
TH.Inlinable = String
"{-# INLINABLE"
       ; let ip :: InlinePragma
ip   = InlinePragma :: 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 }
       ; HsDecl GhcPs -> CvtM (Maybe (LHsDecl GhcPs))
forall a. a -> CvtM (Maybe (Located a))
returnJustL (HsDecl GhcPs -> CvtM (Maybe (LHsDecl GhcPs)))
-> HsDecl 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 NoExtField
XSigD GhcPs
noExtField (Sig GhcPs -> HsDecl GhcPs) -> Sig GhcPs -> HsDecl GhcPs
forall a b. (a -> b) -> a -> b
$ XInlineSig GhcPs -> LIdP GhcPs -> InlinePragma -> Sig GhcPs
forall pass.
XInlineSig pass -> Located (IdP pass) -> InlinePragma -> Sig pass
InlineSig NoExtField
XInlineSig GhcPs
noExtField Located RdrName
LIdP GhcPs
nm' InlinePragma
ip }

cvtPragmaD (SpecialiseP Name
nm Type
ty Maybe Inline
inline 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 Inline
TH.NoInline  = String
"{-# SPECIALISE NOINLINE"
             src Inline
TH.Inline    = String
"{-# SPECIALISE INLINE"
             src Inline
TH.Inlinable = String
"{-# SPECIALISE INLINE"
       ; let (InlineSpec
inline', Activation
dflt,String
srcText) = case Maybe Inline
inline of
               Just Inline
inline1 -> (Inline -> InlineSpec
cvtInline Inline
inline1, Inline -> Activation
dfltActivation Inline
inline1,
                                Inline -> String
src Inline
inline1)
               Maybe Inline
Nothing      -> (InlineSpec
NoUserInline,   Activation
AlwaysActive,
                                String
"{-# 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 }
       ; HsDecl GhcPs -> CvtM (Maybe (LHsDecl GhcPs))
forall a. a -> CvtM (Maybe (Located a))
returnJustL (HsDecl GhcPs -> CvtM (Maybe (LHsDecl GhcPs)))
-> HsDecl 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 NoExtField
XSigD GhcPs
noExtField (Sig GhcPs -> HsDecl GhcPs) -> Sig GhcPs -> HsDecl GhcPs
forall a b. (a -> b) -> a -> b
$ XSpecSig GhcPs
-> LIdP GhcPs -> [LHsSigType GhcPs] -> InlinePragma -> Sig GhcPs
forall pass.
XSpecSig pass
-> Located (IdP pass)
-> [LHsSigType pass]
-> InlinePragma
-> Sig pass
SpecSig NoExtField
XSpecSig GhcPs
noExtField Located RdrName
LIdP GhcPs
nm' [LHsType GhcPs -> LHsSigType GhcPs
mkLHsSigType LHsType GhcPs
ty'] InlinePragma
ip }

cvtPragmaD (SpecialiseInstP Type
ty)
  = do { LHsType GhcPs
ty' <- Type -> CvtM (LHsType GhcPs)
cvtType Type
ty
       ; HsDecl GhcPs -> CvtM (Maybe (LHsDecl GhcPs))
forall a. a -> CvtM (Maybe (Located a))
returnJustL (HsDecl GhcPs -> CvtM (Maybe (LHsDecl GhcPs)))
-> HsDecl 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 NoExtField
XSigD GhcPs
noExtField (Sig GhcPs -> HsDecl GhcPs) -> Sig GhcPs -> HsDecl 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 NoExtField
XSpecInstSig GhcPs
noExtField (String -> SourceText
SourceText String
"{-# SPECIALISE") (LHsType GhcPs -> LHsSigType GhcPs
mkLHsSigType LHsType GhcPs
ty') }

cvtPragmaD (RuleP String
nm Maybe [TyVarBndr ()]
ty_bndrs [RuleBndr]
tm_bndrs Exp
lhs Exp
rhs Phases
phases)
  = do { let nm' :: CLabelString
nm' = String -> CLabelString
mkFastString String
nm
       ; let act :: Activation
act = Phases -> Activation -> Activation
cvtPhases Phases
phases Activation
AlwaysActive
       ; Maybe [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]
forall flag flag'.
CvtFlag flag flag' =>
[TyVarBndr flag] -> CvtM [LHsTyVarBndr flag' GhcPs]
cvtTvs 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
       ; HsDecl GhcPs -> CvtM (Maybe (LHsDecl GhcPs))
forall a. a -> CvtM (Maybe (Located a))
returnJustL (HsDecl GhcPs -> CvtM (Maybe (LHsDecl GhcPs)))
-> HsDecl 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 NoExtField
XRuleD GhcPs
noExtField
            (RuleDecls GhcPs -> HsDecl GhcPs)
-> RuleDecls GhcPs -> HsDecl 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 = NoExtField
XCRuleDecls GhcPs
noExtField
                      , rds_src :: SourceText
rds_src = String -> SourceText
SourceText String
"{-# RULES"
                      , rds_rules :: [LRuleDecl GhcPs]
rds_rules = [RuleDecl GhcPs -> LRuleDecl GhcPs
forall e. e -> Located e
noLoc (RuleDecl GhcPs -> LRuleDecl GhcPs)
-> RuleDecl 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  = NoExtField
XHsRule GhcPs
noExtField
                                 , rd_name :: Located (SourceText, CLabelString)
rd_name = ((SourceText, CLabelString) -> Located (SourceText, CLabelString)
forall e. e -> Located e
noLoc (String -> SourceText
quotedSourceText String
nm,CLabelString
nm'))
                                 , rd_act :: Activation
rd_act  = Activation
act
                                 , rd_tyvs :: Maybe [LHsTyVarBndr () (NoGhcTc GhcPs)]
rd_tyvs = Maybe [LHsTyVarBndr () GhcPs]
Maybe [LHsTyVarBndr () (NoGhcTc 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 AnnTarget
target Exp
exp)
  = do { LHsExpr GhcPs
exp' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
exp
       ; AnnProvenance RdrName
target' <- case AnnTarget
target of
         AnnTarget
ModuleAnnotation  -> AnnProvenance RdrName -> CvtM (AnnProvenance RdrName)
forall (m :: * -> *) a. Monad m => a -> m a
return AnnProvenance RdrName
forall name. AnnProvenance name
ModuleAnnProvenance
         TypeAnnotation 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  (RdrName -> Located RdrName
forall e. e -> Located e
noLoc RdrName
n'))
         ValueAnnotation 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 (RdrName -> Located RdrName
forall e. e -> Located e
noLoc RdrName
n'))
       ; HsDecl GhcPs -> CvtM (Maybe (LHsDecl GhcPs))
forall a. a -> CvtM (Maybe (Located a))
returnJustL (HsDecl GhcPs -> CvtM (Maybe (LHsDecl GhcPs)))
-> HsDecl 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 NoExtField
XAnnD GhcPs
noExtField
                     (AnnDecl GhcPs -> HsDecl GhcPs) -> AnnDecl GhcPs -> HsDecl 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 NoExtField
XHsAnnotation GhcPs
noExtField (String -> SourceText
SourceText String
"{-# ANN") AnnProvenance RdrName
AnnProvenance (IdP GhcPs)
target' LHsExpr GhcPs
exp'
       }

cvtPragmaD (LineP Int
line String
file)
  = do { SrcSpan -> CvtM ()
setL (SrcLoc -> SrcSpan
srcLocSpan (CLabelString -> Int -> Int -> SrcLoc
mkSrcLoc (String -> CLabelString
fsLit String
file) Int
line Int
1))
       ; 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 [Name]
cls Maybe Name
mty)
  = do { Located [Located RdrName]
cls' <- [Located RdrName] -> Located [Located RdrName]
forall e. e -> Located e
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
       ; HsDecl GhcPs -> CvtM (Maybe (LHsDecl GhcPs))
forall a. a -> CvtM (Maybe (Located a))
returnJustL (HsDecl GhcPs -> CvtM (Maybe (LHsDecl GhcPs)))
-> HsDecl 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 NoExtField
XSigD GhcPs
noExtField
                   (Sig GhcPs -> HsDecl GhcPs) -> Sig GhcPs -> HsDecl GhcPs
forall a b. (a -> b) -> a -> b
$ XCompleteMatchSig GhcPs
-> SourceText
-> Located [LIdP GhcPs]
-> Maybe (LIdP GhcPs)
-> Sig GhcPs
forall pass.
XCompleteMatchSig pass
-> SourceText
-> Located [Located (IdP pass)]
-> Maybe (Located (IdP pass))
-> Sig pass
CompleteMatchSig NoExtField
XCompleteMatchSig GhcPs
noExtField SourceText
NoSourceText Located [Located RdrName]
Located [LIdP GhcPs]
cls' Maybe (Located RdrName)
Maybe (LIdP GhcPs)
mty' }

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

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

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

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

cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.LRuleBndr GhcPs)
cvtRuleBndr :: RuleBndr -> CvtM (LRuleBndr GhcPs)
cvtRuleBndr (RuleVar Name
n)
  = do { 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
$ RuleBndr GhcPs -> LRuleBndr GhcPs
forall e. e -> Located e
noLoc (RuleBndr GhcPs -> LRuleBndr GhcPs)
-> RuleBndr GhcPs -> LRuleBndr GhcPs
forall a b. (a -> b) -> a -> b
$ XCRuleBndr GhcPs -> LIdP GhcPs -> RuleBndr GhcPs
forall pass. XCRuleBndr pass -> Located (IdP pass) -> RuleBndr pass
Hs.RuleBndr NoExtField
XCRuleBndr GhcPs
noExtField Located RdrName
LIdP GhcPs
n' }
cvtRuleBndr (TypedRuleVar Name
n 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
$ RuleBndr GhcPs -> LRuleBndr GhcPs
forall e. e -> Located e
noLoc (RuleBndr GhcPs -> LRuleBndr GhcPs)
-> RuleBndr GhcPs -> LRuleBndr GhcPs
forall a b. (a -> b) -> a -> b
$ XRuleBndrSig GhcPs
-> LIdP GhcPs -> HsPatSigType GhcPs -> RuleBndr GhcPs
forall pass.
XRuleBndrSig pass
-> Located (IdP pass) -> HsPatSigType pass -> RuleBndr pass
Hs.RuleBndrSig NoExtField
XRuleBndrSig GhcPs
noExtField Located RdrName
LIdP GhcPs
n' (HsPatSigType GhcPs -> RuleBndr GhcPs)
-> HsPatSigType GhcPs -> RuleBndr GhcPs
forall a b. (a -> b) -> a -> b
$ LHsType GhcPs -> HsPatSigType GhcPs
mkHsPatSigType LHsType GhcPs
ty' }

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

cvtLocalDecs :: MsgDoc -> [TH.Dec] -> CvtM (HsLocalBinds GhcPs)
cvtLocalDecs :: MsgDoc -> [Dec] -> CvtM (HsLocalBinds GhcPs)
cvtLocalDecs MsgDoc
doc [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 NoExtField
XEmptyLocalBinds GhcPs GhcPs
noExtField)
      ([], [Dec]
_) -> do
        [LHsDecl GhcPs]
ds' <- [Dec] -> CvtM [LHsDecl GhcPs]
cvtDecs [Dec]
ds
        let ([LHsBind GhcPs]
binds, [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 ([LSig GhcPs]
sigs, [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 NoExtField
XHsValBinds GhcPs GhcPs
noExtField (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 NoExtField
XValBinds GhcPs GhcPs
noExtField ([LHsBind GhcPs] -> LHsBinds GhcPs
forall a. [a] -> Bag a
listToBag [LHsBind GhcPs]
binds) [LSig GhcPs]
sigs))
      ([(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 NoExtField
XHsIPBinds GhcPs GhcPs
noExtField (XIPBinds GhcPs -> [LIPBind GhcPs] -> HsIPBinds GhcPs
forall id. XIPBinds id -> [LIPBind id] -> HsIPBinds id
IPBinds NoExtField
XIPBinds GhcPs
noExtField [LIPBind GhcPs]
binds))
      (((String, Exp)
_:[(String, Exp)]
_), (Dec
_:[Dec]
_)) ->
        MsgDoc -> CvtM (HsLocalBinds GhcPs)
forall a. MsgDoc -> CvtM a
failWith (String -> MsgDoc
text String
"Implicit parameters mixed with other bindings")

cvtClause :: HsMatchContext GhcPs
          -> TH.Clause -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))
cvtClause :: HsMatchContext GhcPs
-> Clause -> CvtM (LMatch GhcPs (LHsExpr GhcPs))
cvtClause HsMatchContext GhcPs
ctxt (Clause [Pat]
ps Body
body [Dec]
wheres)
  = do  { [Located (Pat GhcPs)]
ps' <- [Pat] -> CvtM [LPat GhcPs]
cvtPats [Pat]
ps
        ; let pps :: [Located (Pat GhcPs)]
pps = (Located (Pat GhcPs) -> Located (Pat GhcPs))
-> [Located (Pat GhcPs)] -> [Located (Pat GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map (PprPrec -> LPat GhcPs -> LPat GhcPs
forall (p :: Pass).
IsPass p =>
PprPrec -> LPat (GhcPass p) -> LPat (GhcPass p)
parenthesizePat PprPrec
appPrec) [Located (Pat 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 String
"a where clause") [Dec]
wheres
        ; Match GhcPs (LHsExpr GhcPs) -> CvtM (LMatch GhcPs (LHsExpr GhcPs))
forall a. a -> CvtM (Located a)
returnL (Match GhcPs (LHsExpr GhcPs)
 -> CvtM (LMatch GhcPs (LHsExpr GhcPs)))
-> Match GhcPs (LHsExpr GhcPs)
-> CvtM (LMatch GhcPs (LHsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ XCMatch GhcPs (LHsExpr GhcPs)
-> HsMatchContext (NoGhcTc GhcPs)
-> [LPat GhcPs]
-> GRHSs GhcPs (LHsExpr GhcPs)
-> Match GhcPs (LHsExpr GhcPs)
forall p body.
XCMatch p body
-> HsMatchContext (NoGhcTc p)
-> [LPat p]
-> GRHSs p body
-> Match p body
Hs.Match NoExtField
XCMatch GhcPs (LHsExpr GhcPs)
noExtField HsMatchContext GhcPs
HsMatchContext (NoGhcTc GhcPs)
ctxt [Located (Pat GhcPs)]
[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 NoExtField
XCGRHSs GhcPs (LHsExpr GhcPs)
noExtField [LGRHS GhcPs (LHsExpr GhcPs)]
g' (HsLocalBinds GhcPs -> LHsLocalBinds GhcPs
forall e. e -> Located e
noLoc HsLocalBinds GhcPs
ds')) }

cvtImplicitParamBind :: String -> TH.Exp -> CvtM (LIPBind GhcPs)
cvtImplicitParamBind :: String -> Exp -> CvtM (LIPBind GhcPs)
cvtImplicitParamBind String
n Exp
e = do
    Located HsIPName
n' <- CvtM HsIPName -> CvtM (Located HsIPName)
forall a. CvtM a -> CvtM (Located a)
wrapL (String -> CvtM HsIPName
ipName String
n)
    LHsExpr GhcPs
e' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
e
    IPBind GhcPs -> CvtM (LIPBind GhcPs)
forall a. a -> CvtM (Located 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 NoExtField
XCIPBind GhcPs
noExtField (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 Exp
e = CvtM (HsExpr GhcPs) -> CvtM (LHsExpr GhcPs)
forall a. CvtM a -> CvtM (Located a)
wrapL (Exp -> CvtM (HsExpr GhcPs)
cvt Exp
e)
  where
    cvt :: Exp -> CvtM (HsExpr GhcPs)
cvt (VarE Name
s)        = do { RdrName
s' <- Name -> CvtM RdrName
vName Name
s; 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 -> LIdP GhcPs -> HsExpr GhcPs
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar NoExtField
XVar GhcPs
noExtField (RdrName -> Located RdrName
forall e. e -> Located e
noLoc RdrName
s') }
    cvt (ConE 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 -> LIdP GhcPs -> HsExpr GhcPs
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar NoExtField
XVar GhcPs
noExtField (RdrName -> Located RdrName
forall e. e -> Located e
noLoc RdrName
s') }
    cvt (LitE 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 NoExtField
XOverLitE GhcPs
noExtField)
                             (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 NoExtField
XLitE GhcPs
noExtField)
                             (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 :: forall (l :: * -> *).
(Lit -> CvtM (l GhcPs))
-> (l GhcPs -> HsExpr GhcPs)
-> (l GhcPs -> Bool)
-> CvtM (HsExpr GhcPs)
go Lit -> CvtM (l GhcPs)
cvt_lit l GhcPs -> HsExpr GhcPs
mk_expr l GhcPs -> Bool
is_compound_lit = do
          l GhcPs
l' <- Lit -> CvtM (l GhcPs)
cvt_lit Lit
l
          let e' :: HsExpr GhcPs
e' = l GhcPs -> HsExpr GhcPs
mk_expr l GhcPs
l'
          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 NoExtField
XPar GhcPs
noExtField (HsExpr GhcPs -> LHsExpr GhcPs
forall e. e -> Located e
noLoc HsExpr GhcPs
e') else HsExpr GhcPs
e'
    cvt (AppE x :: Exp
x@(LamE [Pat]
_ Exp
_) 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 NoExtField
XApp GhcPs
noExtField (LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkLHsPar LHsExpr GhcPs
x')
                                                          (LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkLHsPar LHsExpr GhcPs
y')}
    cvt (AppE Exp
x 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 NoExtField
XApp GhcPs
noExtField (LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkLHsPar LHsExpr GhcPs
x')
                                                          (LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkLHsPar LHsExpr GhcPs
y')}
    cvt (AppTypeE Exp
e 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 NoExtField
XAppTypeE GhcPs
noExtField 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 [] Exp
e)    = Exp -> CvtM (HsExpr GhcPs)
cvt Exp
e -- Degenerate case. We convert the body as its
                               -- own expression to avoid pretty-printing
                               -- oddities that can result from zero-argument
                               -- lambda expressions. See #13856.
    cvt (LamE [Pat]
ps Exp
e)    = do { [Located (Pat GhcPs)]
ps' <- [Pat] -> CvtM [LPat GhcPs]
cvtPats [Pat]
ps; LHsExpr GhcPs
e' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
e
                            ; let pats :: [Located (Pat GhcPs)]
pats = (Located (Pat GhcPs) -> Located (Pat GhcPs))
-> [Located (Pat GhcPs)] -> [Located (Pat GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map (PprPrec -> LPat GhcPs -> LPat GhcPs
forall (p :: Pass).
IsPass p =>
PprPrec -> LPat (GhcPass p) -> LPat (GhcPass p)
parenthesizePat PprPrec
appPrec) [Located (Pat GhcPs)]
ps'
                            ; Origin
th_origin <- CvtM Origin
getOrigin
                            ; 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 NoExtField
XLam GhcPs
noExtField (Origin
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> MatchGroup GhcPs (LHsExpr GhcPs)
forall name (body :: * -> *).
(XMG name (Located (body name)) ~ NoExtField) =>
Origin
-> [LMatch name (Located (body name))]
-> MatchGroup name (Located (body name))
mkMatchGroup Origin
th_origin
                                             [HsMatchContext (NoGhcTc GhcPs)
-> [LPat GhcPs] -> LHsExpr GhcPs -> LMatch GhcPs (LHsExpr GhcPs)
forall (p :: Pass) (body :: * -> *).
HsMatchContext (NoGhcTc (GhcPass p))
-> [LPat (GhcPass p)]
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkSimpleMatch HsMatchContext (NoGhcTc GhcPs)
forall p. HsMatchContext p
LambdaExpr
                                             [Located (Pat GhcPs)]
[LPat GhcPs]
pats LHsExpr GhcPs
e'])}
    cvt (LamCaseE [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 GhcPs
-> Match -> CvtM (LMatch GhcPs (LHsExpr GhcPs))
cvtMatch HsMatchContext GhcPs
forall p. HsMatchContext p
CaseAlt) [Match]
ms
                            ; Origin
th_origin <- CvtM Origin
getOrigin
                            ; 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 NoExtField
XLamCase GhcPs
noExtField
                                                   (Origin
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> MatchGroup GhcPs (LHsExpr GhcPs)
forall name (body :: * -> *).
(XMG name (Located (body name)) ~ NoExtField) =>
Origin
-> [LMatch name (Located (body name))]
-> MatchGroup name (Located (body name))
mkMatchGroup Origin
th_origin [LMatch GhcPs (LHsExpr GhcPs)]
ms')
                            }
    cvt (TupE [Maybe Exp]
es)        = [Maybe Exp] -> Boxity -> CvtM (HsExpr GhcPs)
cvt_tup [Maybe Exp]
es Boxity
Boxed
    cvt (UnboxedTupE [Maybe Exp]
es) = [Maybe Exp] -> Boxity -> CvtM (HsExpr GhcPs)
cvt_tup [Maybe Exp]
es Boxity
Unboxed
    cvt (UnboxedSumE Exp
e Int
alt Int
arity) = do { 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 NoExtField
XExplicitSum GhcPs
noExtField
                                                                   Int
alt Int
arity LHsExpr GhcPs
e'}
    cvt (CondE Exp
x Exp
y 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
$ LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
mkHsIf LHsExpr GhcPs
x' LHsExpr GhcPs
y' LHsExpr GhcPs
z' }
    cvt (MultiIfE [(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 String
"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 NoExtField
XMultiIf GhcPs
noExtField [LGRHS GhcPs (LHsExpr GhcPs)]
alts' }
    cvt (LetE [Dec]
ds Exp
e)    = do { HsLocalBinds GhcPs
ds' <- MsgDoc -> [Dec] -> CvtM (HsLocalBinds GhcPs)
cvtLocalDecs (String -> MsgDoc
text String
"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 NoExtField
XLet GhcPs
noExtField (HsLocalBinds GhcPs -> LHsLocalBinds GhcPs
forall e. e -> Located e
noLoc HsLocalBinds GhcPs
ds') LHsExpr GhcPs
e'}
    cvt (CaseE Exp
e [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 GhcPs
-> Match -> CvtM (LMatch GhcPs (LHsExpr GhcPs))
cvtMatch HsMatchContext GhcPs
forall p. HsMatchContext p
CaseAlt) [Match]
ms
                            ; Origin
th_origin <- CvtM Origin
getOrigin
                            ; 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 NoExtField
XCase GhcPs
noExtField LHsExpr GhcPs
e'
                                                 (Origin
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> MatchGroup GhcPs (LHsExpr GhcPs)
forall name (body :: * -> *).
(XMG name (Located (body name)) ~ NoExtField) =>
Origin
-> [LMatch name (Located (body name))]
-> MatchGroup name (Located (body name))
mkMatchGroup Origin
th_origin [LMatch GhcPs (LHsExpr GhcPs)]
ms') }
    cvt (DoE Maybe ModName
m [Stmt]
ss)     = HsStmtContext GhcRn -> [Stmt] -> CvtM (HsExpr GhcPs)
cvtHsDo (Maybe ModuleName -> HsStmtContext GhcRn
forall p. Maybe ModuleName -> HsStmtContext p
DoExpr (ModName -> ModuleName
mk_mod (ModName -> ModuleName) -> Maybe ModName -> Maybe ModuleName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ModName
m)) [Stmt]
ss
    cvt (MDoE Maybe ModName
m [Stmt]
ss)    = HsStmtContext GhcRn -> [Stmt] -> CvtM (HsExpr GhcPs)
cvtHsDo (Maybe ModuleName -> HsStmtContext GhcRn
forall p. Maybe ModuleName -> HsStmtContext p
MDoExpr (ModName -> ModuleName
mk_mod (ModName -> ModuleName) -> Maybe ModName -> Maybe ModuleName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ModName
m)) [Stmt]
ss
    cvt (CompE [Stmt]
ss)     = HsStmtContext GhcRn -> [Stmt] -> CvtM (HsExpr GhcPs)
cvtHsDo HsStmtContext GhcRn
forall p. HsStmtContext p
ListComp [Stmt]
ss
    cvt (ArithSeqE 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 NoExtField
XArithSeq GhcPs
noExtField Maybe (SyntaxExpr GhcPs)
forall a. Maybe a
Nothing ArithSeqInfo GhcPs
dd' }
    cvt (ListE [Exp]
xs)
      | Just String
s <- [Exp] -> Maybe String
allCharLs [Exp]
xs       = do { HsLit GhcPs
l' <- Lit -> CvtM (HsLit GhcPs)
cvtLit (String -> Lit
StringL String
s)
                                          ; 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 NoExtField
XLitE GhcPs
noExtField 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 NoExtField
XExplicitList GhcPs
noExtField Maybe (SyntaxExpr GhcPs)
forall a. Maybe a
Nothing [LHsExpr GhcPs]
xs'
                             }

    -- Infix expressions
    cvt (InfixE (Just Exp
x) Exp
s (Just Exp
y)) = Exp -> CvtM (HsExpr GhcPs) -> CvtM (HsExpr GhcPs)
forall a. Exp -> CvtM a -> CvtM a
ensureValidOpExp Exp
s (CvtM (HsExpr GhcPs) -> CvtM (HsExpr GhcPs))
-> CvtM (HsExpr GhcPs) -> CvtM (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$
      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).
IsPass p =>
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).
IsPass p =>
PprPrec -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
parenthesizeHsExpr PprPrec
opPrec LHsExpr GhcPs
y'
         ; (LHsExpr GhcPs -> HsExpr GhcPs)
-> HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall a. (Located a -> a) -> a -> CvtM a
wrapParL (XPar GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar NoExtField
XPar GhcPs
noExtField)
           (HsExpr GhcPs -> CvtM (HsExpr GhcPs))
-> HsExpr 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 NoExtField
XOpApp GhcPs
noExtField 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 Maybe Exp
Nothing  Exp
s (Just Exp
y)) = Exp -> CvtM (HsExpr GhcPs) -> CvtM (HsExpr GhcPs)
forall a. Exp -> CvtM a -> CvtM a
ensureValidOpExp Exp
s (CvtM (HsExpr GhcPs) -> CvtM (HsExpr GhcPs))
-> CvtM (HsExpr GhcPs) -> CvtM (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$
                                       do { LHsExpr GhcPs
s' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
s; LHsExpr GhcPs
y' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
y
                                          ; (LHsExpr GhcPs -> HsExpr GhcPs)
-> HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall a. (Located a -> a) -> a -> CvtM a
wrapParL (XPar GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar NoExtField
XPar GhcPs
noExtField) (HsExpr GhcPs -> CvtM (HsExpr GhcPs))
-> HsExpr 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 NoExtField
XSectionR GhcPs
noExtField LHsExpr GhcPs
s' LHsExpr GhcPs
y' }
                                            -- See Note [Sections in HsSyn] in GHC.Hs.Expr
    cvt (InfixE (Just Exp
x) Exp
s Maybe Exp
Nothing ) = Exp -> CvtM (HsExpr GhcPs) -> CvtM (HsExpr GhcPs)
forall a. Exp -> CvtM a -> CvtM a
ensureValidOpExp Exp
s (CvtM (HsExpr GhcPs) -> CvtM (HsExpr GhcPs))
-> CvtM (HsExpr GhcPs) -> CvtM (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$
                                       do { LHsExpr GhcPs
x' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
x; LHsExpr GhcPs
s' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
s
                                          ; (LHsExpr GhcPs -> HsExpr GhcPs)
-> HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall a. (Located a -> a) -> a -> CvtM a
wrapParL (XPar GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar NoExtField
XPar GhcPs
noExtField) (HsExpr GhcPs -> CvtM (HsExpr GhcPs))
-> HsExpr 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 NoExtField
XSectionL GhcPs
noExtField LHsExpr GhcPs
x' LHsExpr GhcPs
s' }

    cvt (InfixE Maybe Exp
Nothing  Exp
s Maybe Exp
Nothing ) = Exp -> CvtM (HsExpr GhcPs) -> CvtM (HsExpr GhcPs)
forall a. Exp -> CvtM a -> CvtM a
ensureValidOpExp Exp
s (CvtM (HsExpr GhcPs) -> CvtM (HsExpr GhcPs))
-> CvtM (HsExpr GhcPs) -> CvtM (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$
                                       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 NoExtField
XPar GhcPs
noExtField LHsExpr GhcPs
s' }
                                       -- Can I indicate this is an infix thing?
                                       -- Note [Dropping constructors]

    cvt (UInfixE Exp
x Exp
s Exp
y)  = Exp -> CvtM (HsExpr GhcPs) -> CvtM (HsExpr GhcPs)
forall a. Exp -> CvtM a -> CvtM a
ensureValidOpExp Exp
s (CvtM (HsExpr GhcPs) -> CvtM (HsExpr GhcPs))
-> CvtM (HsExpr GhcPs) -> CvtM (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$
                           do { LHsExpr GhcPs
x' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
x
                              ; let x'' :: LHsExpr GhcPs
x'' = case LHsExpr GhcPs -> HsExpr GhcPs
forall l e. GenLocated l e -> e
unLoc LHsExpr GhcPs
x' of
                                            OpApp {} -> LHsExpr GhcPs
x'
                                            HsExpr GhcPs
_ -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
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 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 NoExtField
XPar GhcPs
noExtField LHsExpr GhcPs
e' }
    cvt (SigE Exp
e 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).
IsPass p =>
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 NoExtField
XExprWithTySig GhcPs
noExtField LHsExpr GhcPs
pe (LHsType GhcPs -> LHsSigWcType GhcPs
mkLHsSigWcType LHsType GhcPs
t') }
    cvt (RecConE Name
c [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 e. e -> Located e
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 (Located Int) -> HsRecordBinds GhcPs
forall p arg.
[LHsRecField p arg] -> Maybe (Located Int) -> HsRecFields p arg
HsRecFields [LHsRecField' (FieldOcc GhcPs) (LHsExpr GhcPs)]
flds' Maybe (Located Int)
forall a. Maybe a
Nothing) }
    cvt (RecUpdE Exp
e [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 e. e -> Located e
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 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 NoExtField
XStatic GhcPs
noExtField) (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 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 -> LIdP GhcPs -> HsExpr GhcPs
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar NoExtField
XVar GhcPs
noExtField (RdrName -> Located RdrName
forall e. e -> Located e
noLoc RdrName
s') }
    cvt (LabelE 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 NoExtField
XOverLabel GhcPs
noExtField Maybe (IdP GhcPs)
forall a. Maybe a
Nothing (String -> CLabelString
fsLit String
s) }
    cvt (ImplicitParamVarE 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 NoExtField
XIPVar GhcPs
noExtField HsIPName
n' }

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

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

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

The constructors `ensureValidOpExp` permits should be in sync with `pprInfixExp`
in Language.Haskell.TH.Ppr from the template-haskell library.
-}
ensureValidOpExp :: TH.Exp -> CvtM a -> CvtM a
ensureValidOpExp :: forall a. Exp -> CvtM a -> CvtM a
ensureValidOpExp (VarE Name
_n) CvtM a
m = CvtM a
m
ensureValidOpExp (ConE Name
_n) CvtM a
m = CvtM a
m
ensureValidOpExp (UnboundVarE Name
_n) CvtM a
m = CvtM a
m
ensureValidOpExp Exp
_e CvtM a
_m =
    MsgDoc -> CvtM a
forall a. MsgDoc -> CvtM a
failWith (String -> MsgDoc
text String
"Non-variable expression is not allowed in an infix expression")

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

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

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

  OpApp (OpApp x * y) + z

which we don't want.
-}

cvtFld :: (RdrName -> t) -> (TH.Name, TH.Exp)
       -> CvtM (LHsRecField' t (LHsExpr GhcPs))
cvtFld :: forall t.
(RdrName -> t) -> FieldExp -> CvtM (LHsRecField' t (LHsExpr GhcPs))
cvtFld RdrName -> t
f (Name
v,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 (HsRecField' t (LHsExpr GhcPs) -> LHsRecField' t (LHsExpr GhcPs)
forall e. e -> Located e
noLoc (HsRecField' t (LHsExpr GhcPs) -> LHsRecField' t (LHsExpr GhcPs))
-> HsRecField' 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 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 Exp
x 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 Exp
x 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 Exp
x Exp
y 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' }

cvt_tup :: [Maybe Exp] -> Boxity -> CvtM (HsExpr GhcPs)
cvt_tup :: [Maybe Exp] -> Boxity -> CvtM (HsExpr GhcPs)
cvt_tup [Maybe Exp]
es Boxity
boxity = do { let cvtl_maybe :: Maybe Exp -> CvtM (HsTupArg GhcPs)
cvtl_maybe Maybe Exp
Nothing  = HsTupArg GhcPs -> CvtM (HsTupArg GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return HsTupArg GhcPs
missingTupArg
                             cvtl_maybe (Just Exp
e) = (LHsExpr GhcPs -> HsTupArg GhcPs)
-> CvtM (LHsExpr GhcPs) -> CvtM (HsTupArg GhcPs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (XPresent GhcPs -> LHsExpr GhcPs -> HsTupArg GhcPs
forall id. XPresent id -> LHsExpr id -> HsTupArg id
Present NoExtField
XPresent GhcPs
noExtField) (Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
e)
                       ; [HsTupArg GhcPs]
es' <- (Maybe Exp -> CvtM (HsTupArg GhcPs))
-> [Maybe Exp] -> CvtM [HsTupArg GhcPs]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Maybe Exp -> CvtM (HsTupArg GhcPs)
cvtl_maybe [Maybe Exp]
es
                       ; 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
                                    NoExtField
XExplicitTuple GhcPs
noExtField
                                    ((HsTupArg GhcPs -> LHsTupArg GhcPs)
-> [HsTupArg GhcPs] -> [LHsTupArg GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map HsTupArg GhcPs -> LHsTupArg GhcPs
forall e. e -> Located e
noLoc [HsTupArg GhcPs]
es')
                                    Boxity
boxity }

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


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

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

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

Sample input:

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

Sample output:

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

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

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

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

When we call @cvtOpApp@ from @cvtl@, the first argument will always be left-biased
since we have already run @cvtl@ on it.
-}
cvtOpApp :: LHsExpr GhcPs -> TH.Exp -> TH.Exp -> CvtM (HsExpr GhcPs)
cvtOpApp :: LHsExpr GhcPs -> Exp -> Exp -> CvtM (HsExpr GhcPs)
cvtOpApp LHsExpr GhcPs
x Exp
op1 (UInfixE Exp
y Exp
op2 Exp
z)
  = do { LHsExpr GhcPs
l <- CvtM (HsExpr GhcPs) -> CvtM (LHsExpr GhcPs)
forall a. CvtM a -> CvtM (Located a)
wrapL (CvtM (HsExpr GhcPs) -> CvtM (LHsExpr GhcPs))
-> CvtM (HsExpr 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 LHsExpr GhcPs
x Exp
op 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 NoExtField
XOpApp GhcPs
noExtField LHsExpr GhcPs
x LHsExpr GhcPs
op' LHsExpr GhcPs
y') }

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

cvtHsDo :: HsStmtContext GhcRn -> [TH.Stmt] -> CvtM (HsExpr GhcPs)
cvtHsDo :: HsStmtContext GhcRn -> [Stmt] -> CvtM (HsExpr GhcPs)
cvtHsDo HsStmtContext GhcRn
do_or_lc [Stmt]
stmts
  | [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 String
"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 ([LStmt GhcPs (LHsExpr GhcPs)]
stmts'', 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
                    (L SrcSpan
loc (BodyStmt XBodyStmt GhcPs GhcPs (LHsExpr GhcPs)
_ LHsExpr GhcPs
body SyntaxExpr GhcPs
_ SyntaxExpr GhcPs
_))
                      -> LStmt GhcPs (LHsExpr GhcPs) -> CvtM (LStmt GhcPs (LHsExpr GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan
-> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
-> LStmt GhcPs (LHsExpr GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
forall (idR :: Pass) (bodyR :: * -> *) (idL :: Pass).
IsPass idR =>
Located (bodyR (GhcPass idR))
-> StmtLR
     (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR)))
mkLastStmt LHsExpr GhcPs
body))
                    LStmt GhcPs (LHsExpr GhcPs)
_ -> 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 GhcRn
-> Located [LStmt GhcPs (LHsExpr GhcPs)]
-> HsExpr GhcPs
forall p.
XDo p -> HsStmtContext GhcRn -> Located [ExprLStmt p] -> HsExpr p
HsDo NoExtField
XDo GhcPs
noExtField HsStmtContext GhcRn
do_or_lc ([LStmt GhcPs (LHsExpr GhcPs)]
-> Located [LStmt GhcPs (LHsExpr GhcPs)]
forall e. e -> Located e
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 LStmt GhcPs (LHsExpr GhcPs)
stmt = [MsgDoc] -> MsgDoc
vcat [ String -> MsgDoc
text String
"Illegal last statement of" MsgDoc -> MsgDoc -> MsgDoc
<+> HsStmtContext GhcRn -> MsgDoc
forall id. Outputable (IdP id) => HsStmtContext id -> MsgDoc
pprAStmtContext HsStmtContext GhcRn
do_or_lc MsgDoc -> MsgDoc -> MsgDoc
<> MsgDoc
colon
                         , Int -> MsgDoc -> MsgDoc
nest Int
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 String
"(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 Exp
e)    = do { LHsExpr GhcPs
e' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
e; StmtLR GhcPs GhcPs (LHsExpr GhcPs)
-> CvtM (LStmt GhcPs (LHsExpr GhcPs))
forall a. a -> CvtM (Located a)
returnL (StmtLR GhcPs GhcPs (LHsExpr GhcPs)
 -> CvtM (LStmt GhcPs (LHsExpr GhcPs)))
-> StmtLR GhcPs 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 Pat
p Exp
e) = do { Located (Pat GhcPs)
p' <- Pat -> CvtM (LPat GhcPs)
cvtPat Pat
p; LHsExpr GhcPs
e' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
e; StmtLR GhcPs GhcPs (LHsExpr GhcPs)
-> CvtM (LStmt GhcPs (LHsExpr GhcPs))
forall a. a -> CvtM (Located a)
returnL (StmtLR GhcPs GhcPs (LHsExpr GhcPs)
 -> CvtM (LStmt GhcPs (LHsExpr GhcPs)))
-> StmtLR GhcPs 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 (bodyR :: * -> *).
LPat GhcPs
-> Located (bodyR GhcPs)
-> StmtLR GhcPs GhcPs (Located (bodyR GhcPs))
mkPsBindStmt Located (Pat GhcPs)
LPat GhcPs
p' LHsExpr GhcPs
e' }
cvtStmt (TH.LetS [Dec]
ds)   = do { HsLocalBinds GhcPs
ds' <- MsgDoc -> [Dec] -> CvtM (HsLocalBinds GhcPs)
cvtLocalDecs (String -> MsgDoc
text String
"a let binding") [Dec]
ds
                            ; StmtLR GhcPs GhcPs (LHsExpr GhcPs)
-> CvtM (LStmt GhcPs (LHsExpr GhcPs))
forall a. a -> CvtM (Located a)
returnL (StmtLR GhcPs GhcPs (LHsExpr GhcPs)
 -> CvtM (LStmt GhcPs (LHsExpr GhcPs)))
-> StmtLR GhcPs 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 NoExtField
XLetStmt GhcPs GhcPs (LHsExpr GhcPs)
noExtField (HsLocalBinds GhcPs -> LHsLocalBinds GhcPs
forall e. e -> Located e
noLoc HsLocalBinds GhcPs
ds') }
cvtStmt (TH.ParS [[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} {idR}.
(IsPass p, XParStmtBlock GhcPs idR ~ NoExtField,
 SyntaxExprGhc p ~ SyntaxExpr idR) =>
[Stmt] -> CvtM (ParStmtBlock GhcPs idR)
cvt_one [[Stmt]]
dss
                            ; StmtLR GhcPs GhcPs (LHsExpr GhcPs)
-> CvtM (LStmt GhcPs (LHsExpr GhcPs))
forall a. a -> CvtM (Located a)
returnL (StmtLR GhcPs GhcPs (LHsExpr GhcPs)
 -> CvtM (LStmt GhcPs (LHsExpr GhcPs)))
-> StmtLR GhcPs 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 NoExtField
XParStmt GhcPs GhcPs (LHsExpr GhcPs)
noExtField [ParStmtBlock GhcPs GhcPs]
dss' HsExpr GhcPs
forall (p :: Pass). HsExpr (GhcPass p)
noExpr SyntaxExpr GhcPs
forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
noSyntaxExpr }
  where
    cvt_one :: [Stmt] -> CvtM (ParStmtBlock GhcPs idR)
cvt_one [Stmt]
ds = do { [LStmt GhcPs (LHsExpr GhcPs)]
ds' <- [Stmt] -> CvtM [LStmt GhcPs (LHsExpr GhcPs)]
cvtStmts [Stmt]
ds
                    ; ParStmtBlock GhcPs idR -> CvtM (ParStmtBlock GhcPs idR)
forall (m :: * -> *) a. Monad m => a -> m a
return (XParStmtBlock GhcPs idR
-> [LStmt GhcPs (LHsExpr GhcPs)]
-> [IdP idR]
-> SyntaxExpr idR
-> ParStmtBlock GhcPs idR
forall idL idR.
XParStmtBlock idL idR
-> [ExprLStmt idL]
-> [IdP idR]
-> SyntaxExpr idR
-> ParStmtBlock idL idR
ParStmtBlock NoExtField
XParStmtBlock GhcPs idR
noExtField [LStmt GhcPs (LHsExpr GhcPs)]
ds' [IdP idR]
forall a. HasCallStack => a
undefined SyntaxExpr idR
forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
noSyntaxExpr) }
cvtStmt (TH.RecS [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; StmtLR GhcPs GhcPs (LHsExpr GhcPs)
-> CvtM (LStmt GhcPs (LHsExpr GhcPs))
forall a. a -> CvtM (Located 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 GhcPs
         -> TH.Match -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))
cvtMatch :: HsMatchContext GhcPs
-> Match -> CvtM (LMatch GhcPs (LHsExpr GhcPs))
cvtMatch HsMatchContext GhcPs
ctxt (TH.Match Pat
p Body
body [Dec]
decs)
  = do  { Located (Pat GhcPs)
p' <- Pat -> CvtM (LPat GhcPs)
cvtPat Pat
p
        ; let lp :: Located (Pat GhcPs)
lp = case Located (Pat GhcPs)
p' of
                     (L SrcSpan
loc SigPat{}) -> SrcSpan -> Pat GhcPs -> Located (Pat GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XParPat GhcPs -> LPat GhcPs -> Pat GhcPs
forall p. XParPat p -> LPat p -> Pat p
ParPat NoExtField
XParPat GhcPs
noExtField Located (Pat GhcPs)
LPat GhcPs
p') -- #14875
                     Located (Pat GhcPs)
_                -> Located (Pat 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 String
"a where clause") [Dec]
decs
        ; Match GhcPs (LHsExpr GhcPs) -> CvtM (LMatch GhcPs (LHsExpr GhcPs))
forall a. a -> CvtM (Located a)
returnL (Match GhcPs (LHsExpr GhcPs)
 -> CvtM (LMatch GhcPs (LHsExpr GhcPs)))
-> Match GhcPs (LHsExpr GhcPs)
-> CvtM (LMatch GhcPs (LHsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ XCMatch GhcPs (LHsExpr GhcPs)
-> HsMatchContext (NoGhcTc GhcPs)
-> [LPat GhcPs]
-> GRHSs GhcPs (LHsExpr GhcPs)
-> Match GhcPs (LHsExpr GhcPs)
forall p body.
XCMatch p body
-> HsMatchContext (NoGhcTc p)
-> [LPat p]
-> GRHSs p body
-> Match p body
Hs.Match NoExtField
XCMatch GhcPs (LHsExpr GhcPs)
noExtField HsMatchContext GhcPs
HsMatchContext (NoGhcTc GhcPs)
ctxt [Located (Pat GhcPs)
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 NoExtField
XCGRHSs GhcPs (LHsExpr GhcPs)
noExtField [LGRHS GhcPs (LHsExpr GhcPs)]
g' (HsLocalBinds GhcPs -> LHsLocalBinds GhcPs
forall e. e -> Located e
noLoc HsLocalBinds GhcPs
decs')) }

cvtGuard :: TH.Body -> CvtM [LGRHS GhcPs (LHsExpr GhcPs)]
cvtGuard :: Body -> CvtM [LGRHS GhcPs (LHsExpr GhcPs)]
cvtGuard (GuardedB [(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 Exp
e)      = do { LHsExpr GhcPs
e' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
e
                               ; LGRHS GhcPs (LHsExpr GhcPs)
g' <- GRHS GhcPs (LHsExpr GhcPs) -> CvtM (LGRHS GhcPs (LHsExpr GhcPs))
forall a. a -> CvtM (Located a)
returnL (GRHS GhcPs (LHsExpr GhcPs) -> CvtM (LGRHS GhcPs (LHsExpr GhcPs)))
-> GRHS 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 NoExtField
XCGRHS GhcPs (LHsExpr GhcPs)
noExtField [] 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 Exp
ge,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' <- StmtLR GhcPs GhcPs (LHsExpr GhcPs)
-> CvtM (LStmt GhcPs (LHsExpr GhcPs))
forall a. a -> CvtM (Located a)
returnL (StmtLR GhcPs GhcPs (LHsExpr GhcPs)
 -> CvtM (LStmt GhcPs (LHsExpr GhcPs)))
-> StmtLR GhcPs 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'
                              ; GRHS GhcPs (LHsExpr GhcPs) -> CvtM (LGRHS GhcPs (LHsExpr GhcPs))
forall a. a -> CvtM (Located a)
returnL (GRHS GhcPs (LHsExpr GhcPs) -> CvtM (LGRHS GhcPs (LHsExpr GhcPs)))
-> GRHS 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 NoExtField
XCGRHS GhcPs (LHsExpr GhcPs)
noExtField [LStmt GhcPs (LHsExpr GhcPs)
g'] LHsExpr GhcPs
rhs' }
cvtpair (PatG [Stmt]
gs,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
                              ; GRHS GhcPs (LHsExpr GhcPs) -> CvtM (LGRHS GhcPs (LHsExpr GhcPs))
forall a. a -> CvtM (Located a)
returnL (GRHS GhcPs (LHsExpr GhcPs) -> CvtM (LGRHS GhcPs (LHsExpr GhcPs)))
-> GRHS 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 NoExtField
XCGRHS GhcPs (LHsExpr GhcPs)
noExtField [LStmt GhcPs (LHsExpr GhcPs)]
gs' LHsExpr GhcPs
rhs' }

cvtOverLit :: Lit -> CvtM (HsOverLit GhcPs)
cvtOverLit :: Lit -> CvtM (HsOverLit GhcPs)
cvtOverLit (IntegerL 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 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 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 Lit
_ = String -> CvtM (HsOverLit GhcPs)
forall a. String -> a
panic String
"Convert.cvtOverLit: Unexpected overloaded literal"
-- An Integer is like an (overloaded) '3' in a Haskell source program
-- Similarly 3.5 for fractionals

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

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

cvtLit :: Lit -> CvtM (HsLit GhcPs)
cvtLit :: Lit -> CvtM (HsLit GhcPs)
cvtLit (IntPrimL 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 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 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 NoExtField
XHsFloatPrim GhcPs
noExtField (Rational -> FractionalLit
forall a. Real a => a -> FractionalLit
mkFractionalLit Rational
f) }
cvtLit (DoublePrimL 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 NoExtField
XHsDoublePrim GhcPs
noExtField (Rational -> FractionalLit
forall a. Real a => a -> FractionalLit
mkFractionalLit Rational
f) }
cvtLit (CharL 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 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 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 [Word8]
s) = do { let { !s' :: ByteString
s' = [Word8] -> ByteString
BS.pack [Word8]
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 (BytesPrimL (Bytes ForeignPtr Word8
fptr Word
off Word
sz)) = do
  let bs :: ByteString
bs = IO ByteString -> ByteString
forall a. IO a -> a
unsafePerformIO (IO ByteString -> ByteString) -> IO ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ForeignPtr Word8 -> (Ptr Word8 -> IO ByteString) -> IO ByteString
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fptr ((Ptr Word8 -> IO ByteString) -> IO ByteString)
-> (Ptr Word8 -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
ptr ->
             CStringLen -> IO ByteString
BS.packCStringLen (Ptr Word8
ptr Ptr Word8 -> Int -> Ptr CChar
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
off, Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
sz)
  ByteString -> CvtM ()
forall a. a -> CvtM ()
force ByteString
bs
  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
bs
cvtLit Lit
_ = String -> CvtM (HsLit GhcPs)
forall a. String -> a
panic String
"Convert.cvtLit: Unexpected literal"
        -- cvtLit should not be called on IntegerL, RationalL
        -- That precondition is established right here in
        -- "GHC.ThToHs", hence panic

quotedSourceText :: String