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

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

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


This module converts Template Haskell syntax into Hs syntax
-}

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

import GHC.Prelude

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

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

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

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

convertToHsDecls :: Origin -> SrcSpan -> [TH.Dec] -> Either SDoc [LHsDecl GhcPs]
convertToHsDecls :: Origin -> SrcSpan -> [Dec] -> Either SDoc [LHsDecl GhcPs]
convertToHsDecls Origin
origin SrcSpan
loc [Dec]
ds = Origin
-> SrcSpan
-> CvtM [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> Either SDoc [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a. Origin -> SrcSpan -> CvtM a -> Either SDoc a
initCvt Origin
origin SrcSpan
loc (([Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs))]
 -> [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
-> CvtM [Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs))]
-> CvtM [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs))]
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a. [Maybe a] -> [a]
catMaybes ((Dec -> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs))))
-> [Dec] -> CvtM [Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Dec -> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
cvt_dec [Dec]
ds))
  where
    cvt_dec :: Dec -> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
cvt_dec Dec
d = String
-> Dec
-> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
-> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl 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 SDoc (LHsExpr GhcPs)
convertToHsExpr :: Origin -> SrcSpan -> Exp -> Either SDoc (LHsExpr GhcPs)
convertToHsExpr Origin
origin SrcSpan
loc Exp
e
  = Origin
-> SrcSpan -> CvtM (LHsExpr GhcPs) -> Either SDoc (LHsExpr GhcPs)
forall a. Origin -> SrcSpan -> CvtM a -> Either SDoc a
initCvt Origin
origin SrcSpan
loc (CvtM (LHsExpr GhcPs) -> Either SDoc (LHsExpr GhcPs))
-> CvtM (LHsExpr GhcPs) -> Either SDoc (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 SDoc (LPat GhcPs)
convertToPat :: Origin -> SrcSpan -> Pat -> Either SDoc (LPat GhcPs)
convertToPat Origin
origin SrcSpan
loc Pat
p
  = Origin -> SrcSpan -> CvtM (LPat GhcPs) -> Either SDoc (LPat GhcPs)
forall a. Origin -> SrcSpan -> CvtM a -> Either SDoc a
initCvt Origin
origin SrcSpan
loc (CvtM (LPat GhcPs) -> Either SDoc (LPat GhcPs))
-> CvtM (LPat GhcPs) -> Either SDoc (LPat GhcPs)
forall a b. (a -> b) -> a -> b
$ String -> Pat -> CvtM (LPat GhcPs) -> CvtM (LPat GhcPs)
forall a b. (Show a, Ppr a) => String -> a -> CvtM b -> CvtM b
wrapMsg String
"pattern" Pat
p (CvtM (LPat GhcPs) -> CvtM (LPat GhcPs))
-> CvtM (LPat GhcPs) -> CvtM (LPat GhcPs)
forall a b. (a -> b) -> a -> b
$ Pat -> CvtM (LPat GhcPs)
cvtPat Pat
p

convertToHsType :: Origin -> SrcSpan -> TH.Type -> Either SDoc (LHsType GhcPs)
convertToHsType :: Origin -> SrcSpan -> Type -> Either SDoc (LHsType GhcPs)
convertToHsType Origin
origin SrcSpan
loc Type
t
  = Origin
-> SrcSpan -> CvtM (LHsType GhcPs) -> Either SDoc (LHsType GhcPs)
forall a. Origin -> SrcSpan -> CvtM a -> Either SDoc a
initCvt Origin
origin SrcSpan
loc (CvtM (LHsType GhcPs) -> Either SDoc (LHsType GhcPs))
-> CvtM (LHsType GhcPs) -> Either SDoc (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 SDoc (SrcSpan, a)
unCvtM :: Origin -> SrcSpan -> Either SDoc (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 SDoc (SrcSpan, a)) -> CvtM a
forall a. (Origin -> SrcSpan -> Either SDoc (SrcSpan, a)) -> CvtM a
CvtM ((Origin -> SrcSpan -> Either SDoc (SrcSpan, a)) -> CvtM a)
-> (Origin -> SrcSpan -> Either SDoc (SrcSpan, a)) -> CvtM a
forall a b. (a -> b) -> a -> b
$ \Origin
_ SrcSpan
loc -> (SrcSpan, a) -> Either SDoc (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 SDoc (SrcSpan, a)
m) >>= :: forall a b. CvtM a -> (a -> CvtM b) -> CvtM b
>>= a -> CvtM b
k = (Origin -> SrcSpan -> Either SDoc (SrcSpan, b)) -> CvtM b
forall a. (Origin -> SrcSpan -> Either SDoc (SrcSpan, a)) -> CvtM a
CvtM ((Origin -> SrcSpan -> Either SDoc (SrcSpan, b)) -> CvtM b)
-> (Origin -> SrcSpan -> Either SDoc (SrcSpan, b)) -> CvtM b
forall a b. (a -> b) -> a -> b
$ \Origin
origin SrcSpan
loc -> case Origin -> SrcSpan -> Either SDoc (SrcSpan, a)
m Origin
origin SrcSpan
loc of
    Left SDoc
err -> SDoc -> Either SDoc (SrcSpan, b)
forall a b. a -> Either a b
Left SDoc
err
    Right (SrcSpan
loc',a
v) -> CvtM b -> Origin -> SrcSpan -> Either SDoc (SrcSpan, b)
forall a. CvtM a -> Origin -> SrcSpan -> Either SDoc (SrcSpan, a)
unCvtM (a -> CvtM b
k a
v) Origin
origin SrcSpan
loc'

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

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

getL :: CvtM SrcSpan
getL :: CvtM SrcSpan
getL = (Origin -> SrcSpan -> Either SDoc (SrcSpan, SrcSpan))
-> CvtM SrcSpan
forall a. (Origin -> SrcSpan -> Either SDoc (SrcSpan, a)) -> CvtM a
CvtM (\Origin
_ SrcSpan
loc -> (SrcSpan, SrcSpan) -> Either SDoc (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 SDoc (SrcSpan, ())) -> CvtM ()
forall a. (Origin -> SrcSpan -> Either SDoc (SrcSpan, a)) -> CvtM a
CvtM (\Origin
_ SrcSpan
_ -> (SrcSpan, ()) -> Either SDoc (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 SDoc (SrcSpan, Located a))
-> CvtM (Located a)
forall a. (Origin -> SrcSpan -> Either SDoc (SrcSpan, a)) -> CvtM a
CvtM (\Origin
_ SrcSpan
loc -> (SrcSpan, Located a) -> Either SDoc (SrcSpan, Located a)
forall a b. b -> Either a b
Right (SrcSpan
loc, SrcSpan -> a -> Located a
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc a
x))

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

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

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

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

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

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

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

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

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

  | Bool
otherwise
  = do  { GenLocated SrcSpanAnnA (Pat GhcPs)
pat' <- Pat -> CvtM (LPat GhcPs)
cvtPat Pat
pat
        ; [GenLocated
   SrcSpan (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
body' <- Body -> CvtM [LGRHS GhcPs (LHsExpr GhcPs)]
cvtGuard Body
body
        ; HsLocalBinds GhcPs
ds' <- SDoc -> [Dec] -> CvtM (HsLocalBinds GhcPs)
cvtLocalDecs (String -> SDoc
text String
"a where clause") [Dec]
ds
        ; HsDecl GhcPs
-> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA (HsDecl GhcPs
 -> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs))))
-> HsDecl GhcPs
-> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl 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 { pat_lhs :: LPat GhcPs
pat_lhs = GenLocated SrcSpanAnnA (Pat GhcPs)
LPat GhcPs
pat'
                  , pat_rhs :: GRHSs GhcPs (LHsExpr GhcPs)
pat_rhs = XCGRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> [LGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
-> HsLocalBinds GhcPs
-> GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall p body.
XCGRHSs p body -> [LGRHS p body] -> HsLocalBinds p -> GRHSs p body
GRHSs EpAnnComments
XCGRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
emptyComments [GenLocated
   SrcSpan (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
[LGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
body' HsLocalBinds GhcPs
ds'
                  , pat_ext :: XPatBind GhcPs GhcPs
pat_ext = XPatBind GhcPs GhcPs
forall a. EpAnn a
noAnn
                  , pat_ticks :: ([CoreTickish], [[CoreTickish]])
pat_ticks = ([],[]) } }

cvtDec (TH.FunD Name
nm [Clause]
cls)
  | [Clause] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Clause]
cls
  = SDoc -> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
forall a. SDoc -> CvtM a
failWith (String -> SDoc
text String
"Function binding for"
                 SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (String -> SDoc
text (Name -> String
forall a. Ppr a => a -> String
TH.pprint Name
nm))
                 SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"has no equations")
  | Bool
otherwise
  = do  { LocatedN RdrName
nm' <- Name -> CvtM (LocatedN RdrName)
vNameN Name
nm
        ; [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
cls' <- (Clause
 -> CvtM
      (GenLocated
         SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))))
-> [Clause]
-> CvtM
     [GenLocated
        SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr 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 (XRec GhcPs (IdP GhcPs) -> HsMatchContext GhcPs
forall p. LIdP p -> HsMatchContext p
mkPrefixFunRhs LocatedN RdrName
XRec GhcPs (IdP GhcPs)
nm')) [Clause]
cls
        ; Origin
th_origin <- CvtM Origin
getOrigin
        ; HsDecl GhcPs
-> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA (HsDecl GhcPs
 -> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs))))
-> HsDecl GhcPs
-> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl 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
-> LocatedN RdrName
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> HsBind GhcPs
mkFunBind Origin
th_origin LocatedN RdrName
nm' [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
[LMatch GhcPs (LHsExpr GhcPs)]
cls' }

cvtDec (TH.SigD Name
nm Type
typ)
  = do  { LocatedN RdrName
nm' <- Name -> CvtM (LocatedN RdrName)
vNameN Name
nm
        ; GenLocated SrcSpanAnnA (HsSigType GhcPs)
ty' <- Type -> CvtM (LHsSigType GhcPs)
cvtSigType Type
typ
        ; HsDecl GhcPs
-> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA (HsDecl GhcPs
 -> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs))))
-> HsDecl GhcPs
-> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl 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
-> [XRec GhcPs (IdP GhcPs)] -> LHsSigWcType GhcPs -> Sig GhcPs
forall pass.
XTypeSig pass -> [LIdP pass] -> LHsSigWcType pass -> Sig pass
TypeSig XTypeSig GhcPs
forall a. EpAnn a
noAnn [LocatedN RdrName
XRec GhcPs (IdP GhcPs)
nm'] (GenLocated SrcSpanAnnA (HsSigType GhcPs)
-> HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs))
forall thing. thing -> HsWildCardBndrs GhcPs thing
mkHsWildCardBndrs GenLocated SrcSpanAnnA (HsSigType GhcPs)
ty')) }

cvtDec (TH.KiSigD Name
nm Type
ki)
  = do  { LocatedN RdrName
nm' <- Name -> CvtM (LocatedN RdrName)
tconNameN Name
nm
        ; GenLocated SrcSpanAnnA (HsSigType GhcPs)
ki' <- Type -> CvtM (LHsSigType GhcPs)
cvtSigKind Type
ki
        ; let sig' :: StandaloneKindSig GhcPs
sig' = XStandaloneKindSig GhcPs
-> XRec GhcPs (IdP GhcPs)
-> LHsSigType GhcPs
-> StandaloneKindSig GhcPs
forall pass.
XStandaloneKindSig pass
-> LIdP pass -> LHsSigType pass -> StandaloneKindSig pass
StandaloneKindSig XStandaloneKindSig GhcPs
forall a. EpAnn a
noAnn LocatedN RdrName
XRec GhcPs (IdP GhcPs)
nm' GenLocated SrcSpanAnnA (HsSigType GhcPs)
LHsSigType GhcPs
ki'
        ; HsDecl GhcPs
-> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA (HsDecl GhcPs
 -> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs))))
-> HsDecl GhcPs
-> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl 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 { LocatedN RdrName
nm' <- Name -> CvtM (LocatedN RdrName)
vcNameN Name
nm
       ; HsDecl GhcPs
-> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA (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 XFixSig GhcPs
forall a. EpAnn a
noAnn
                                      (XFixitySig GhcPs
-> [XRec GhcPs (IdP GhcPs)] -> Fixity -> FixitySig GhcPs
forall pass.
XFixitySig pass -> [LIdP pass] -> Fixity -> FixitySig pass
FixitySig NoExtField
XFixitySig GhcPs
noExtField [LocatedN RdrName
XRec GhcPs (IdP 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  { (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
_, LocatedN RdrName
tc', LHsQTyVars GhcPs
tvs') <- Cxt
-> Name
-> [TyVarBndr ()]
-> CvtM (LHsContext GhcPs, LocatedN RdrName, LHsQTyVars GhcPs)
cvt_tycl_hdr [] Name
tc [TyVarBndr ()]
tvs
        ; GenLocated SrcSpanAnnA (HsType GhcPs)
rhs' <- Type -> CvtM (LHsType GhcPs)
cvtType Type
rhs
        ; HsDecl GhcPs
-> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA (HsDecl GhcPs
 -> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs))))
-> HsDecl GhcPs
-> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl 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 { tcdSExt :: XSynDecl GhcPs
tcdSExt = XSynDecl GhcPs
forall a. EpAnn a
noAnn, tcdLName :: XRec GhcPs (IdP GhcPs)
tcdLName = LocatedN RdrName
XRec GhcPs (IdP GhcPs)
tc', tcdTyVars :: LHsQTyVars GhcPs
tcdTyVars = LHsQTyVars GhcPs
tvs'
                  , tcdFixity :: LexicalFixity
tcdFixity = LexicalFixity
Prefix
                  , tcdRhs :: LHsType GhcPs
tcdRhs = GenLocated SrcSpanAnnA (HsType GhcPs)
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)
                 (SDoc -> CvtM ()
forall a. SDoc -> CvtM a
failWith (String -> SDoc
text String
"Cannot mix GADT constructors with Haskell 98"
                        SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"constructors"))
        ; 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)
                 (SDoc -> CvtM ()
forall a. SDoc -> CvtM a
failWith (String -> SDoc
text String
"Kind signatures are only allowed on GADTs"))
        ; (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
ctxt', LocatedN RdrName
tc', LHsQTyVars GhcPs
tvs') <- Cxt
-> Name
-> [TyVarBndr ()]
-> CvtM (LHsContext GhcPs, LocatedN RdrName, LHsQTyVars GhcPs)
cvt_tycl_hdr Cxt
ctxt Name
tc [TyVarBndr ()]
tvs
        ; Maybe (GenLocated SrcSpanAnnA (HsType GhcPs))
ksig' <- Type -> CvtM (GenLocated SrcSpanAnnA (HsType GhcPs))
Type -> CvtM (LHsType GhcPs)
cvtKind (Type -> CvtM (GenLocated SrcSpanAnnA (HsType GhcPs)))
-> Maybe Type
-> CvtM (Maybe (GenLocated SrcSpanAnnA (HsType GhcPs)))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
`traverse` Maybe Type
ksig
        ; [GenLocated SrcSpanAnnA (ConDecl GhcPs)]
cons' <- (Con -> CvtM (GenLocated SrcSpanAnnA (ConDecl GhcPs)))
-> [Con] -> CvtM [GenLocated SrcSpanAnnA (ConDecl GhcPs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Con -> CvtM (GenLocated SrcSpanAnnA (ConDecl GhcPs))
Con -> CvtM (LConDecl GhcPs)
cvtConstr [Con]
constrs
        ; [GenLocated SrcSpan (HsDerivingClause GhcPs)]
derivs' <- [DerivClause] -> CvtM (HsDeriving GhcPs)
cvtDerivs [DerivClause]
derivs
        ; let defn :: HsDataDefn GhcPs
defn = HsDataDefn { dd_ext :: XCHsDataDefn GhcPs
dd_ext = NoExtField
XCHsDataDefn GhcPs
noExtField
                                , dd_ND :: NewOrData
dd_ND = NewOrData
DataType, dd_cType :: Maybe (XRec GhcPs CType)
dd_cType = Maybe (XRec GhcPs CType)
forall a. Maybe a
Nothing
                                , dd_ctxt :: Maybe (LHsContext GhcPs)
dd_ctxt = GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> Maybe
     (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)])
forall a. a -> Maybe a
Just GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
ctxt'
                                , dd_kindSig :: Maybe (LHsType GhcPs)
dd_kindSig = Maybe (GenLocated SrcSpanAnnA (HsType GhcPs))
Maybe (LHsType GhcPs)
ksig'
                                , dd_cons :: [LConDecl GhcPs]
dd_cons = [GenLocated SrcSpanAnnA (ConDecl GhcPs)]
[LConDecl GhcPs]
cons', dd_derivs :: HsDeriving GhcPs
dd_derivs = [GenLocated SrcSpan (HsDerivingClause GhcPs)]
HsDeriving GhcPs
derivs' }
        ; HsDecl GhcPs
-> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA (HsDecl GhcPs
 -> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs))))
-> HsDecl GhcPs
-> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl 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 { tcdDExt :: XDataDecl GhcPs
tcdDExt = XDataDecl GhcPs
forall a. EpAnn a
noAnn
                   , tcdLName :: XRec GhcPs (IdP GhcPs)
tcdLName = LocatedN RdrName
XRec GhcPs (IdP 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  { (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
ctxt', LocatedN RdrName
tc', LHsQTyVars GhcPs
tvs') <- Cxt
-> Name
-> [TyVarBndr ()]
-> CvtM (LHsContext GhcPs, LocatedN RdrName, LHsQTyVars GhcPs)
cvt_tycl_hdr Cxt
ctxt Name
tc [TyVarBndr ()]
tvs
        ; Maybe (GenLocated SrcSpanAnnA (HsType GhcPs))
ksig' <- Type -> CvtM (GenLocated SrcSpanAnnA (HsType GhcPs))
Type -> CvtM (LHsType GhcPs)
cvtKind (Type -> CvtM (GenLocated SrcSpanAnnA (HsType GhcPs)))
-> Maybe Type
-> CvtM (Maybe (GenLocated SrcSpanAnnA (HsType GhcPs)))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
`traverse` Maybe Type
ksig
        ; GenLocated SrcSpanAnnA (ConDecl GhcPs)
con' <- Con -> CvtM (LConDecl GhcPs)
cvtConstr Con
constr
        ; [GenLocated SrcSpan (HsDerivingClause GhcPs)]
derivs' <- [DerivClause] -> CvtM (HsDeriving GhcPs)
cvtDerivs [DerivClause]
derivs
        ; let defn :: HsDataDefn GhcPs
defn = HsDataDefn { dd_ext :: XCHsDataDefn GhcPs
dd_ext = NoExtField
XCHsDataDefn GhcPs
noExtField
                                , dd_ND :: NewOrData
dd_ND = NewOrData
NewType, dd_cType :: Maybe (XRec GhcPs CType)
dd_cType = Maybe (XRec GhcPs CType)
forall a. Maybe a
Nothing
                                , dd_ctxt :: Maybe (LHsContext GhcPs)
dd_ctxt = GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> Maybe
     (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)])
forall a. a -> Maybe a
Just GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
ctxt'
                                , dd_kindSig :: Maybe (LHsType GhcPs)
dd_kindSig = Maybe (GenLocated SrcSpanAnnA (HsType GhcPs))
Maybe (LHsType GhcPs)
ksig'
                                , dd_cons :: [LConDecl GhcPs]
dd_cons = [GenLocated SrcSpanAnnA (ConDecl GhcPs)
LConDecl GhcPs
con']
                                , dd_derivs :: HsDeriving GhcPs
dd_derivs = [GenLocated SrcSpan (HsDerivingClause GhcPs)]
HsDeriving GhcPs
derivs' }
        ; HsDecl GhcPs
-> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA (HsDecl GhcPs
 -> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs))))
-> HsDecl GhcPs
-> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl 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 { tcdDExt :: XDataDecl GhcPs
tcdDExt = XDataDecl GhcPs
forall a. EpAnn a
noAnn
                   , tcdLName :: XRec GhcPs (IdP GhcPs)
tcdLName = LocatedN RdrName
XRec GhcPs (IdP 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  { (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
cxt', LocatedN RdrName
tc', LHsQTyVars GhcPs
tvs') <- Cxt
-> Name
-> [TyVarBndr ()]
-> CvtM (LHsContext GhcPs, LocatedN RdrName, LHsQTyVars GhcPs)
cvt_tycl_hdr Cxt
ctxt Name
cl [TyVarBndr ()]
tvs
        ; [GenLocated SrcSpanAnnA (FunDep GhcPs)]
fds'  <- (FunDep -> CvtM (GenLocated SrcSpanAnnA (FunDep GhcPs)))
-> [FunDep] -> CvtM [GenLocated SrcSpanAnnA (FunDep GhcPs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FunDep -> CvtM (GenLocated SrcSpanAnnA (FunDep GhcPs))
FunDep -> CvtM (LHsFunDep GhcPs)
cvt_fundep [FunDep]
fds
        ; (Bag (GenLocated SrcSpanAnnA (HsBind GhcPs))
binds', [GenLocated SrcSpanAnnA (Sig GhcPs)]
sigs', [GenLocated SrcSpanAnnA (FamilyDecl GhcPs)]
fams', [GenLocated SrcSpanAnnA (TyFamInstDecl GhcPs)]
at_defs', [GenLocated SrcSpanAnnA (DataFamInstDecl GhcPs)]
adts') <- SDoc
-> [Dec]
-> CvtM
     (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],
      [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs])
cvt_ci_decs (String -> SDoc
text String
"a class declaration") [Dec]
decs
        ; Bool -> CvtM () -> CvtM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([GenLocated SrcSpanAnnA (DataFamInstDecl GhcPs)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated SrcSpanAnnA (DataFamInstDecl GhcPs)]
adts')
            (SDoc -> CvtM ()
forall a. SDoc -> CvtM a
failWith (SDoc -> CvtM ()) -> SDoc -> CvtM ()
forall a b. (a -> b) -> a -> b
$ (String -> SDoc
text String
"Default data instance declarations"
                     SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"are not allowed:")
                   SDoc -> SDoc -> SDoc
$$ ([GenLocated SrcSpanAnnA (DataFamInstDecl GhcPs)] -> SDoc
forall a. Outputable a => a -> SDoc
Outputable.ppr [GenLocated SrcSpanAnnA (DataFamInstDecl GhcPs)]
adts'))
        ; HsDecl GhcPs
-> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA (HsDecl GhcPs
 -> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs))))
-> HsDecl GhcPs
-> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl 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 { tcdCExt :: XClassDecl GhcPs
tcdCExt = (EpAnn [AddEpAnn]
forall a. EpAnn a
noAnn, AnnSortKey
NoAnnSortKey, LayoutInfo
NoLayoutInfo)
                    , tcdCtxt :: Maybe (LHsContext GhcPs)
tcdCtxt = GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> Maybe
     (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)])
forall a. a -> Maybe a
Just GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
cxt', tcdLName :: XRec GhcPs (IdP GhcPs)
tcdLName = LocatedN RdrName
XRec GhcPs (IdP GhcPs)
tc', tcdTyVars :: LHsQTyVars GhcPs
tcdTyVars = LHsQTyVars GhcPs
tvs'
                    , tcdFixity :: LexicalFixity
tcdFixity = LexicalFixity
Prefix
                    , tcdFDs :: [LHsFunDep GhcPs]
tcdFDs = [GenLocated SrcSpanAnnA (FunDep GhcPs)]
[LHsFunDep GhcPs]
fds', tcdSigs :: [LSig GhcPs]
tcdSigs = [LSig GhcPs] -> [LSig GhcPs]
Hs.mkClassOpSigs [GenLocated SrcSpanAnnA (Sig GhcPs)]
[LSig GhcPs]
sigs'
                    , tcdMeths :: LHsBinds GhcPs
tcdMeths = Bag (GenLocated SrcSpanAnnA (HsBind GhcPs))
LHsBinds GhcPs
binds'
                    , tcdATs :: [LFamilyDecl GhcPs]
tcdATs = [GenLocated SrcSpanAnnA (FamilyDecl GhcPs)]
[LFamilyDecl GhcPs]
fams', tcdATDefs :: [LTyFamInstDecl GhcPs]
tcdATDefs = [GenLocated SrcSpanAnnA (TyFamInstDecl GhcPs)]
[LTyFamInstDecl GhcPs]
at_defs', tcdDocs :: [LDocDecl GhcPs]
tcdDocs = [] }
                              -- no docs in TH ^^
        }

cvtDec (InstanceD Maybe Overlap
o Cxt
ctxt Type
ty [Dec]
decs)
  = do  { let doc :: SDoc
doc = String -> SDoc
text String
"an instance declaration"
        ; (Bag (GenLocated SrcSpanAnnA (HsBind GhcPs))
binds', [GenLocated SrcSpanAnnA (Sig GhcPs)]
sigs', [GenLocated SrcSpanAnnA (FamilyDecl GhcPs)]
fams', [GenLocated SrcSpanAnnA (TyFamInstDecl GhcPs)]
ats', [GenLocated SrcSpanAnnA (DataFamInstDecl GhcPs)]
adts') <- SDoc
-> [Dec]
-> CvtM
     (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],
      [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs])
cvt_ci_decs SDoc
doc [Dec]
decs
        ; Bool -> CvtM () -> CvtM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([GenLocated SrcSpanAnnA (FamilyDecl GhcPs)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated SrcSpanAnnA (FamilyDecl GhcPs)]
fams') (SDoc -> CvtM ()
forall a. SDoc -> CvtM a
failWith (SDoc -> [GenLocated SrcSpanAnnA (FamilyDecl GhcPs)] -> SDoc
forall a. Outputable a => SDoc -> [a] -> SDoc
mkBadDecMsg SDoc
doc [GenLocated SrcSpanAnnA (FamilyDecl GhcPs)]
fams'))
        ; GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
ctxt' <- PprPrec -> Cxt -> CvtM (LHsContext GhcPs)
cvtContext PprPrec
funPrec Cxt
ctxt
        ; (L SrcSpanAnnA
loc HsType GhcPs
ty') <- Type -> CvtM (LHsType GhcPs)
cvtType Type
ty
        ; let inst_ty' :: GenLocated SrcSpanAnnA (HsSigType GhcPs)
inst_ty' = SrcSpanAnnA
-> HsSigType GhcPs -> GenLocated SrcSpanAnnA (HsSigType GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (HsSigType GhcPs -> GenLocated SrcSpanAnnA (HsSigType GhcPs))
-> HsSigType GhcPs -> GenLocated SrcSpanAnnA (HsSigType GhcPs)
forall a b. (a -> b) -> a -> b
$ LHsType GhcPs -> HsSigType GhcPs
mkHsImplicitSigType (LHsType GhcPs -> HsSigType GhcPs)
-> LHsType GhcPs -> HsSigType GhcPs
forall a b. (a -> b) -> a -> b
$
                         Cxt
-> SrcSpanAnnA
-> LHsContext GhcPs
-> LHsType GhcPs
-> LHsType GhcPs
mkHsQualTy Cxt
ctxt SrcSpanAnnA
loc GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
LHsContext GhcPs
ctxt' (LHsType GhcPs -> LHsType GhcPs) -> LHsType GhcPs -> LHsType GhcPs
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA
-> HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc HsType GhcPs
ty'
        ; HsDecl GhcPs
-> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA (HsDecl GhcPs
 -> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs))))
-> HsDecl GhcPs
-> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl 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 { cid_ext :: XCClsInstDecl GhcPs
cid_ext = (EpAnn [AddEpAnn]
forall a. EpAnn a
noAnn, AnnSortKey
NoAnnSortKey), cid_poly_ty :: LHsSigType GhcPs
cid_poly_ty = GenLocated SrcSpanAnnA (HsSigType GhcPs)
LHsSigType GhcPs
inst_ty'
                      , cid_binds :: LHsBinds GhcPs
cid_binds = Bag (GenLocated SrcSpanAnnA (HsBind GhcPs))
LHsBinds GhcPs
binds'
                      , cid_sigs :: [LSig GhcPs]
cid_sigs = [LSig GhcPs] -> [LSig GhcPs]
Hs.mkClassOpSigs [GenLocated SrcSpanAnnA (Sig GhcPs)]
[LSig GhcPs]
sigs'
                      , cid_tyfam_insts :: [LTyFamInstDecl GhcPs]
cid_tyfam_insts = [GenLocated SrcSpanAnnA (TyFamInstDecl GhcPs)]
[LTyFamInstDecl GhcPs]
ats', cid_datafam_insts :: [LDataFamInstDecl GhcPs]
cid_datafam_insts = [GenLocated SrcSpanAnnA (DataFamInstDecl GhcPs)]
[LDataFamInstDecl GhcPs]
adts'
                      , cid_overlap_mode :: Maybe (XRec GhcPs OverlapMode)
cid_overlap_mode
                                   = (Overlap -> GenLocated (SrcAnn AnnPragma) OverlapMode)
-> Maybe Overlap
-> Maybe (GenLocated (SrcAnn AnnPragma) OverlapMode)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SrcAnn AnnPragma
-> OverlapMode -> GenLocated (SrcAnn AnnPragma) OverlapMode
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnA -> SrcAnn AnnPragma
forall a ann. SrcSpanAnn' a -> SrcAnn ann
l2l SrcSpanAnnA
loc) (OverlapMode -> GenLocated (SrcAnn AnnPragma) OverlapMode)
-> (Overlap -> OverlapMode)
-> Overlap
-> GenLocated (SrcAnn AnnPragma) 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 (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA (HsDecl GhcPs
 -> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs))))
-> HsDecl GhcPs
-> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl 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 { (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
_, LocatedN RdrName
tc', LHsQTyVars GhcPs
tvs') <- Cxt
-> Name
-> [TyVarBndr ()]
-> CvtM (LHsContext GhcPs, LocatedN RdrName, LHsQTyVars GhcPs)
cvt_tycl_hdr [] Name
tc [TyVarBndr ()]
tvs
       ; GenLocated SrcSpan (FamilyResultSig GhcPs)
result <- Maybe Type -> CvtM (LFamilyResultSig GhcPs)
cvtMaybeKindToFamilyResultSig Maybe Type
kind
       ; HsDecl GhcPs
-> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA (HsDecl GhcPs
 -> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs))))
-> HsDecl GhcPs
-> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl 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
-> TopLevelFlag
-> XRec GhcPs (IdP GhcPs)
-> LHsQTyVars GhcPs
-> LexicalFixity
-> LFamilyResultSig GhcPs
-> Maybe (LInjectivityAnn GhcPs)
-> FamilyDecl GhcPs
forall pass.
XCFamilyDecl pass
-> FamilyInfo pass
-> TopLevelFlag
-> LIdP pass
-> LHsQTyVars pass
-> LexicalFixity
-> LFamilyResultSig pass
-> Maybe (LInjectivityAnn pass)
-> FamilyDecl pass
FamilyDecl XCFamilyDecl GhcPs
forall a. EpAnn a
noAnn FamilyInfo GhcPs
forall pass. FamilyInfo pass
DataFamily TopLevelFlag
TopLevel LocatedN RdrName
XRec GhcPs (IdP GhcPs)
tc' LHsQTyVars GhcPs
tvs' LexicalFixity
Prefix GenLocated SrcSpan (FamilyResultSig GhcPs)
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 { (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
ctxt', LocatedN RdrName
tc', HsOuterFamEqnTyVarBndrs GhcPs
bndrs', [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
typats') <- Cxt
-> Maybe [TyVarBndr ()]
-> Type
-> CvtM
     (LHsContext GhcPs, LocatedN RdrName, HsOuterFamEqnTyVarBndrs GhcPs,
      HsTyPats GhcPs)
cvt_datainst_hdr Cxt
ctxt Maybe [TyVarBndr ()]
bndrs Type
tys
       ; Maybe (GenLocated SrcSpanAnnA (HsType GhcPs))
ksig' <- Type -> CvtM (GenLocated SrcSpanAnnA (HsType GhcPs))
Type -> CvtM (LHsType GhcPs)
cvtKind (Type -> CvtM (GenLocated SrcSpanAnnA (HsType GhcPs)))
-> Maybe Type
-> CvtM (Maybe (GenLocated SrcSpanAnnA (HsType GhcPs)))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
`traverse` Maybe Type
ksig
       ; [GenLocated SrcSpanAnnA (ConDecl GhcPs)]
cons' <- (Con -> CvtM (GenLocated SrcSpanAnnA (ConDecl GhcPs)))
-> [Con] -> CvtM [GenLocated SrcSpanAnnA (ConDecl GhcPs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Con -> CvtM (GenLocated SrcSpanAnnA (ConDecl GhcPs))
Con -> CvtM (LConDecl GhcPs)
cvtConstr [Con]
constrs
       ; [GenLocated SrcSpan (HsDerivingClause GhcPs)]
derivs' <- [DerivClause] -> CvtM (HsDeriving GhcPs)
cvtDerivs [DerivClause]
derivs
       ; let defn :: HsDataDefn GhcPs
defn = HsDataDefn { dd_ext :: XCHsDataDefn GhcPs
dd_ext = NoExtField
XCHsDataDefn GhcPs
noExtField
                               , dd_ND :: NewOrData
dd_ND = NewOrData
DataType, dd_cType :: Maybe (XRec GhcPs CType)
dd_cType = Maybe (XRec GhcPs CType)
forall a. Maybe a
Nothing
                               , dd_ctxt :: Maybe (LHsContext GhcPs)
dd_ctxt = GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> Maybe
     (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)])
forall a. a -> Maybe a
Just GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
ctxt'
                               , dd_kindSig :: Maybe (LHsType GhcPs)
dd_kindSig = Maybe (GenLocated SrcSpanAnnA (HsType GhcPs))
Maybe (LHsType GhcPs)
ksig'
                               , dd_cons :: [LConDecl GhcPs]
dd_cons = [GenLocated SrcSpanAnnA (ConDecl GhcPs)]
[LConDecl GhcPs]
cons', dd_derivs :: HsDeriving GhcPs
dd_derivs = [GenLocated SrcSpan (HsDerivingClause GhcPs)]
HsDeriving GhcPs
derivs' }

       ; HsDecl GhcPs
-> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA (HsDecl GhcPs
 -> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs))))
-> HsDecl GhcPs
-> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl 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
           { dfid_ext :: XDataFamInstD GhcPs
dfid_ext = XDataFamInstD GhcPs
forall a. EpAnn a
noAnn
           , dfid_inst :: DataFamInstDecl GhcPs
dfid_inst = DataFamInstDecl { dfid_eqn :: FamEqn GhcPs (HsDataDefn GhcPs)
dfid_eqn =
                           FamEqn { feqn_ext :: XCFamEqn GhcPs (HsDataDefn GhcPs)
feqn_ext = XCFamEqn GhcPs (HsDataDefn GhcPs)
forall a. EpAnn a
noAnn
                                  , feqn_tycon :: XRec GhcPs (IdP GhcPs)
feqn_tycon = LocatedN RdrName
XRec GhcPs (IdP GhcPs)
tc'
                                  , feqn_bndrs :: HsOuterFamEqnTyVarBndrs GhcPs
feqn_bndrs = HsOuterFamEqnTyVarBndrs GhcPs
bndrs'
                                  , feqn_pats :: HsTyPats GhcPs
feqn_pats = [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
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 { (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
ctxt', LocatedN RdrName
tc', HsOuterFamEqnTyVarBndrs GhcPs
bndrs', [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
typats') <- Cxt
-> Maybe [TyVarBndr ()]
-> Type
-> CvtM
     (LHsContext GhcPs, LocatedN RdrName, HsOuterFamEqnTyVarBndrs GhcPs,
      HsTyPats GhcPs)
cvt_datainst_hdr Cxt
ctxt Maybe [TyVarBndr ()]
bndrs Type
tys
       ; Maybe (GenLocated SrcSpanAnnA (HsType GhcPs))
ksig' <- Type -> CvtM (GenLocated SrcSpanAnnA (HsType GhcPs))
Type -> CvtM (LHsType GhcPs)
cvtKind (Type -> CvtM (GenLocated SrcSpanAnnA (HsType GhcPs)))
-> Maybe Type
-> CvtM (Maybe (GenLocated SrcSpanAnnA (HsType GhcPs)))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
`traverse` Maybe Type
ksig
       ; GenLocated SrcSpanAnnA (ConDecl GhcPs)
con' <- Con -> CvtM (LConDecl GhcPs)
cvtConstr Con
constr
       ; [GenLocated SrcSpan (HsDerivingClause GhcPs)]
derivs' <- [DerivClause] -> CvtM (HsDeriving GhcPs)
cvtDerivs [DerivClause]
derivs
       ; let defn :: HsDataDefn GhcPs
defn = HsDataDefn { dd_ext :: XCHsDataDefn GhcPs
dd_ext = NoExtField
XCHsDataDefn GhcPs
noExtField
                               , dd_ND :: NewOrData
dd_ND = NewOrData
NewType, dd_cType :: Maybe (XRec GhcPs CType)
dd_cType = Maybe (XRec GhcPs CType)
forall a. Maybe a
Nothing
                               , dd_ctxt :: Maybe (LHsContext GhcPs)
dd_ctxt = GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> Maybe
     (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)])
forall a. a -> Maybe a
Just GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
ctxt'
                               , dd_kindSig :: Maybe (LHsType GhcPs)
dd_kindSig = Maybe (GenLocated SrcSpanAnnA (HsType GhcPs))
Maybe (LHsType GhcPs)
ksig'
                               , dd_cons :: [LConDecl GhcPs]
dd_cons = [GenLocated SrcSpanAnnA (ConDecl GhcPs)
LConDecl GhcPs
con'], dd_derivs :: HsDeriving GhcPs
dd_derivs = [GenLocated SrcSpan (HsDerivingClause GhcPs)]
HsDeriving GhcPs
derivs' }
       ; HsDecl GhcPs
-> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA (HsDecl GhcPs
 -> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs))))
-> HsDecl GhcPs
-> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl 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
           { dfid_ext :: XDataFamInstD GhcPs
dfid_ext = XDataFamInstD GhcPs
forall a. EpAnn a
noAnn
           , dfid_inst :: DataFamInstDecl GhcPs
dfid_inst = DataFamInstDecl { dfid_eqn :: FamEqn GhcPs (HsDataDefn GhcPs)
dfid_eqn =
                           FamEqn { feqn_ext :: XCFamEqn GhcPs (HsDataDefn GhcPs)
feqn_ext = XCFamEqn GhcPs (HsDataDefn GhcPs)
forall a. EpAnn a
noAnn
                                  , feqn_tycon :: XRec GhcPs (IdP GhcPs)
feqn_tycon = LocatedN RdrName
XRec GhcPs (IdP GhcPs)
tc'
                                  , feqn_bndrs :: HsOuterFamEqnTyVarBndrs GhcPs
feqn_bndrs = HsOuterFamEqnTyVarBndrs GhcPs
bndrs'
                                  , feqn_pats :: HsTyPats GhcPs
feqn_pats = [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
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 SrcSpanAnnA
_ FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
eqn') <- TySynEqn -> CvtM (LTyFamInstEqn GhcPs)
cvtTySynEqn TySynEqn
eqn
        ; HsDecl GhcPs
-> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA (HsDecl GhcPs
 -> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs))))
-> HsDecl GhcPs
-> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl 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
            { tfid_ext :: XTyFamInstD GhcPs
tfid_ext = NoExtField
XTyFamInstD GhcPs
noExtField
            , tfid_inst :: TyFamInstDecl GhcPs
tfid_inst = TyFamInstDecl { tfid_xtn :: XCTyFamInstDecl GhcPs
tfid_xtn = XCTyFamInstDecl GhcPs
forall a. EpAnn a
noAnn, tfid_eqn :: TyFamInstEqn GhcPs
tfid_eqn = FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
TyFamInstEqn GhcPs
eqn' } }}

cvtDec (OpenTypeFamilyD TypeFamilyHead
head)
  = do { (LocatedN RdrName
tc', LHsQTyVars GhcPs
tyvars', GenLocated SrcSpan (FamilyResultSig GhcPs)
result', Maybe (GenLocated SrcSpan (InjectivityAnn GhcPs))
injectivity') <- TypeFamilyHead
-> CvtM
     (LocatedN RdrName, LHsQTyVars GhcPs, LFamilyResultSig GhcPs,
      Maybe (LInjectivityAnn GhcPs))
cvt_tyfam_head TypeFamilyHead
head
       ; HsDecl GhcPs
-> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA (HsDecl GhcPs
 -> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs))))
-> HsDecl GhcPs
-> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl 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
-> TopLevelFlag
-> XRec GhcPs (IdP GhcPs)
-> LHsQTyVars GhcPs
-> LexicalFixity
-> LFamilyResultSig GhcPs
-> Maybe (LInjectivityAnn GhcPs)
-> FamilyDecl GhcPs
forall pass.
XCFamilyDecl pass
-> FamilyInfo pass
-> TopLevelFlag
-> LIdP pass
-> LHsQTyVars pass
-> LexicalFixity
-> LFamilyResultSig pass
-> Maybe (LInjectivityAnn pass)
-> FamilyDecl pass
FamilyDecl XCFamilyDecl GhcPs
forall a. EpAnn a
noAnn FamilyInfo GhcPs
forall pass. FamilyInfo pass
OpenTypeFamily TopLevelFlag
TopLevel LocatedN RdrName
XRec GhcPs (IdP GhcPs)
tc' LHsQTyVars GhcPs
tyvars' LexicalFixity
Prefix GenLocated SrcSpan (FamilyResultSig GhcPs)
LFamilyResultSig GhcPs
result' Maybe (GenLocated SrcSpan (InjectivityAnn GhcPs))
Maybe (LInjectivityAnn GhcPs)
injectivity'
       }

cvtDec (ClosedTypeFamilyD TypeFamilyHead
head [TySynEqn]
eqns)
  = do { (LocatedN RdrName
tc', LHsQTyVars GhcPs
tyvars', GenLocated SrcSpan (FamilyResultSig GhcPs)
result', Maybe (GenLocated SrcSpan (InjectivityAnn GhcPs))
injectivity') <- TypeFamilyHead
-> CvtM
     (LocatedN RdrName, LHsQTyVars GhcPs, LFamilyResultSig GhcPs,
      Maybe (LInjectivityAnn GhcPs))
cvt_tyfam_head TypeFamilyHead
head
       ; [GenLocated
   SrcSpanAnnA (FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))]
eqns' <- (TySynEqn
 -> CvtM
      (GenLocated
         SrcSpanAnnA
         (FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))))
-> [TySynEqn]
-> CvtM
     [GenLocated
        SrcSpanAnnA (FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TySynEqn
-> CvtM
     (GenLocated
        SrcSpanAnnA (FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))))
TySynEqn -> CvtM (LTyFamInstEqn GhcPs)
cvtTySynEqn [TySynEqn]
eqns
       ; HsDecl GhcPs
-> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA (HsDecl GhcPs
 -> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs))))
-> HsDecl GhcPs
-> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl 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
-> TopLevelFlag
-> XRec GhcPs (IdP GhcPs)
-> LHsQTyVars GhcPs
-> LexicalFixity
-> LFamilyResultSig GhcPs
-> Maybe (LInjectivityAnn GhcPs)
-> FamilyDecl GhcPs
forall pass.
XCFamilyDecl pass
-> FamilyInfo pass
-> TopLevelFlag
-> LIdP pass
-> LHsQTyVars pass
-> LexicalFixity
-> LFamilyResultSig pass
-> Maybe (LInjectivityAnn pass)
-> FamilyDecl pass
FamilyDecl XCFamilyDecl GhcPs
forall a. EpAnn a
noAnn (Maybe [LTyFamInstEqn GhcPs] -> FamilyInfo GhcPs
forall pass. Maybe [LTyFamInstEqn pass] -> FamilyInfo pass
ClosedTypeFamily ([GenLocated
   SrcSpanAnnA (FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))]
-> Maybe
     [GenLocated
        SrcSpanAnnA (FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))]
forall a. a -> Maybe a
Just [GenLocated
   SrcSpanAnnA (FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))]
eqns')) TopLevelFlag
TopLevel LocatedN RdrName
XRec GhcPs (IdP GhcPs)
tc' LHsQTyVars GhcPs
tyvars' LexicalFixity
Prefix
                           GenLocated SrcSpan (FamilyResultSig GhcPs)
LFamilyResultSig GhcPs
result' Maybe (GenLocated SrcSpan (InjectivityAnn GhcPs))
Maybe (LInjectivityAnn GhcPs)
injectivity' }

cvtDec (TH.RoleAnnotD Name
tc [Role]
roles)
  = do { LocatedN RdrName
tc' <- Name -> CvtM (LocatedN RdrName)
tconNameN Name
tc
       ; let roles' :: [Located (Maybe Role)]
roles' = (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 (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA
                   (HsDecl GhcPs
 -> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs))))
-> HsDecl GhcPs
-> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl 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
-> XRec GhcPs (IdP GhcPs)
-> [XRec GhcPs (Maybe Role)]
-> RoleAnnotDecl GhcPs
forall pass.
XCRoleAnnotDecl pass
-> LIdP pass -> [XRec pass (Maybe Role)] -> RoleAnnotDecl pass
RoleAnnotDecl XCRoleAnnotDecl GhcPs
forall a. EpAnn a
noAnn LocatedN RdrName
XRec GhcPs (IdP GhcPs)
tc' [Located (Maybe Role)]
[XRec GhcPs (Maybe Role)]
roles') }

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

cvtDec (TH.DefaultSigD Name
nm Type
typ)
  = do { LocatedN RdrName
nm' <- Name -> CvtM (LocatedN RdrName)
vNameN Name
nm
       ; GenLocated SrcSpanAnnA (HsSigType GhcPs)
ty' <- Type -> CvtM (LHsSigType GhcPs)
cvtSigType Type
typ
       ; HsDecl GhcPs
-> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA (HsDecl GhcPs
 -> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs))))
-> HsDecl GhcPs
-> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl 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
-> [XRec GhcPs (IdP GhcPs)]
-> LHsSigType GhcPs
-> Sig GhcPs
forall pass.
XClassOpSig pass
-> Bool -> [LIdP pass] -> LHsSigType pass -> Sig pass
ClassOpSig XClassOpSig GhcPs
forall a. EpAnn a
noAnn Bool
True [LocatedN RdrName
XRec GhcPs (IdP GhcPs)
nm'] GenLocated SrcSpanAnnA (HsSigType GhcPs)
LHsSigType GhcPs
ty'}

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

    -- cvtDir :: LocatedN RdrName -> (PatSynDir -> CvtM (HsPatSynDir RdrName))
    cvtDir :: LocatedN RdrName -> PatSynDir -> CvtM (HsPatSynDir GhcPs)
cvtDir LocatedN RdrName
_ PatSynDir
Unidir          = HsPatSynDir GhcPs -> CvtM (HsPatSynDir GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return HsPatSynDir GhcPs
forall id. HsPatSynDir id
Unidirectional
    cvtDir LocatedN 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 LocatedN RdrName
n (ExplBidir [Clause]
cls) =
      do { [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
ms <- (Clause
 -> CvtM
      (GenLocated
         SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))))
-> [Clause]
-> CvtM
     [GenLocated
        SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr 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 (XRec GhcPs (IdP GhcPs) -> HsMatchContext GhcPs
forall p. LIdP p -> HsMatchContext p
mkPrefixFunRhs LocatedN RdrName
XRec GhcPs (IdP 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
-> LocatedL
     [GenLocated
        SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
AnnoBody p body =>
Origin
-> LocatedL
     [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]
-> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))
mkMatchGroup Origin
th_origin ([GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> LocatedL
     [GenLocated
        SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall a an. a -> LocatedAn an a
noLocA [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
ms) }

cvtDec (TH.PatSynSigD Name
nm Type
ty)
  = do { LocatedN RdrName
nm' <- Name -> CvtM (LocatedN RdrName)
cNameN Name
nm
       ; GenLocated SrcSpanAnnA (HsSigType GhcPs)
ty' <- Type -> CvtM (LHsSigType GhcPs)
cvtPatSynSigTy Type
ty
       ; HsDecl GhcPs
-> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA (HsDecl GhcPs
 -> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs))))
-> HsDecl GhcPs
-> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl 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
-> [XRec GhcPs (IdP GhcPs)] -> LHsSigType GhcPs -> Sig GhcPs
forall pass.
XPatSynSig pass -> [LIdP pass] -> LHsSigType pass -> Sig pass
PatSynSig XPatSynSig GhcPs
forall a. EpAnn a
noAnn [LocatedN RdrName
XRec GhcPs (IdP GhcPs)
nm'] GenLocated SrcSpanAnnA (HsSigType GhcPs)
LHsSigType 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
_)
  = SDoc -> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
forall a. SDoc -> CvtM a
failWith (String -> SDoc
text String
"Implicit parameter binding only allowed in let or where")

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

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

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

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

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

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

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

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

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

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

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

is_bind :: LHsDecl GhcPs -> Either (LHsBind GhcPs) (LHsDecl GhcPs)
is_bind :: LHsDecl GhcPs -> Either (LHsBind GhcPs) (LHsDecl GhcPs)
is_bind (L SrcSpanAnnA
loc (Hs.ValD XValD GhcPs
_ HsBind GhcPs
bind)) = GenLocated SrcSpanAnnA (HsBind GhcPs)
-> Either
     (GenLocated SrcSpanAnnA (HsBind GhcPs))
     (GenLocated SrcSpanAnnA (HsDecl GhcPs))
forall a b. a -> Either a b
Left (SrcSpanAnnA
-> HsBind GhcPs -> GenLocated SrcSpanAnnA (HsBind GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc HsBind GhcPs
bind)
is_bind LHsDecl GhcPs
decl                     = GenLocated SrcSpanAnnA (HsDecl GhcPs)
-> Either
     (GenLocated SrcSpanAnnA (HsBind GhcPs))
     (GenLocated SrcSpanAnnA (HsDecl GhcPs))
forall a b. b -> Either a b
Right GenLocated SrcSpanAnnA (HsDecl GhcPs)
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 => SDoc -> [a] -> SDoc
mkBadDecMsg :: forall a. Outputable a => SDoc -> [a] -> SDoc
mkBadDecMsg SDoc
doc [a]
bads
  = [SDoc] -> SDoc
sep [ String -> SDoc
text String
"Illegal declaration(s) in" SDoc -> SDoc -> SDoc
<+> SDoc
doc SDoc -> SDoc -> SDoc
<> SDoc
colon
        , Int -> SDoc -> SDoc
nest Int
2 ([SDoc] -> SDoc
vcat ((a -> SDoc) -> [a] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map a -> SDoc
forall a. Outputable a => a -> SDoc
Outputable.ppr [a]
bads)) ]

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

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

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

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

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

cvtConstr (ForallC [TyVarBndr Specificity]
tvs Cxt
ctxt Con
con)
  = do  { [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)]
tvs'      <- [TyVarBndr Specificity] -> CvtM [LHsTyVarBndr Specificity GhcPs]
forall flag flag'.
CvtFlag flag flag' =>
[TyVarBndr flag] -> CvtM [LHsTyVarBndr flag' GhcPs]
cvtTvs [TyVarBndr Specificity]
tvs
        ; GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
ctxt'     <- PprPrec -> Cxt -> CvtM (LHsContext GhcPs)
cvtContext PprPrec
funPrec Cxt
ctxt
        ; L SrcSpanAnnA
_ ConDecl GhcPs
con'  <- Con -> CvtM (LConDecl GhcPs)
cvtConstr Con
con
        ; ConDecl GhcPs -> CvtM (GenLocated SrcSpanAnnA (ConDecl GhcPs))
forall e ann. e -> CvtM (GenLocated (SrcSpanAnn' (EpAnn ann)) e)
returnLA (ConDecl GhcPs -> CvtM (GenLocated SrcSpanAnnA (ConDecl GhcPs)))
-> ConDecl GhcPs -> CvtM (GenLocated SrcSpanAnnA (ConDecl GhcPs))
forall a b. (a -> b) -> a -> b
$ [LHsTyVarBndr Specificity GhcPs]
-> LHsContext GhcPs -> ConDecl GhcPs -> ConDecl GhcPs
add_forall [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)]
[LHsTyVarBndr Specificity GhcPs]
tvs' GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
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_bndrs :: forall pass. ConDecl pass -> XRec pass (HsOuterSigTyVarBndrs pass)
con_bndrs = L SrcSpanAnnA
l HsOuterTyVarBndrs Specificity GhcPs
outer_bndrs, con_mb_cxt :: forall pass. ConDecl pass -> Maybe (LHsContext pass)
con_mb_cxt = Maybe (LHsContext GhcPs)
cxt })
      = ConDecl GhcPs
con { con_bndrs :: XRec GhcPs (HsOuterTyVarBndrs Specificity GhcPs)
con_bndrs  = SrcSpanAnnA
-> HsOuterTyVarBndrs Specificity GhcPs
-> GenLocated SrcSpanAnnA (HsOuterTyVarBndrs Specificity GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l HsOuterTyVarBndrs Specificity GhcPs
outer_bndrs'
            , con_mb_cxt :: Maybe (LHsContext GhcPs)
con_mb_cxt = GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> Maybe
     (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)])
-> Maybe
     (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)])
forall {l} {a} {l}.
GenLocated l [a]
-> Maybe (GenLocated l [a]) -> Maybe (GenLocated l [a])
add_cxt GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
LHsContext GhcPs
cxt' Maybe
  (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)])
Maybe (LHsContext GhcPs)
cxt }
      where
        outer_bndrs' :: HsOuterTyVarBndrs Specificity GhcPs
outer_bndrs'
          | [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)]
all_tvs = HsOuterTyVarBndrs Specificity GhcPs
forall flag. HsOuterTyVarBndrs flag GhcPs
mkHsOuterImplicit
          | Bool
otherwise    = EpAnnForallTy
-> [LHsTyVarBndr Specificity GhcPs]
-> HsOuterTyVarBndrs Specificity GhcPs
forall flag.
EpAnnForallTy
-> [LHsTyVarBndr flag GhcPs] -> HsOuterTyVarBndrs flag GhcPs
mkHsOuterExplicit EpAnnForallTy
forall a. EpAnn a
noAnn [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)]
[LHsTyVarBndr Specificity GhcPs]
all_tvs

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

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

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

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

cvtConstr (GadtC [Name]
c [BangType]
strtys Type
ty)
  = do  { [LocatedN RdrName]
c'      <- (Name -> CvtM (LocatedN RdrName))
-> [Name] -> CvtM [LocatedN RdrName]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> CvtM (LocatedN RdrName)
cNameN [Name]
c
        ; [GenLocated SrcSpanAnnA (HsType GhcPs)]
args    <- (BangType -> CvtM (GenLocated SrcSpanAnnA (HsType GhcPs)))
-> [BangType] -> CvtM [GenLocated SrcSpanAnnA (HsType GhcPs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM BangType -> CvtM (GenLocated SrcSpanAnnA (HsType GhcPs))
BangType -> CvtM (LHsType GhcPs)
cvt_arg [BangType]
strtys
        ; GenLocated SrcSpanAnnA (HsType GhcPs)
ty'     <- Type -> CvtM (LHsType GhcPs)
cvtType Type
ty
        ; ConDecl GhcPs -> CvtM (GenLocated SrcSpanAnnA (ConDecl GhcPs))
forall e ann. e -> CvtM (GenLocated (SrcSpanAnn' (EpAnn ann)) e)
returnLA (ConDecl GhcPs -> CvtM (GenLocated SrcSpanAnnA (ConDecl GhcPs)))
-> ConDecl GhcPs -> CvtM (GenLocated SrcSpanAnnA (ConDecl GhcPs))
forall a b. (a -> b) -> a -> b
$ [LocatedN RdrName]
-> HsConDeclGADTDetails GhcPs -> LHsType GhcPs -> ConDecl GhcPs
mk_gadt_decl [LocatedN RdrName]
c' ([HsScaled GhcPs (LHsType GhcPs)] -> HsConDeclGADTDetails GhcPs
forall pass.
[HsScaled pass (LBangType pass)] -> HsConDeclGADTDetails pass
PrefixConGADT ([HsScaled GhcPs (LHsType GhcPs)] -> HsConDeclGADTDetails GhcPs)
-> [HsScaled GhcPs (LHsType GhcPs)] -> HsConDeclGADTDetails GhcPs
forall a b. (a -> b) -> a -> b
$ (GenLocated SrcSpanAnnA (HsType GhcPs)
 -> HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))
-> [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> [HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnA (HsType GhcPs)
-> HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a pass. a -> HsScaled pass a
hsLinear [GenLocated SrcSpanAnnA (HsType GhcPs)]
args) GenLocated SrcSpanAnnA (HsType GhcPs)
LHsType GhcPs
ty'}

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

cvtConstr (RecGadtC [Name]
c [VarBangType]
varstrtys Type
ty)
  = do  { [LocatedN RdrName]
c'       <- (Name -> CvtM (LocatedN RdrName))
-> [Name] -> CvtM [LocatedN RdrName]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> CvtM (LocatedN RdrName)
cNameN [Name]
c
        ; GenLocated SrcSpanAnnA (HsType GhcPs)
ty'      <- Type -> CvtM (LHsType GhcPs)
cvtType Type
ty
        ; [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
rec_flds <- (VarBangType -> CvtM (GenLocated SrcSpanAnnA (ConDeclField GhcPs)))
-> [VarBangType]
-> CvtM [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM VarBangType -> CvtM (GenLocated SrcSpanAnnA (ConDeclField GhcPs))
VarBangType -> CvtM (LConDeclField GhcPs)
cvt_id_arg [VarBangType]
varstrtys
        ; ConDecl GhcPs -> CvtM (GenLocated SrcSpanAnnA (ConDecl GhcPs))
forall e ann. e -> CvtM (GenLocated (SrcSpanAnn' (EpAnn ann)) e)
returnLA (ConDecl GhcPs -> CvtM (GenLocated SrcSpanAnnA (ConDecl GhcPs)))
-> ConDecl GhcPs -> CvtM (GenLocated SrcSpanAnnA (ConDecl GhcPs))
forall a b. (a -> b) -> a -> b
$ [LocatedN RdrName]
-> HsConDeclGADTDetails GhcPs -> LHsType GhcPs -> ConDecl GhcPs
mk_gadt_decl [LocatedN RdrName]
c' (XRec GhcPs [LConDeclField GhcPs] -> HsConDeclGADTDetails GhcPs
forall pass.
XRec pass [LConDeclField pass] -> HsConDeclGADTDetails pass
RecConGADT (XRec GhcPs [LConDeclField GhcPs] -> HsConDeclGADTDetails GhcPs)
-> XRec GhcPs [LConDeclField GhcPs] -> HsConDeclGADTDetails GhcPs
forall a b. (a -> b) -> a -> b
$ [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
-> GenLocated
     SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
forall a an. a -> LocatedAn an a
noLocA [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
rec_flds) GenLocated SrcSpanAnnA (HsType GhcPs)
LHsType GhcPs
ty' }

mk_gadt_decl :: [LocatedN RdrName] -> HsConDeclGADTDetails GhcPs -> LHsType GhcPs
             -> ConDecl GhcPs
mk_gadt_decl :: [LocatedN RdrName]
-> HsConDeclGADTDetails GhcPs -> LHsType GhcPs -> ConDecl GhcPs
mk_gadt_decl [LocatedN RdrName]
names HsConDeclGADTDetails GhcPs
args LHsType GhcPs
res_ty
  = ConDeclGADT { con_g_ext :: XConDeclGADT GhcPs
con_g_ext  = XConDeclGADT GhcPs
forall a. EpAnn a
noAnn
                , con_names :: [XRec GhcPs (IdP GhcPs)]
con_names  = [LocatedN RdrName]
[XRec GhcPs (IdP GhcPs)]
names
                , con_bndrs :: XRec GhcPs (HsOuterTyVarBndrs Specificity GhcPs)
con_bndrs  = HsOuterTyVarBndrs Specificity GhcPs
-> GenLocated SrcSpanAnnA (HsOuterTyVarBndrs Specificity GhcPs)
forall a an. a -> LocatedAn an a
noLocA HsOuterTyVarBndrs Specificity GhcPs
forall flag. HsOuterTyVarBndrs flag GhcPs
mkHsOuterImplicit
                , con_mb_cxt :: Maybe (LHsContext GhcPs)
con_mb_cxt = Maybe (LHsContext GhcPs)
forall a. Maybe a
Nothing
                , con_g_args :: HsConDeclGADTDetails GhcPs
con_g_args = HsConDeclGADTDetails GhcPs
args
                , con_res_ty :: LHsType GhcPs
con_res_ty = LHsType GhcPs
res_ty
                , con_doc :: Maybe LHsDocString
con_doc    = 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 { GenLocated SrcSpanAnnA (HsType 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 GenLocated SrcSpanAnnA (HsType GhcPs)
LHsType GhcPs
ty''
             su' :: SrcUnpackedness
su' = SourceUnpackedness -> SrcUnpackedness
cvtSrcUnpackedness SourceUnpackedness
su
             ss' :: SrcStrictness
ss' = SourceStrictness -> SrcStrictness
cvtSrcStrictness SourceStrictness
ss
       ; HsType GhcPs -> CvtM (GenLocated SrcSpanAnnA (HsType GhcPs))
forall e ann. e -> CvtM (GenLocated (SrcSpanAnn' (EpAnn ann)) e)
returnLA (HsType GhcPs -> CvtM (GenLocated SrcSpanAnnA (HsType GhcPs)))
-> HsType GhcPs -> CvtM (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a b. (a -> b) -> a -> b
$ XBangTy GhcPs -> HsSrcBang -> LHsType GhcPs -> HsType GhcPs
forall pass.
XBangTy pass -> HsSrcBang -> LHsType pass -> HsType pass
HsBangTy XBangTy GhcPs
forall a. EpAnn a
noAnn (SourceText -> SrcUnpackedness -> SrcStrictness -> HsSrcBang
HsSrcBang SourceText
NoSourceText SrcUnpackedness
su' SrcStrictness
ss') LHsType GhcPs
ty' }

cvt_id_arg :: (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField GhcPs)
cvt_id_arg :: VarBangType -> CvtM (LConDeclField GhcPs)
cvt_id_arg (Name
i, Bang
str, Type
ty)
  = do  { L SrcSpanAnnN
li RdrName
i' <- Name -> CvtM (LocatedN RdrName)
vNameN Name
i
        ; GenLocated SrcSpanAnnA (HsType GhcPs)
ty' <- BangType -> CvtM (LHsType GhcPs)
cvt_arg (Bang
str,Type
ty)
        ; GenLocated SrcSpanAnnA (ConDeclField GhcPs)
-> CvtM (GenLocated SrcSpanAnnA (ConDeclField GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (ConDeclField GhcPs)
 -> CvtM (GenLocated SrcSpanAnnA (ConDeclField GhcPs)))
-> GenLocated SrcSpanAnnA (ConDeclField GhcPs)
-> CvtM (GenLocated SrcSpanAnnA (ConDeclField GhcPs))
forall a b. (a -> b) -> a -> b
$ ConDeclField GhcPs -> GenLocated SrcSpanAnnA (ConDeclField GhcPs)
forall a an. a -> LocatedAn an a
noLocA (ConDeclField
                          { cd_fld_ext :: XConDeclField GhcPs
cd_fld_ext = XConDeclField GhcPs
forall a. EpAnn a
noAnn
                          , cd_fld_names :: [LFieldOcc GhcPs]
cd_fld_names
                              = [SrcSpan -> FieldOcc GhcPs -> GenLocated SrcSpan (FieldOcc GhcPs)
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnN -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnN
li) (FieldOcc GhcPs -> GenLocated SrcSpan (FieldOcc GhcPs))
-> FieldOcc GhcPs -> GenLocated SrcSpan (FieldOcc GhcPs)
forall a b. (a -> b) -> a -> b
$ XCFieldOcc GhcPs -> LocatedN RdrName -> FieldOcc GhcPs
forall pass. XCFieldOcc pass -> LocatedN RdrName -> FieldOcc pass
FieldOcc NoExtField
XCFieldOcc GhcPs
noExtField (SrcSpanAnnN -> RdrName -> LocatedN RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
li RdrName
i')]
                          , cd_fld_type :: LHsType GhcPs
cd_fld_type =  GenLocated SrcSpanAnnA (HsType GhcPs)
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 { [GenLocated SrcSpan (HsDerivingClause GhcPs)]
cs' <- (DerivClause -> CvtM (GenLocated SrcSpan (HsDerivingClause GhcPs)))
-> [DerivClause]
-> CvtM [GenLocated SrcSpan (HsDerivingClause GhcPs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM DerivClause -> CvtM (GenLocated SrcSpan (HsDerivingClause GhcPs))
DerivClause -> CvtM (LHsDerivingClause GhcPs)
cvtDerivClause [DerivClause]
cs
                  ; [GenLocated SrcSpan (HsDerivingClause GhcPs)]
-> CvtM [GenLocated SrcSpan (HsDerivingClause GhcPs)]
forall (m :: * -> *) a. Monad m => a -> m a
return [GenLocated SrcSpan (HsDerivingClause GhcPs)]
cs' }

cvt_fundep :: TH.FunDep -> CvtM (LHsFunDep GhcPs)
cvt_fundep :: FunDep -> CvtM (LHsFunDep GhcPs)
cvt_fundep (TH.FunDep [Name]
xs [Name]
ys) = do { [LocatedN RdrName]
xs' <- (Name -> CvtM (LocatedN RdrName))
-> [Name] -> CvtM [LocatedN RdrName]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> CvtM (LocatedN RdrName)
tNameN [Name]
xs
                                  ; [LocatedN RdrName]
ys' <- (Name -> CvtM (LocatedN RdrName))
-> [Name] -> CvtM [LocatedN RdrName]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> CvtM (LocatedN RdrName)
tNameN [Name]
ys
                                  ; FunDep GhcPs -> CvtM (GenLocated SrcSpanAnnA (FunDep GhcPs))
forall e ann. e -> CvtM (GenLocated (SrcSpanAnn' (EpAnn ann)) e)
returnLA (XCFunDep GhcPs
-> [XRec GhcPs (IdP GhcPs)]
-> [XRec GhcPs (IdP GhcPs)]
-> FunDep GhcPs
forall pass.
XCFunDep pass -> [LIdP pass] -> [LIdP pass] -> FunDep pass
Hs.FunDep XCFunDep GhcPs
forall a. EpAnn a
noAnn [LocatedN RdrName]
[XRec GhcPs (IdP GhcPs)]
xs' [LocatedN RdrName]
[XRec GhcPs (IdP GhcPs)]
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
  = SDoc -> CvtM (ForeignDecl GhcPs)
forall a. SDoc -> CvtM a
failWith (SDoc -> CvtM (ForeignDecl GhcPs))
-> SDoc -> CvtM (ForeignDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text (String -> String
forall a. Show a => a -> String
show String
from) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is not a valid ccall impent"
  where
    mk_imp :: ForeignImport -> CvtM (ForeignDecl GhcPs)
mk_imp ForeignImport
impspec
      = do { LocatedN RdrName
nm' <- Name -> CvtM (LocatedN RdrName)
vNameN Name
nm
           ; GenLocated SrcSpanAnnA (HsSigType GhcPs)
ty' <- Type -> CvtM (LHsSigType GhcPs)
cvtSigType Type
ty
           ; ForeignDecl GhcPs -> CvtM (ForeignDecl GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (ForeignImport { fd_i_ext :: XForeignImport GhcPs
fd_i_ext = XForeignImport GhcPs
forall a. EpAnn a
noAnn
                                   , fd_name :: XRec GhcPs (IdP GhcPs)
fd_name = LocatedN RdrName
XRec GhcPs (IdP GhcPs)
nm'
                                   , fd_sig_ty :: LHsSigType GhcPs
fd_sig_ty = GenLocated SrcSpanAnnA (HsSigType GhcPs)
LHsSigType GhcPs
ty'
                                   , fd_fi :: ForeignImport
fd_fi = ForeignImport
impspec })
           }
    safety' :: Safety
safety' = case Safety
safety of
                     Safety
Unsafe     -> Safety
PlayRisky
                     Safety
Safe       -> Safety
PlaySafe
                     Safety
Interruptible -> Safety
PlayInterruptible

cvtForD (ExportF Callconv
callconv String
as Name
nm Type
ty)
  = do  { LocatedN RdrName
nm' <- Name -> CvtM (LocatedN RdrName)
vNameN Name
nm
        ; GenLocated SrcSpanAnnA (HsSigType GhcPs)
ty' <- Type -> CvtM (LHsSigType GhcPs)
cvtSigType Type
ty
        ; let e :: ForeignExport
e = Located CExportSpec -> Located SourceText -> ForeignExport
CExport (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 { fd_e_ext :: XForeignExport GhcPs
fd_e_ext = XForeignExport GhcPs
forall a. EpAnn a
noAnn
                                 , fd_name :: XRec GhcPs (IdP GhcPs)
fd_name = LocatedN RdrName
XRec GhcPs (IdP GhcPs)
nm'
                                 , fd_sig_ty :: LHsSigType GhcPs
fd_sig_ty = GenLocated SrcSpanAnnA (HsSigType GhcPs)
LHsSigType GhcPs
ty'
                                 , fd_fe :: ForeignExport
fd_fe = ForeignExport
e } }

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

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

cvtPragmaD :: Pragma -> CvtM (Maybe (LHsDecl GhcPs))
cvtPragmaD :: Pragma -> CvtM (Maybe (LHsDecl GhcPs))
cvtPragmaD (InlineP Name
nm Inline
inline RuleMatch
rm Phases
phases)
  = do { LocatedN RdrName
nm' <- Name -> CvtM (LocatedN RdrName)
vNameN Name
nm
       ; let dflt :: Activation
dflt = Inline -> Activation
dfltActivation Inline
inline
       ; let src :: Inline -> String
src Inline
TH.NoInline  = String
"{-# NOINLINE"
             src Inline
TH.Inline    = String
"{-# INLINE"
             src Inline
TH.Inlinable = String
"{-# INLINABLE"
       ; let ip :: InlinePragma
ip   = InlinePragma { inl_src :: SourceText
inl_src    = String -> SourceText
SourceText (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 (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA (HsDecl GhcPs
 -> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs))))
-> HsDecl GhcPs
-> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl 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
-> XRec GhcPs (IdP GhcPs) -> InlinePragma -> Sig GhcPs
forall pass.
XInlineSig pass -> LIdP pass -> InlinePragma -> Sig pass
InlineSig XInlineSig GhcPs
forall a. EpAnn a
noAnn LocatedN RdrName
XRec GhcPs (IdP GhcPs)
nm' InlinePragma
ip }

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

cvtPragmaD (SpecialiseInstP Type
ty)
  = do { GenLocated SrcSpanAnnA (HsSigType GhcPs)
ty' <- Type -> CvtM (LHsSigType GhcPs)
cvtSigType Type
ty
       ; HsDecl GhcPs
-> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA (HsDecl GhcPs
 -> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs))))
-> HsDecl GhcPs
-> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl 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 XSpecInstSig GhcPs
forall a. EpAnn a
noAnn (String -> SourceText
SourceText String
"{-# SPECIALISE") GenLocated SrcSpanAnnA (HsSigType GhcPs)
LHsSigType GhcPs
ty' }

cvtPragmaD (RuleP String
nm Maybe [TyVarBndr ()]
ty_bndrs [RuleBndr]
tm_bndrs Exp
lhs Exp
rhs Phases
phases)
  = do { let nm' :: CLabelString
nm' = String -> CLabelString
mkFastString String
nm
       ; let act :: Activation
act = Phases -> Activation -> Activation
cvtPhases Phases
phases Activation
AlwaysActive
       ; Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)]
ty_bndrs' <- ([TyVarBndr ()]
 -> CvtM [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)])
-> Maybe [TyVarBndr ()]
-> CvtM (Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)])
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse [TyVarBndr ()]
-> CvtM [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)]
forall flag flag'.
CvtFlag flag flag' =>
[TyVarBndr flag] -> CvtM [LHsTyVarBndr flag' GhcPs]
cvtTvs Maybe [TyVarBndr ()]
ty_bndrs
       ; [GenLocated SrcSpan (RuleBndr GhcPs)]
tm_bndrs' <- (RuleBndr -> CvtM (GenLocated SrcSpan (RuleBndr GhcPs)))
-> [RuleBndr] -> CvtM [GenLocated SrcSpan (RuleBndr GhcPs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM RuleBndr -> CvtM (GenLocated SrcSpan (RuleBndr GhcPs))
RuleBndr -> CvtM (LRuleBndr GhcPs)
cvtRuleBndr [RuleBndr]
tm_bndrs
       ; GenLocated SrcSpanAnnA (HsExpr GhcPs)
lhs'   <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
lhs
       ; GenLocated SrcSpanAnnA (HsExpr GhcPs)
rhs'   <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
rhs
       ; HsDecl GhcPs
-> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA (HsDecl GhcPs
 -> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs))))
-> HsDecl GhcPs
-> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl 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 { rds_ext :: XCRuleDecls GhcPs
rds_ext = XCRuleDecls GhcPs
forall a. EpAnn a
noAnn
                      , rds_src :: SourceText
rds_src = String -> SourceText
SourceText String
"{-# RULES"
                      , rds_rules :: [LRuleDecl GhcPs]
rds_rules = [RuleDecl GhcPs -> LocatedAn AnnListItem (RuleDecl GhcPs)
forall a an. a -> LocatedAn an a
noLocA (RuleDecl GhcPs -> LocatedAn AnnListItem (RuleDecl GhcPs))
-> RuleDecl GhcPs -> LocatedAn AnnListItem (RuleDecl GhcPs)
forall a b. (a -> b) -> a -> b
$
                          HsRule { rd_ext :: XHsRule GhcPs
rd_ext  = XHsRule GhcPs
forall a. EpAnn a
noAnn
                                 , rd_name :: XRec GhcPs (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 [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)]
Maybe [LHsTyVarBndr () (NoGhcTc GhcPs)]
ty_bndrs'
                                 , rd_tmvs :: [LRuleBndr GhcPs]
rd_tmvs = [GenLocated SrcSpan (RuleBndr GhcPs)]
[LRuleBndr GhcPs]
tm_bndrs'
                                 , rd_lhs :: LHsExpr GhcPs
rd_lhs  = GenLocated SrcSpanAnnA (HsExpr GhcPs)
LHsExpr GhcPs
lhs'
                                 , rd_rhs :: LHsExpr GhcPs
rd_rhs  = GenLocated SrcSpanAnnA (HsExpr GhcPs)
LHsExpr GhcPs
rhs' }] }

          }

cvtPragmaD (AnnP AnnTarget
target Exp
exp)
  = do { GenLocated SrcSpanAnnA (HsExpr GhcPs)
exp' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
exp
       ; AnnProvenance GhcPs
target' <- case AnnTarget
target of
         AnnTarget
ModuleAnnotation  -> AnnProvenance GhcPs -> CvtM (AnnProvenance GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return AnnProvenance GhcPs
forall pass. AnnProvenance pass
ModuleAnnProvenance
         TypeAnnotation Name
n  -> do
           RdrName
n' <- Name -> CvtM RdrName
tconName Name
n
           AnnProvenance GhcPs -> CvtM (AnnProvenance GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (XRec GhcPs (IdP GhcPs) -> AnnProvenance GhcPs
forall pass. LIdP pass -> AnnProvenance pass
TypeAnnProvenance  (RdrName -> LocatedN RdrName
forall a an. a -> LocatedAn an a
noLocA RdrName
n'))
         ValueAnnotation Name
n -> do
           RdrName
n' <- Name -> CvtM RdrName
vcName Name
n
           AnnProvenance GhcPs -> CvtM (AnnProvenance GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (XRec GhcPs (IdP GhcPs) -> AnnProvenance GhcPs
forall pass. LIdP pass -> AnnProvenance pass
ValueAnnProvenance (RdrName -> LocatedN RdrName
forall a an. a -> LocatedAn an a
noLocA RdrName
n'))
       ; HsDecl GhcPs
-> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA (HsDecl GhcPs
 -> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs))))
-> HsDecl GhcPs
-> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl 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 GhcPs
-> LHsExpr GhcPs
-> AnnDecl GhcPs
forall pass.
XHsAnnotation pass
-> SourceText
-> AnnProvenance pass
-> XRec pass (HsExpr pass)
-> AnnDecl pass
HsAnnotation XHsAnnotation GhcPs
forall a. EpAnn a
noAnn (String -> SourceText
SourceText String
"{-# ANN") AnnProvenance GhcPs
target' GenLocated SrcSpanAnnA (HsExpr GhcPs)
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 (GenLocated SrcSpanAnnA (HsDecl GhcPs))
-> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs))
forall a. Maybe a
Nothing
       }
cvtPragmaD (CompleteP [Name]
cls Maybe Name
mty)
  = do { Located [LocatedN RdrName]
cls' <- [LocatedN RdrName] -> Located [LocatedN RdrName]
forall e. e -> Located e
noLoc ([LocatedN RdrName] -> Located [LocatedN RdrName])
-> CvtM [LocatedN RdrName] -> CvtM (Located [LocatedN RdrName])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name -> CvtM (LocatedN RdrName))
-> [Name] -> CvtM [LocatedN RdrName]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> CvtM (LocatedN RdrName)
cNameN [Name]
cls
       ; Maybe (LocatedN RdrName)
mty'  <- (Name -> CvtM (LocatedN RdrName))
-> Maybe Name -> CvtM (Maybe (LocatedN RdrName))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Name -> CvtM (LocatedN RdrName)
tconNameN Maybe Name
mty
       ; HsDecl GhcPs
-> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
forall a. a -> CvtM (Maybe (LocatedA a))
returnJustLA (HsDecl GhcPs
 -> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs))))
-> HsDecl GhcPs
-> CvtM (Maybe (GenLocated SrcSpanAnnA (HsDecl 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
-> XRec GhcPs [XRec GhcPs (IdP GhcPs)]
-> Maybe (XRec GhcPs (IdP GhcPs))
-> Sig GhcPs
forall pass.
XCompleteMatchSig pass
-> SourceText
-> XRec pass [LIdP pass]
-> Maybe (LIdP pass)
-> Sig pass
CompleteMatchSig XCompleteMatchSig GhcPs
forall a. EpAnn a
noAnn SourceText
NoSourceText Located [LocatedN RdrName]
XRec GhcPs [XRec GhcPs (IdP GhcPs)]
cls' Maybe (LocatedN RdrName)
Maybe (XRec GhcPs (IdP 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 { LocatedN RdrName
n' <- Name -> CvtM (LocatedN RdrName)
vNameN Name
n
       ; GenLocated SrcSpan (RuleBndr GhcPs)
-> CvtM (GenLocated SrcSpan (RuleBndr GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpan (RuleBndr GhcPs)
 -> CvtM (GenLocated SrcSpan (RuleBndr GhcPs)))
-> GenLocated SrcSpan (RuleBndr GhcPs)
-> CvtM (GenLocated SrcSpan (RuleBndr GhcPs))
forall a b. (a -> b) -> a -> b
$ RuleBndr GhcPs -> GenLocated SrcSpan (RuleBndr GhcPs)
forall e. e -> Located e
noLoc (RuleBndr GhcPs -> GenLocated SrcSpan (RuleBndr GhcPs))
-> RuleBndr GhcPs -> GenLocated SrcSpan (RuleBndr GhcPs)
forall a b. (a -> b) -> a -> b
$ XCRuleBndr GhcPs -> XRec GhcPs (IdP GhcPs) -> RuleBndr GhcPs
forall pass. XCRuleBndr pass -> LIdP pass -> RuleBndr pass
Hs.RuleBndr XCRuleBndr GhcPs
forall a. EpAnn a
noAnn LocatedN RdrName
XRec GhcPs (IdP GhcPs)
n' }
cvtRuleBndr (TypedRuleVar Name
n Type
ty)
  = do { LocatedN RdrName
n'  <- Name -> CvtM (LocatedN RdrName)
vNameN Name
n
       ; GenLocated SrcSpanAnnA (HsType GhcPs)
ty' <- Type -> CvtM (LHsType GhcPs)
cvtType Type
ty
       ; GenLocated SrcSpan (RuleBndr GhcPs)
-> CvtM (GenLocated SrcSpan (RuleBndr GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpan (RuleBndr GhcPs)
 -> CvtM (GenLocated SrcSpan (RuleBndr GhcPs)))
-> GenLocated SrcSpan (RuleBndr GhcPs)
-> CvtM (GenLocated SrcSpan (RuleBndr GhcPs))
forall a b. (a -> b) -> a -> b
$ RuleBndr GhcPs -> GenLocated SrcSpan (RuleBndr GhcPs)
forall e. e -> Located e
noLoc (RuleBndr GhcPs -> GenLocated SrcSpan (RuleBndr GhcPs))
-> RuleBndr GhcPs -> GenLocated SrcSpan (RuleBndr GhcPs)
forall a b. (a -> b) -> a -> b
$ XRuleBndrSig GhcPs
-> XRec GhcPs (IdP GhcPs) -> HsPatSigType GhcPs -> RuleBndr GhcPs
forall pass.
XRuleBndrSig pass
-> LIdP pass -> HsPatSigType pass -> RuleBndr pass
Hs.RuleBndrSig XRuleBndrSig GhcPs
forall a. EpAnn a
noAnn LocatedN RdrName
XRec GhcPs (IdP GhcPs)
n' (HsPatSigType GhcPs -> RuleBndr GhcPs)
-> HsPatSigType GhcPs -> RuleBndr GhcPs
forall a b. (a -> b) -> a -> b
$ EpAnn EpaLocation -> LHsType GhcPs -> HsPatSigType GhcPs
mkHsPatSigType EpAnn EpaLocation
forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (HsType GhcPs)
LHsType GhcPs
ty' }

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

cvtLocalDecs :: SDoc -> [TH.Dec] -> CvtM (HsLocalBinds GhcPs)
cvtLocalDecs :: SDoc -> [Dec] -> CvtM (HsLocalBinds GhcPs)
cvtLocalDecs SDoc
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
        [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
ds' <- [Dec] -> CvtM [LHsDecl GhcPs]
cvtDecs [Dec]
ds
        let ([GenLocated SrcSpanAnnA (HsBind GhcPs)]
binds, [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
prob_sigs) = (GenLocated SrcSpanAnnA (HsDecl GhcPs)
 -> Either
      (GenLocated SrcSpanAnnA (HsBind GhcPs))
      (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> ([GenLocated SrcSpanAnnA (HsBind GhcPs)],
    [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
partitionWith GenLocated SrcSpanAnnA (HsDecl GhcPs)
-> Either
     (GenLocated SrcSpanAnnA (HsBind GhcPs))
     (GenLocated SrcSpanAnnA (HsDecl GhcPs))
LHsDecl GhcPs -> Either (LHsBind GhcPs) (LHsDecl GhcPs)
is_bind [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
ds'
        let ([GenLocated SrcSpanAnnA (Sig GhcPs)]
sigs, [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
bads) = (GenLocated SrcSpanAnnA (HsDecl GhcPs)
 -> Either
      (GenLocated SrcSpanAnnA (Sig GhcPs))
      (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> ([GenLocated SrcSpanAnnA (Sig GhcPs)],
    [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
partitionWith GenLocated SrcSpanAnnA (HsDecl GhcPs)
-> Either
     (GenLocated SrcSpanAnnA (Sig GhcPs))
     (GenLocated SrcSpanAnnA (HsDecl GhcPs))
LHsDecl GhcPs -> Either (LSig GhcPs) (LHsDecl GhcPs)
is_sig [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
prob_sigs
        Bool -> CvtM () -> CvtM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([GenLocated SrcSpanAnnA (HsDecl GhcPs)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
bads) (SDoc -> CvtM ()
forall a. SDoc -> CvtM a
failWith (SDoc -> [GenLocated SrcSpanAnnA (HsDecl GhcPs)] -> SDoc
forall a. Outputable a => SDoc -> [a] -> SDoc
mkBadDecMsg SDoc
doc [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
bads))
        HsLocalBinds GhcPs -> CvtM (HsLocalBinds GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (XHsValBinds GhcPs GhcPs
-> HsValBindsLR GhcPs GhcPs -> HsLocalBinds GhcPs
forall idL idR.
XHsValBinds idL idR
-> HsValBindsLR idL idR -> HsLocalBindsLR idL idR
HsValBinds XHsValBinds GhcPs GhcPs
forall a. EpAnn a
noAnn (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 AnnSortKey
XValBinds GhcPs GhcPs
NoAnnSortKey ([GenLocated SrcSpanAnnA (HsBind GhcPs)]
-> Bag (GenLocated SrcSpanAnnA (HsBind GhcPs))
forall a. [a] -> Bag a
listToBag [GenLocated SrcSpanAnnA (HsBind GhcPs)]
binds) [GenLocated SrcSpanAnnA (Sig GhcPs)]
[LSig GhcPs]
sigs))
      ([(String, Exp)]
ip_binds, []) -> do
        [GenLocated SrcSpanAnnA (IPBind GhcPs)]
binds <- ((String, Exp) -> CvtM (GenLocated SrcSpanAnnA (IPBind GhcPs)))
-> [(String, Exp)] -> CvtM [GenLocated SrcSpanAnnA (IPBind GhcPs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((String -> Exp -> CvtM (GenLocated SrcSpanAnnA (IPBind GhcPs)))
-> (String, Exp) -> CvtM (GenLocated SrcSpanAnnA (IPBind GhcPs))
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> Exp -> CvtM (GenLocated SrcSpanAnnA (IPBind GhcPs))
String -> Exp -> CvtM (LIPBind GhcPs)
cvtImplicitParamBind) [(String, Exp)]
ip_binds
        HsLocalBinds GhcPs -> CvtM (HsLocalBinds GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (XHsIPBinds GhcPs GhcPs -> HsIPBinds GhcPs -> HsLocalBinds GhcPs
forall idL idR.
XHsIPBinds idL idR -> HsIPBinds idR -> HsLocalBindsLR idL idR
HsIPBinds XHsIPBinds GhcPs GhcPs
forall a. EpAnn a
noAnn (XIPBinds GhcPs -> [LIPBind GhcPs] -> HsIPBinds GhcPs
forall id. XIPBinds id -> [LIPBind id] -> HsIPBinds id
IPBinds NoExtField
XIPBinds GhcPs
noExtField [GenLocated SrcSpanAnnA (IPBind GhcPs)]
[LIPBind GhcPs]
binds))
      (((String, Exp)
_:[(String, Exp)]
_), (Dec
_:[Dec]
_)) ->
        SDoc -> CvtM (HsLocalBinds GhcPs)
forall a. SDoc -> CvtM a
failWith (String -> SDoc
text String
"Implicit parameters mixed with other bindings")

cvtClause :: HsMatchContext GhcPs
          -> TH.Clause -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))
cvtClause :: HsMatchContext GhcPs
-> Clause -> CvtM (LMatch GhcPs (LHsExpr GhcPs))
cvtClause HsMatchContext GhcPs
ctxt (Clause [Pat]
ps Body
body [Dec]
wheres)
  = do  { [GenLocated SrcSpanAnnA (Pat GhcPs)]
ps' <- [Pat] -> CvtM [LPat GhcPs]
cvtPats [Pat]
ps
        ; let pps :: [GenLocated SrcSpanAnnA (Pat GhcPs)]
pps = (GenLocated SrcSpanAnnA (Pat GhcPs)
 -> GenLocated SrcSpanAnnA (Pat GhcPs))
-> [GenLocated SrcSpanAnnA (Pat GhcPs)]
-> [GenLocated SrcSpanAnnA (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) [GenLocated SrcSpanAnnA (Pat GhcPs)]
ps'
        ; [GenLocated
   SrcSpan (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
g'  <- Body -> CvtM [LGRHS GhcPs (LHsExpr GhcPs)]
cvtGuard Body
body
        ; HsLocalBinds GhcPs
ds' <- SDoc -> [Dec] -> CvtM (HsLocalBinds GhcPs)
cvtLocalDecs (String -> SDoc
text String
"a where clause") [Dec]
wheres
        ; Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> CvtM
     (GenLocated
        SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
forall e ann. e -> CvtM (GenLocated (SrcSpanAnn' (EpAnn ann)) e)
returnLA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> CvtM
      (GenLocated
         SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))))
-> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> CvtM
     (GenLocated
        SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
forall a b. (a -> b) -> a -> b
$ XCMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> HsMatchContext (NoGhcTc GhcPs)
-> [LPat GhcPs]
-> GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall p body.
XCMatch p body
-> HsMatchContext (NoGhcTc p)
-> [LPat p]
-> GRHSs p body
-> Match p body
Hs.Match XCMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. EpAnn a
noAnn HsMatchContext (NoGhcTc GhcPs)
HsMatchContext GhcPs
ctxt [GenLocated SrcSpanAnnA (Pat GhcPs)]
[LPat GhcPs]
pps (XCGRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> [LGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
-> HsLocalBinds GhcPs
-> GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall p body.
XCGRHSs p body -> [LGRHS p body] -> HsLocalBinds p -> GRHSs p body
GRHSs EpAnnComments
XCGRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
emptyComments [GenLocated
   SrcSpan (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
[LGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
g' HsLocalBinds GhcPs
ds') }

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

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

cvtl :: TH.Exp -> CvtM (LHsExpr GhcPs)
cvtl :: Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
e = CvtM (HsExpr GhcPs) -> CvtM (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. CvtM a -> CvtM (LocatedA a)
wrapLA (Exp -> CvtM (HsExpr GhcPs)
cvt Exp
e)
  where
    cvt :: Exp -> CvtM (HsExpr GhcPs)
cvt (VarE Name
s)   = do { RdrName
s' <- Name -> CvtM RdrName
vName Name
s; 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 -> XRec GhcPs (IdP GhcPs) -> HsExpr GhcPs
forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
XVar GhcPs
noExtField (RdrName -> LocatedN RdrName
forall a an. a -> LocatedAn an a
noLocA 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 -> XRec GhcPs (IdP GhcPs) -> HsExpr GhcPs
forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
XVar GhcPs
noExtField (RdrName -> LocatedN RdrName
forall a an. a -> LocatedAn an a
noLocA 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 EpAnnCO
XOverLitE GhcPs
noComments)
                             (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 EpAnnCO
XLitE GhcPs
noComments)
                             (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 XPar GhcPs
forall a. EpAnn a
noAnn (HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall a an. a -> LocatedAn an a
noLocA HsExpr GhcPs
e') else HsExpr GhcPs
e'
    cvt (AppE x :: Exp
x@(LamE [Pat]
_ Exp
_) Exp
y) = do { GenLocated SrcSpanAnnA (HsExpr GhcPs)
x' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
x; GenLocated SrcSpanAnnA (HsExpr GhcPs)
y' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
y
                                   ; 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 EpAnnCO
XApp GhcPs
noComments (LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkLHsPar GenLocated SrcSpanAnnA (HsExpr GhcPs)
LHsExpr GhcPs
x')
                                                          (LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkLHsPar GenLocated SrcSpanAnnA (HsExpr GhcPs)
LHsExpr GhcPs
y')}
    cvt (AppE Exp
x Exp
y)            = do { GenLocated SrcSpanAnnA (HsExpr GhcPs)
x' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
x; GenLocated SrcSpanAnnA (HsExpr GhcPs)
y' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
y
                                   ; 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 EpAnnCO
XApp GhcPs
noComments (LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkLHsPar GenLocated SrcSpanAnnA (HsExpr GhcPs)
LHsExpr GhcPs
x')
                                                          (LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkLHsPar GenLocated SrcSpanAnnA (HsExpr GhcPs)
LHsExpr GhcPs
y')}
    cvt (AppTypeE Exp
e Type
t) = do { GenLocated SrcSpanAnnA (HsExpr GhcPs)
e' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
e
                            ; GenLocated SrcSpanAnnA (HsType GhcPs)
t' <- Type -> CvtM (LHsType GhcPs)
cvtType Type
t
                            ; let tp :: LHsType GhcPs
tp = PprPrec -> LHsType GhcPs -> LHsType GhcPs
forall (p :: Pass).
PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)
parenthesizeHsType PprPrec
appPrec GenLocated SrcSpanAnnA (HsType GhcPs)
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 SrcSpan
XAppTypeE GhcPs
noSrcSpan GenLocated SrcSpanAnnA (HsExpr GhcPs)
LHsExpr GhcPs
e'
                                     (LHsWcType (NoGhcTc GhcPs) -> HsExpr GhcPs)
-> LHsWcType (NoGhcTc GhcPs) -> HsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnA (HsType GhcPs)
-> HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
forall thing. thing -> HsWildCardBndrs GhcPs thing
mkHsWildCardBndrs GenLocated SrcSpanAnnA (HsType GhcPs)
LHsType GhcPs
tp }
    cvt (LamE [] Exp
e)    = Exp -> CvtM (HsExpr GhcPs)
cvt Exp
e -- Degenerate case. We convert the body as its
                               -- own expression to avoid pretty-printing
                               -- oddities that can result from zero-argument
                               -- lambda expressions. See #13856.
    cvt (LamE [Pat]
ps Exp
e)    = do { [GenLocated SrcSpanAnnA (Pat GhcPs)]
ps' <- [Pat] -> CvtM [LPat GhcPs]
cvtPats [Pat]
ps; GenLocated SrcSpanAnnA (HsExpr GhcPs)
e' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
e
                            ; let pats :: [GenLocated SrcSpanAnnA (Pat GhcPs)]
pats = (GenLocated SrcSpanAnnA (Pat GhcPs)
 -> GenLocated SrcSpanAnnA (Pat GhcPs))
-> [GenLocated SrcSpanAnnA (Pat GhcPs)]
-> [GenLocated SrcSpanAnnA (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) [GenLocated SrcSpanAnnA (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
-> LocatedL
     [GenLocated
        SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
AnnoBody p body =>
Origin
-> LocatedL
     [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]
-> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))
mkMatchGroup Origin
th_origin
                                             ([GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> LocatedL
     [GenLocated
        SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall a an. a -> LocatedAn an a
noLocA [HsMatchContext (NoGhcTc GhcPs)
-> [LPat GhcPs]
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> LMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
(Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcSpanAnnA,
 Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpan) =>
HsMatchContext (NoGhcTc (GhcPass p))
-> [LPat (GhcPass p)]
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkSimpleMatch HsMatchContext (NoGhcTc GhcPs)
forall p. HsMatchContext p
LambdaExpr
                                             [GenLocated SrcSpanAnnA (Pat GhcPs)]
[LPat GhcPs]
pats GenLocated SrcSpanAnnA (HsExpr GhcPs)
e']))}
    cvt (LamCaseE [Match]
ms)  = do { [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
ms' <- (Match
 -> CvtM
      (GenLocated
         SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))))
-> [Match]
-> CvtM
     [GenLocated
        SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr 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 XLamCase GhcPs
forall a. EpAnn a
noAnn
                                                   (Origin
-> LocatedL
     [GenLocated
        SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
AnnoBody p body =>
Origin
-> LocatedL
     [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]
-> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))
mkMatchGroup Origin
th_origin ([GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> LocatedL
     [GenLocated
        SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall a an. a -> LocatedAn an a
noLocA [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
ms'))
                            }
    cvt (TupE [Maybe Exp]
es)        = [Maybe Exp] -> Boxity -> CvtM (HsExpr GhcPs)
cvt_tup [Maybe Exp]
es Boxity
Boxed
    cvt (UnboxedTupE [Maybe Exp]
es) = [Maybe Exp] -> Boxity -> CvtM (HsExpr GhcPs)
cvt_tup [Maybe Exp]
es Boxity
Unboxed
    cvt (UnboxedSumE Exp
e Int
alt Int
arity) = do { GenLocated SrcSpanAnnA (HsExpr GhcPs)
e' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
e
                                       ; Int -> Int -> CvtM ()
unboxedSumChecks Int
alt Int
arity
                                       ; HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcPs -> CvtM (HsExpr GhcPs))
-> HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XExplicitSum GhcPs -> Int -> Int -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XExplicitSum p -> Int -> Int -> LHsExpr p -> HsExpr p
ExplicitSum XExplicitSum GhcPs
forall a. EpAnn a
noAnn
                                                                   Int
alt Int
arity GenLocated SrcSpanAnnA (HsExpr GhcPs)
LHsExpr GhcPs
e'}
    cvt (CondE Exp
x Exp
y Exp
z)  = do { GenLocated SrcSpanAnnA (HsExpr GhcPs)
x' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
x; GenLocated SrcSpanAnnA (HsExpr GhcPs)
y' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
y; GenLocated SrcSpanAnnA (HsExpr GhcPs)
z' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
z;
                            ; 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 -> EpAnn AnnsIf -> HsExpr GhcPs
mkHsIf GenLocated SrcSpanAnnA (HsExpr GhcPs)
LHsExpr GhcPs
x' GenLocated SrcSpanAnnA (HsExpr GhcPs)
LHsExpr GhcPs
y' GenLocated SrcSpanAnnA (HsExpr GhcPs)
LHsExpr GhcPs
z' EpAnn AnnsIf
forall a. EpAnn a
noAnn }
    cvt (MultiIfE [(Guard, Exp)]
alts)
      | [(Guard, Exp)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Guard, Exp)]
alts      = SDoc -> CvtM (HsExpr GhcPs)
forall a. SDoc -> CvtM a
failWith (String -> SDoc
text String
"Multi-way if-expression with no alternatives")
      | Bool
otherwise      = do { [GenLocated
   SrcSpan (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
alts' <- ((Guard, Exp)
 -> CvtM
      (GenLocated
         SrcSpan (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))))
-> [(Guard, Exp)]
-> CvtM
     [GenLocated
        SrcSpan (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Guard, Exp)
-> CvtM
     (GenLocated
        SrcSpan (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
(Guard, Exp) -> CvtM (LGRHS GhcPs (LHsExpr GhcPs))
cvtpair [(Guard, Exp)]
alts
                            ; HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcPs -> CvtM (HsExpr GhcPs))
-> HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XMultiIf GhcPs -> [LGRHS GhcPs (LHsExpr GhcPs)] -> HsExpr GhcPs
forall p. XMultiIf p -> [LGRHS p (LHsExpr p)] -> HsExpr p
HsMultiIf XMultiIf GhcPs
forall a. EpAnn a
noAnn [GenLocated
   SrcSpan (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
[LGRHS GhcPs (LHsExpr GhcPs)]
alts' }
    cvt (LetE [Dec]
ds Exp
e)    = do { HsLocalBinds GhcPs
ds' <- SDoc -> [Dec] -> CvtM (HsLocalBinds GhcPs)
cvtLocalDecs (String -> SDoc
text String
"a let expression") [Dec]
ds
                            ; GenLocated SrcSpanAnnA (HsExpr GhcPs)
e' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
e; 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 -> HsLocalBinds GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XLet p -> HsLocalBinds p -> LHsExpr p -> HsExpr p
HsLet XLet GhcPs
forall a. EpAnn a
noAnn HsLocalBinds GhcPs
ds' GenLocated SrcSpanAnnA (HsExpr GhcPs)
LHsExpr GhcPs
e'}
    cvt (CaseE Exp
e [Match]
ms)   = do { GenLocated SrcSpanAnnA (HsExpr GhcPs)
e' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
e; [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
ms' <- (Match
 -> CvtM
      (GenLocated
         SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))))
-> [Match]
-> CvtM
     [GenLocated
        SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr 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 XCase GhcPs
forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (HsExpr GhcPs)
LHsExpr GhcPs
e'
                                                 (Origin
-> LocatedL
     [GenLocated
        SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
AnnoBody p body =>
Origin
-> LocatedL
     [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]
-> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))
mkMatchGroup Origin
th_origin ([GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> LocatedL
     [GenLocated
        SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall a an. a -> LocatedAn an a
noLocA [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
ms')) }
    cvt (DoE Maybe ModName
m [Stmt]
ss)     = HsStmtContext GhcRn -> [Stmt] -> CvtM (HsExpr GhcPs)
cvtHsDo (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 XArithSeq GhcPs
forall a. EpAnn a
noAnn 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 EpAnnCO
XLitE GhcPs
noComments HsLit GhcPs
l') }
             -- Note [Converting strings]
      | Bool
otherwise       = do { [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
xs' <- (Exp -> CvtM (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> [Exp] -> CvtM [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Exp -> CvtM (GenLocated SrcSpanAnnA (HsExpr GhcPs))
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 -> [LHsExpr GhcPs] -> HsExpr GhcPs
forall p. XExplicitList p -> [LHsExpr p] -> HsExpr p
ExplicitList XExplicitList GhcPs
forall a. EpAnn a
noAnn [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
[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 { GenLocated SrcSpanAnnA (HsExpr GhcPs)
x' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
x
         ; GenLocated SrcSpanAnnA (HsExpr GhcPs)
s' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
s
         ; GenLocated SrcSpanAnnA (HsExpr GhcPs)
y' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
y
         ; let px :: LHsExpr GhcPs
px = PprPrec -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (p :: Pass).
IsPass p =>
PprPrec -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
parenthesizeHsExpr PprPrec
opPrec GenLocated SrcSpanAnnA (HsExpr GhcPs)
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 GenLocated SrcSpanAnnA (HsExpr GhcPs)
LHsExpr GhcPs
y'
         ; (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> HsExpr GhcPs)
-> HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall a. (LocatedA a -> a) -> a -> CvtM a
wrapParLA (XPar GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar XPar GhcPs
forall a. EpAnn a
noAnn)
           (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 XOpApp GhcPs
forall a. EpAnn a
noAnn LHsExpr GhcPs
px GenLocated SrcSpanAnnA (HsExpr GhcPs)
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 { GenLocated SrcSpanAnnA (HsExpr GhcPs)
s' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
s; GenLocated SrcSpanAnnA (HsExpr GhcPs)
y' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
y
                                          ; (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> HsExpr GhcPs)
-> HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall a. (LocatedA a -> a) -> a -> CvtM a
wrapParLA (XPar GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar XPar GhcPs
forall a. EpAnn a
noAnn) (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 EpAnnCO
XSectionR GhcPs
noComments GenLocated SrcSpanAnnA (HsExpr GhcPs)
LHsExpr GhcPs
s' GenLocated SrcSpanAnnA (HsExpr GhcPs)
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 { GenLocated SrcSpanAnnA (HsExpr GhcPs)
x' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
x; GenLocated SrcSpanAnnA (HsExpr GhcPs)
s' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
s
                                          ; (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> HsExpr GhcPs)
-> HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall a. (LocatedA a -> a) -> a -> CvtM a
wrapParLA (XPar GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar XPar GhcPs
forall a. EpAnn a
noAnn) (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 EpAnnCO
XSectionL GhcPs
noComments GenLocated SrcSpanAnnA (HsExpr GhcPs)
LHsExpr GhcPs
x' GenLocated SrcSpanAnnA (HsExpr GhcPs)
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 { GenLocated SrcSpanAnnA (HsExpr GhcPs)
s' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
s
                                          ; HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcPs -> CvtM (HsExpr GhcPs))
-> HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XPar GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar XPar GhcPs
forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (HsExpr GhcPs)
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 { GenLocated SrcSpanAnnA (HsExpr GhcPs)
x' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
x
                              ; let x'' :: GenLocated SrcSpanAnnA (HsExpr GhcPs)
x'' = case GenLocated SrcSpanAnnA (HsExpr GhcPs) -> HsExpr GhcPs
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (HsExpr GhcPs)
x' of
                                            OpApp {} -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
x'
                                            HsExpr GhcPs
_ -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkLHsPar GenLocated SrcSpanAnnA (HsExpr GhcPs)
LHsExpr GhcPs
x'
                              ; LHsExpr GhcPs -> Exp -> Exp -> CvtM (HsExpr GhcPs)
cvtOpApp GenLocated SrcSpanAnnA (HsExpr GhcPs)
LHsExpr GhcPs
x'' Exp
s Exp
y } --  Note [Converting UInfix]

    cvt (ParensE Exp
e)      = do { GenLocated SrcSpanAnnA (HsExpr GhcPs)
e' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
e; HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcPs -> CvtM (HsExpr GhcPs))
-> HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XPar GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar XPar GhcPs
forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (HsExpr GhcPs)
LHsExpr GhcPs
e' }
    cvt (SigE Exp
e Type
t)       = do { GenLocated SrcSpanAnnA (HsExpr GhcPs)
e' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
e; GenLocated SrcSpanAnnA (HsSigType GhcPs)
t' <- Type -> CvtM (LHsSigType GhcPs)
cvtSigType Type
t
                              ; let pe :: LHsExpr GhcPs
pe = PprPrec -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (p :: Pass).
IsPass p =>
PprPrec -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
parenthesizeHsExpr PprPrec
sigPrec GenLocated SrcSpanAnnA (HsExpr GhcPs)
LHsExpr GhcPs
e'
                              ; HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcPs -> CvtM (HsExpr GhcPs))
-> HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XExprWithTySig GhcPs
-> LHsExpr GhcPs -> LHsSigWcType (NoGhcTc GhcPs) -> HsExpr GhcPs
forall p.
XExprWithTySig p
-> LHsExpr p -> LHsSigWcType (NoGhcTc p) -> HsExpr p
ExprWithTySig XExprWithTySig GhcPs
forall a. EpAnn a
noAnn LHsExpr GhcPs
pe (GenLocated SrcSpanAnnA (HsSigType GhcPs)
-> HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs))
forall thing. thing -> HsWildCardBndrs GhcPs thing
mkHsWildCardBndrs GenLocated SrcSpanAnnA (HsSigType GhcPs)
t') }
    cvt (RecConE Name
c [FieldExp]
flds) = do { LocatedN RdrName
c' <- Name -> CvtM (LocatedN RdrName)
cNameN Name
c
                              ; [GenLocated
   SrcSpanAnnA
   (HsRecField'
      (FieldOcc GhcPs) (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
flds' <- (FieldExp
 -> CvtM
      (GenLocated
         SrcSpanAnnA
         (HsRecField'
            (FieldOcc GhcPs) (GenLocated SrcSpanAnnA (HsExpr GhcPs)))))
-> [FieldExp]
-> CvtM
     [GenLocated
        SrcSpanAnnA
        (HsRecField'
           (FieldOcc GhcPs) (GenLocated SrcSpanAnnA (HsExpr 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' GhcPs (FieldOcc GhcPs) (LHsExpr GhcPs))
forall t.
(RdrName -> t)
-> FieldExp -> CvtM (LHsRecField' GhcPs t (LHsExpr GhcPs))
cvtFld (LocatedN RdrName -> FieldOcc GhcPs
mkFieldOcc (LocatedN RdrName -> FieldOcc GhcPs)
-> (RdrName -> LocatedN RdrName) -> RdrName -> FieldOcc GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RdrName -> LocatedN RdrName
forall a an. a -> LocatedAn an a
noLocA)) [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
$ LocatedN RdrName
-> HsRecordBinds GhcPs -> EpAnn [AddEpAnn] -> HsExpr GhcPs
mkRdrRecordCon LocatedN RdrName
c' ([LHsRecField GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
-> Maybe (Located Int)
-> HsRecFields GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall p arg.
[LHsRecField p arg] -> Maybe (Located Int) -> HsRecFields p arg
HsRecFields [GenLocated
   SrcSpanAnnA
   (HsRecField'
      (FieldOcc GhcPs) (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
[LHsRecField GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
flds' Maybe (Located Int)
forall a. Maybe a
Nothing) EpAnn [AddEpAnn]
forall a. EpAnn a
noAnn }
    cvt (RecUpdE Exp
e [FieldExp]
flds) = do { GenLocated SrcSpanAnnA (HsExpr GhcPs)
e' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
e
                              ; [GenLocated
   SrcSpanAnnA
   (HsRecField'
      (AmbiguousFieldOcc GhcPs) (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
flds'
                                  <- (FieldExp
 -> CvtM
      (GenLocated
         SrcSpanAnnA
         (HsRecField'
            (AmbiguousFieldOcc GhcPs)
            (GenLocated SrcSpanAnnA (HsExpr GhcPs)))))
-> [FieldExp]
-> CvtM
     [GenLocated
        SrcSpanAnnA
        (HsRecField'
           (AmbiguousFieldOcc GhcPs) (GenLocated SrcSpanAnnA (HsExpr 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' GhcPs (AmbiguousFieldOcc GhcPs) (LHsExpr GhcPs))
forall t.
(RdrName -> t)
-> FieldExp -> CvtM (LHsRecField' GhcPs t (LHsExpr GhcPs))
cvtFld (LocatedN RdrName -> AmbiguousFieldOcc GhcPs
mkAmbiguousFieldOcc (LocatedN RdrName -> AmbiguousFieldOcc GhcPs)
-> (RdrName -> LocatedN RdrName)
-> RdrName
-> AmbiguousFieldOcc GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RdrName -> LocatedN RdrName
forall a an. a -> LocatedAn an a
noLocA))
                                           [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
$ XRecordUpd GhcPs
-> LHsExpr GhcPs
-> Either
     [LHsRecField' GhcPs (AmbiguousFieldOcc GhcPs) (LHsExpr GhcPs)]
     [LHsRecUpdProj GhcPs]
-> HsExpr GhcPs
forall p.
XRecordUpd p
-> LHsExpr p
-> Either [LHsRecUpdField p] [LHsRecUpdProj p]
-> HsExpr p
RecordUpd XRecordUpd GhcPs
forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (HsExpr GhcPs)
LHsExpr GhcPs
e' ([GenLocated
   SrcSpanAnnA
   (HsRecField'
      (AmbiguousFieldOcc GhcPs) (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> Either
     [GenLocated
        SrcSpanAnnA
        (HsRecField'
           (AmbiguousFieldOcc GhcPs) (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
     [GenLocated
        SrcSpanAnnA
        (HsRecField'
           (FieldLabelStrings GhcPs) (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall a b. a -> Either a b
Left [GenLocated
   SrcSpanAnnA
   (HsRecField'
      (AmbiguousFieldOcc GhcPs) (GenLocated SrcSpanAnnA (HsExpr 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 XStatic GhcPs
forall a. EpAnn a
noAnn) (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 -> XRec GhcPs (IdP GhcPs) -> HsExpr GhcPs
forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
XVar GhcPs
noExtField (RdrName -> LocatedN RdrName
forall a an. a -> LocatedAn an a
noLocA RdrName
s') }
    cvt (LabelE String
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
$ XOverLabel GhcPs -> CLabelString -> HsExpr GhcPs
forall p. XOverLabel p -> CLabelString -> HsExpr p
HsOverLabel EpAnnCO
XOverLabel GhcPs
noComments (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 EpAnnCO
XIPVar GhcPs
noComments HsIPName
n' }
    cvt (GetFieldE Exp
exp String
f) = do { GenLocated SrcSpanAnnA (HsExpr GhcPs)
e' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
exp
                               ; 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
$ XGetField GhcPs
-> LHsExpr GhcPs -> Located (HsFieldLabel GhcPs) -> HsExpr GhcPs
forall p.
XGetField p -> LHsExpr p -> Located (HsFieldLabel p) -> HsExpr p
HsGetField EpAnnCO
XGetField GhcPs
noComments GenLocated SrcSpanAnnA (HsExpr GhcPs)
LHsExpr GhcPs
e' (SrcSpan -> HsFieldLabel GhcPs -> Located (HsFieldLabel GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
noSrcSpan (XCHsFieldLabel GhcPs -> Located CLabelString -> HsFieldLabel GhcPs
forall p.
XCHsFieldLabel p -> Located CLabelString -> HsFieldLabel p
HsFieldLabel XCHsFieldLabel GhcPs
forall a. EpAnn a
noAnn (SrcSpan -> CLabelString -> Located CLabelString
forall l e. l -> e -> GenLocated l e
L SrcSpan
noSrcSpan (String -> CLabelString
fsLit String
f)))) }
    cvt (ProjectionE NonEmpty String
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
$ XProjection GhcPs
-> NonEmpty (Located (HsFieldLabel GhcPs)) -> HsExpr GhcPs
forall p.
XProjection p -> NonEmpty (Located (HsFieldLabel p)) -> HsExpr p
HsProjection XProjection GhcPs
forall a. EpAnn a
noAnn (NonEmpty (Located (HsFieldLabel GhcPs)) -> HsExpr GhcPs)
-> NonEmpty (Located (HsFieldLabel GhcPs)) -> HsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ (String -> Located (HsFieldLabel GhcPs))
-> NonEmpty String -> NonEmpty (Located (HsFieldLabel GhcPs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SrcSpan -> HsFieldLabel GhcPs -> Located (HsFieldLabel GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
noSrcSpan (HsFieldLabel GhcPs -> Located (HsFieldLabel GhcPs))
-> (String -> HsFieldLabel GhcPs)
-> String
-> Located (HsFieldLabel GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XCHsFieldLabel GhcPs -> Located CLabelString -> HsFieldLabel GhcPs
forall p.
XCHsFieldLabel p -> Located CLabelString -> HsFieldLabel p
HsFieldLabel XCHsFieldLabel GhcPs
forall a. EpAnn a
noAnn (Located CLabelString -> HsFieldLabel GhcPs)
-> (String -> Located CLabelString) -> String -> HsFieldLabel GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> CLabelString -> Located CLabelString
forall l e. l -> e -> GenLocated l e
L SrcSpan
noSrcSpan (CLabelString -> Located CLabelString)
-> (String -> CLabelString) -> String -> Located CLabelString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> CLabelString
fsLit) NonEmpty String
xs

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

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

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

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

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

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

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

  OpApp (OpApp x * y) + z

which we don't want.
-}

cvtFld :: (RdrName -> t) -> (TH.Name, TH.Exp)
       -> CvtM (LHsRecField' GhcPs t (LHsExpr GhcPs))
cvtFld :: forall t.
(RdrName -> t)
-> FieldExp -> CvtM (LHsRecField' GhcPs t (LHsExpr GhcPs))
cvtFld RdrName -> t
f (Name
v,Exp
e)
  = do  { LocatedA RdrName
v' <- Name -> CvtM (LocatedA RdrName)
vNameL Name
v; GenLocated SrcSpanAnnA (HsExpr GhcPs)
e' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
e
        ; LocatedAn
  AnnListItem (HsRecField' t (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> CvtM
     (LocatedAn
        AnnListItem
        (HsRecField' t (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
forall (m :: * -> *) a. Monad m => a -> m a
return (HsRecField' t (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> LocatedAn
     AnnListItem (HsRecField' t (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a an. a -> LocatedAn an a
noLocA (HsRecField' t (GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> LocatedAn
      AnnListItem
      (HsRecField' t (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> HsRecField' t (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> LocatedAn
     AnnListItem (HsRecField' t (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a b. (a -> b) -> a -> b
$ HsRecField { hsRecFieldAnn :: XHsRecField t
hsRecFieldAnn = XHsRecField t
forall a. EpAnn a
noAnn
                                      , hsRecFieldLbl :: Located t
hsRecFieldLbl = LocatedAn AnnListItem t -> Located t
forall a e. LocatedAn a e -> Located e
reLoc (LocatedAn AnnListItem t -> Located t)
-> LocatedAn AnnListItem t -> Located t
forall a b. (a -> b) -> a -> b
$ (RdrName -> t) -> LocatedA RdrName -> LocatedAn AnnListItem t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RdrName -> t
f LocatedA RdrName
v'
                                      , hsRecFieldArg :: GenLocated SrcSpanAnnA (HsExpr GhcPs)
hsRecFieldArg = GenLocated SrcSpanAnnA (HsExpr GhcPs)
e'
                                      , hsRecPun :: Bool
hsRecPun      = Bool
False}) }

cvtDD :: Range -> CvtM (ArithSeqInfo GhcPs)
cvtDD :: Range -> CvtM (ArithSeqInfo GhcPs)
cvtDD (FromR Exp
x)           = do { GenLocated SrcSpanAnnA (HsExpr GhcPs)
x' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
x; 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 GenLocated SrcSpanAnnA (HsExpr GhcPs)
LHsExpr GhcPs
x' }
cvtDD (FromThenR Exp
x Exp
y)     = do { GenLocated SrcSpanAnnA (HsExpr GhcPs)
x' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
x; GenLocated SrcSpanAnnA (HsExpr GhcPs)
y' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
y; 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 GenLocated SrcSpanAnnA (HsExpr GhcPs)
LHsExpr GhcPs
x' GenLocated SrcSpanAnnA (HsExpr GhcPs)
LHsExpr GhcPs
y' }
cvtDD (FromToR Exp
x Exp
y)       = do { GenLocated SrcSpanAnnA (HsExpr GhcPs)
x' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
x; GenLocated SrcSpanAnnA (HsExpr GhcPs)
y' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
y; 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 GenLocated SrcSpanAnnA (HsExpr GhcPs)
LHsExpr GhcPs
x' GenLocated SrcSpanAnnA (HsExpr GhcPs)
LHsExpr GhcPs
y' }
cvtDD (FromThenToR Exp
x Exp
y Exp
z) = do { GenLocated SrcSpanAnnA (HsExpr GhcPs)
x' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
x; GenLocated SrcSpanAnnA (HsExpr GhcPs)
y' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
y; GenLocated SrcSpanAnnA (HsExpr GhcPs)
z' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
z; 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 GenLocated SrcSpanAnnA (HsExpr GhcPs)
LHsExpr GhcPs
x' GenLocated SrcSpanAnnA (HsExpr GhcPs)
LHsExpr GhcPs
y' GenLocated SrcSpanAnnA (HsExpr GhcPs)
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 (EpAnn EpaLocation -> HsTupArg GhcPs
missingTupArg EpAnn EpaLocation
forall a. EpAnn a
noAnn)
                             cvtl_maybe (Just Exp
e) = (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> HsTupArg GhcPs)
-> CvtM (GenLocated SrcSpanAnnA (HsExpr 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 XPresent GhcPs
forall a. EpAnn a
noAnn) (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 -> [HsTupArg GhcPs] -> Boxity -> HsExpr GhcPs
forall p. XExplicitTuple p -> [HsTupArg p] -> Boxity -> HsExpr p
ExplicitTuple
                                    XExplicitTuple GhcPs
forall a. EpAnn a
noAnn
                                    [HsTupArg GhcPs]
es'
                                    Boxity
boxity }

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


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

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

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

Sample input:

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

Sample output:

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

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

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

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

When we call @cvtOpApp@ from @cvtl@, the first argument will always be left-biased
since we have already run @cvtl@ on it.
-}
cvtOpApp :: LHsExpr GhcPs -> TH.Exp -> TH.Exp -> CvtM (HsExpr GhcPs)
cvtOpApp :: LHsExpr GhcPs -> Exp -> Exp -> CvtM (HsExpr GhcPs)
cvtOpApp LHsExpr GhcPs
x Exp
op1 (UInfixE Exp
y Exp
op2 Exp
z)
  = do { GenLocated SrcSpanAnnA (HsExpr GhcPs)
l <- CvtM (HsExpr GhcPs) -> CvtM (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. CvtM a -> CvtM (LocatedA a)
wrapLA (CvtM (HsExpr GhcPs)
 -> CvtM (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> CvtM (HsExpr GhcPs)
-> CvtM (GenLocated SrcSpanAnnA (HsExpr 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 GenLocated SrcSpanAnnA (HsExpr GhcPs)
LHsExpr GhcPs
l Exp
op2 Exp
z }
cvtOpApp LHsExpr GhcPs
x Exp
op Exp
y
  = do { GenLocated SrcSpanAnnA (HsExpr GhcPs)
op' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
op
       ; GenLocated SrcSpanAnnA (HsExpr GhcPs)
y' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
y
       ; HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (XOpApp GhcPs
-> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp XOpApp GhcPs
forall a. EpAnn a
noAnn LHsExpr GhcPs
x GenLocated SrcSpanAnnA (HsExpr GhcPs)
LHsExpr GhcPs
op' GenLocated SrcSpanAnnA (HsExpr GhcPs)
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 = SDoc -> CvtM (HsExpr GhcPs)
forall a. SDoc -> CvtM a
failWith (String -> SDoc
text String
"Empty stmt list in do-block")
  | Bool
otherwise
  = do  { [GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
stmts' <- [Stmt] -> CvtM [LStmt GhcPs (LHsExpr GhcPs)]
cvtStmts [Stmt]
stmts
        ; let Just ([GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
stmts'', GenLocated
  SrcSpanAnnA
  (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
last') = [GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> Maybe
     ([GenLocated
         SrcSpanAnnA
         (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))],
      GenLocated
        SrcSpanAnnA
        (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
forall a. [a] -> Maybe ([a], a)
snocView [GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
stmts'

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

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

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

cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt GhcPs (LHsExpr GhcPs))
cvtStmt :: Stmt -> CvtM (LStmt GhcPs (LHsExpr GhcPs))
cvtStmt (NoBindS Exp
e)    = do { GenLocated SrcSpanAnnA (HsExpr GhcPs)
e' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
e; StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> CvtM
     (GenLocated
        SrcSpanAnnA
        (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
forall e ann. e -> CvtM (GenLocated (SrcSpanAnn' (EpAnn ann)) e)
returnLA (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> CvtM
      (GenLocated
         SrcSpanAnnA
         (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))))
-> StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> CvtM
     (GenLocated
        SrcSpanAnnA
        (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall (bodyR :: * -> *) (idL :: Pass).
LocatedA (bodyR GhcPs)
-> StmtLR (GhcPass idL) GhcPs (LocatedA (bodyR GhcPs))
mkBodyStmt GenLocated SrcSpanAnnA (HsExpr GhcPs)
e' }
cvtStmt (TH.BindS Pat
p Exp
e) = do { GenLocated SrcSpanAnnA (Pat GhcPs)
p' <- Pat -> CvtM (LPat GhcPs)
cvtPat Pat
p; GenLocated SrcSpanAnnA (HsExpr GhcPs)
e' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
e; StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> CvtM
     (GenLocated
        SrcSpanAnnA
        (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
forall e ann. e -> CvtM (GenLocated (SrcSpanAnn' (EpAnn ann)) e)
returnLA (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> CvtM
      (GenLocated
         SrcSpanAnnA
         (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))))
-> StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> CvtM
     (GenLocated
        SrcSpanAnnA
        (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
forall a b. (a -> b) -> a -> b
$ EpAnn [AddEpAnn]
-> LPat GhcPs
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall (bodyR :: * -> *).
EpAnn [AddEpAnn]
-> LPat GhcPs
-> LocatedA (bodyR GhcPs)
-> StmtLR GhcPs GhcPs (LocatedA (bodyR GhcPs))
mkPsBindStmt EpAnn [AddEpAnn]
forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (Pat GhcPs)
LPat GhcPs
p' GenLocated SrcSpanAnnA (HsExpr GhcPs)
e' }
cvtStmt (TH.LetS [Dec]
ds)   = do { HsLocalBinds GhcPs
ds' <- SDoc -> [Dec] -> CvtM (HsLocalBinds GhcPs)
cvtLocalDecs (String -> SDoc
text String
"a let binding") [Dec]
ds
                            ; StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> CvtM
     (GenLocated
        SrcSpanAnnA
        (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
forall e ann. e -> CvtM (GenLocated (SrcSpanAnn' (EpAnn ann)) e)
returnLA (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> CvtM
      (GenLocated
         SrcSpanAnnA
         (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))))
-> StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> CvtM
     (GenLocated
        SrcSpanAnnA
        (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
forall a b. (a -> b) -> a -> b
$ XLetStmt GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> HsLocalBinds GhcPs
-> StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall idL idR body.
XLetStmt idL idR body
-> HsLocalBindsLR idL idR -> StmtLR idL idR body
LetStmt XLetStmt GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. EpAnn a
noAnn 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 {idR} {p :: Pass}.
(XParStmtBlock GhcPs idR ~ NoExtField,
 SyntaxExprGhc p ~ SyntaxExpr idR, IsPass p) =>
[Stmt] -> CvtM (ParStmtBlock GhcPs idR)
cvt_one [[Stmt]]
dss
                            ; StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> CvtM
     (GenLocated
        SrcSpanAnnA
        (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
forall e ann. e -> CvtM (GenLocated (SrcSpanAnn' (EpAnn ann)) e)
returnLA (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> CvtM
      (GenLocated
         SrcSpanAnnA
         (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))))
-> StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> CvtM
     (GenLocated
        SrcSpanAnnA
        (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
forall a b. (a -> b) -> a -> b
$ XParStmt GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> [ParStmtBlock GhcPs GhcPs]
-> HsExpr GhcPs
-> SyntaxExpr GhcPs
-> StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr 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 (GenLocated SrcSpanAnnA (HsExpr 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 { [GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr 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 [GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
[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 { [GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
ss' <- (Stmt
 -> CvtM
      (GenLocated
         SrcSpanAnnA
         (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))))
-> [Stmt]
-> CvtM
     [GenLocated
        SrcSpanAnnA
        (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Stmt
-> CvtM
     (GenLocated
        SrcSpanAnnA
        (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
Stmt -> CvtM (LStmt GhcPs (LHsExpr GhcPs))
cvtStmt [Stmt]
ss; StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> CvtM
     (GenLocated
        SrcSpanAnnA
        (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
forall e ann. e -> CvtM (GenLocated (SrcSpanAnn' (EpAnn ann)) e)
returnLA (EpAnn AnnList
-> LocatedL
     [LStmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
-> StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall (idL :: Pass) bodyR.
(Anno
   [GenLocated
      (Anno (StmtLR (GhcPass idL) GhcPs bodyR))
      (StmtLR (GhcPass idL) GhcPs bodyR)]
 ~ SrcSpanAnnL) =>
EpAnn AnnList
-> LocatedL [LStmtLR (GhcPass idL) GhcPs bodyR]
-> StmtLR (GhcPass idL) GhcPs bodyR
mkRecStmt EpAnn AnnList
forall a. EpAnn a
noAnn ([GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> LocatedAn
     AnnList
     [GenLocated
        SrcSpanAnnA
        (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall a an. a -> LocatedAn an a
noLocA [GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
ss')) }

cvtMatch :: HsMatchContext GhcPs
         -> TH.Match -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))
cvtMatch :: HsMatchContext GhcPs
-> Match -> CvtM (LMatch GhcPs (LHsExpr GhcPs))
cvtMatch HsMatchContext GhcPs
ctxt (TH.Match Pat
p Body
body [Dec]
decs)
  = do  { GenLocated SrcSpanAnnA (Pat GhcPs)
p' <- Pat -> CvtM (LPat GhcPs)
cvtPat Pat
p
        ; let lp :: GenLocated SrcSpanAnnA (Pat GhcPs)
lp = case GenLocated SrcSpanAnnA (Pat GhcPs)
p' of
                     (L SrcSpanAnnA
loc SigPat{}) -> SrcSpanAnnA -> Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (XParPat GhcPs -> LPat GhcPs -> Pat GhcPs
forall p. XParPat p -> LPat p -> Pat p
ParPat XParPat GhcPs
forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (Pat GhcPs)
LPat GhcPs
p') -- #14875
                     GenLocated SrcSpanAnnA (Pat GhcPs)
_                -> GenLocated SrcSpanAnnA (Pat GhcPs)
p'
        ; [GenLocated
   SrcSpan (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
g' <- Body -> CvtM [LGRHS GhcPs (LHsExpr GhcPs)]
cvtGuard Body
body
        ; HsLocalBinds GhcPs
decs' <- SDoc -> [Dec] -> CvtM (HsLocalBinds GhcPs)
cvtLocalDecs (String -> SDoc
text String
"a where clause") [Dec]
decs
        ; Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> CvtM
     (GenLocated
        SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
forall e ann. e -> CvtM (GenLocated (SrcSpanAnn' (EpAnn ann)) e)
returnLA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> CvtM
      (GenLocated
         SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))))
-> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> CvtM
     (GenLocated
        SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
forall a b. (a -> b) -> a -> b
$ XCMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> HsMatchContext (NoGhcTc GhcPs)
-> [LPat GhcPs]
-> GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall p body.
XCMatch p body
-> HsMatchContext (NoGhcTc p)
-> [LPat p]
-> GRHSs p body
-> Match p body
Hs.Match XCMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. EpAnn a
noAnn HsMatchContext (NoGhcTc GhcPs)
HsMatchContext GhcPs
ctxt [GenLocated SrcSpanAnnA (Pat GhcPs)
LPat GhcPs
lp] (XCGRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> [LGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
-> HsLocalBinds GhcPs
-> GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall p body.
XCGRHSs p body -> [LGRHS p body] -> HsLocalBinds p -> GRHSs p body
GRHSs EpAnnComments
XCGRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
emptyComments [GenLocated
   SrcSpan (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
[LGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
g' HsLocalBinds GhcPs
decs') }

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

cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS GhcPs (LHsExpr GhcPs))
cvtpair :: (Guard, Exp) -> CvtM (LGRHS GhcPs (LHsExpr GhcPs))
cvtpair (NormalG Exp
ge,Exp
rhs) = do { GenLocated SrcSpanAnnA (HsExpr GhcPs)
ge' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
ge; GenLocated SrcSpanAnnA (HsExpr GhcPs)
rhs' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
rhs
                              ; GenLocated
  SrcSpanAnnA
  (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
g' <- StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> CvtM
     (GenLocated
        SrcSpanAnnA
        (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
forall e ann. e -> CvtM (GenLocated (SrcSpanAnn' (EpAnn ann)) e)
returnLA (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> CvtM
      (GenLocated
         SrcSpanAnnA
         (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))))
-> StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> CvtM
     (GenLocated
        SrcSpanAnnA
        (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall (bodyR :: * -> *) (idL :: Pass).
LocatedA (bodyR GhcPs)
-> StmtLR (GhcPass idL) GhcPs (LocatedA (bodyR GhcPs))
mkBodyStmt GenLocated SrcSpanAnnA (HsExpr GhcPs)
ge'
                              ; GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> CvtM
     (GenLocated
        SrcSpan (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
forall a. a -> CvtM (Located a)
returnL (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> CvtM
      (GenLocated
         SrcSpan (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))))
-> GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> CvtM
     (GenLocated
        SrcSpan (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
forall a b. (a -> b) -> a -> b
$ XCGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> [LStmt GhcPs (LHsExpr GhcPs)]
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall p body.
XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body
GRHS XCGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. EpAnn a
noAnn [GenLocated
  SrcSpanAnnA
  (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
LStmt GhcPs (LHsExpr GhcPs)
g'] GenLocated SrcSpanAnnA (HsExpr GhcPs)
rhs' }
cvtpair (PatG [Stmt]
gs,Exp
rhs)    = do { [GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
gs' <- [Stmt] -> CvtM [LStmt GhcPs (LHsExpr GhcPs)]
cvtStmts [Stmt]
gs; GenLocated SrcSpanAnnA (HsExpr GhcPs)
rhs' <- Exp -> CvtM (LHsExpr GhcPs)
cvtl Exp
rhs
                              ; GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> CvtM
     (GenLocated
        SrcSpan (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
forall a. a -> CvtM (Located a)
returnL (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> CvtM
      (GenLocated
         SrcSpan (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))))
-> GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> CvtM
     (GenLocated
        SrcSpan (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
forall a b. (a -> b) -> a -> b
$ XCGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> [LStmt GhcPs (LHsExpr GhcPs)]
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall p body.
XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body
GRHS XCGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. EpAnn a
noAnn [GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
[LStmt GhcPs (LHsExpr GhcPs)]
gs' GenLocated SrcSpanAnnA (HsExpr 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
mkTHFractionalLit 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
mkTHFractionalLit 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
mkTHFractionalLit 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 -> SourceText
quotedSourceText :: String -> SourceText
quotedSourceText String
s = String -> SourceText
SourceText (String -> SourceText) -> String -> SourceText
forall a b. (a -> b) -> a -> b
$ String
"\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\""

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

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

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

cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField GhcPs (LPat GhcPs))
cvtPatFld :: FieldPat -> CvtM (LHsRecField GhcPs (LPat GhcPs))
cvtPatFld (Name
s,Pat
p)
  = do  { L SrcSpanAnnN
ls RdrName
s' <- Name -> CvtM (LocatedN RdrName)
vNameN Name
s
        ; GenLocated SrcSpanAnnA (Pat GhcPs)
p' <- Pat -> CvtM (LPat GhcPs)
cvtPat Pat
p
        ; GenLocated
  SrcSpanAnnA
  (HsRecField' (FieldOcc GhcPs) (GenLocated SrcSpanAnnA (Pat GhcPs)))
-> CvtM
     (GenLocated
        SrcSpanAnnA
        (HsRecField'
           (FieldOcc GhcPs) (GenLocated SrcSpanAnnA (Pat GhcPs))))
forall (m :: * -> *) a. Monad m => a -> m a
return (HsRecField' (FieldOcc GhcPs) (GenLocated SrcSpanAnnA (Pat GhcPs))
-> GenLocated
     SrcSpanAnnA
     (HsRecField' (FieldOcc GhcPs) (GenLocated SrcSpanAnnA (Pat GhcPs)))
forall a an. a -> LocatedAn an a
noLocA (HsRecField' (FieldOcc GhcPs) (GenLocated SrcSpanAnnA (Pat GhcPs))
 -> GenLocated
      SrcSpanAnnA
      (HsRecField'
         (FieldOcc GhcPs) (GenLocated SrcSpanAnnA (Pat GhcPs))))
-> HsRecField'
     (FieldOcc GhcPs) (GenLocated SrcSpanAnnA (Pat GhcPs))
-> GenLocated
     SrcSpanAnnA
     (HsRecField' (FieldOcc GhcPs) (GenLocated SrcSpanAnnA (Pat GhcPs)))
forall a b. (a -> b) -> a -> b
$ HsRecField { hsRecFieldAnn :: XHsRecField (FieldOcc GhcPs)
hsRecFieldAnn = XHsRecField (FieldOcc GhcPs)
forall a. EpAnn a
noAnn
                                      , hsRecFieldLbl :: GenLocated SrcSpan (FieldOcc GhcPs)
hsRecFieldLbl
                                         = SrcSpan -> FieldOcc GhcPs -> GenLocated SrcSpan (FieldOcc GhcPs)
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnN -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnN
ls) (FieldOcc GhcPs -> GenLocated SrcSpan (FieldOcc GhcPs))
-> FieldOcc GhcPs -> GenLocated SrcSpan (FieldOcc GhcPs)
forall a b. (a -> b) -> a -> b
$ LocatedN RdrName -> FieldOcc GhcPs
mkFieldOcc (SrcSpanAnnN -> RdrName -> LocatedN RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
ls RdrName
s')
                                      , hsRecFieldArg :: GenLocated SrcSpanAnnA (Pat GhcPs)
hsRecFieldArg = GenLocated SrcSpanAnnA (Pat GhcPs)
p'
                                      , hsRecPun :: Bool
hsRecPun      = Bool
False}) }

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

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

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

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

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

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

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

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

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

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

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

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

cvtDerivClause :: TH.DerivClause
               -> CvtM (LHsDerivingClause GhcPs)
cvtDerivClause :: DerivClause -> CvtM (LHsDerivingClause GhcPs)
cvtDerivClause (TH.DerivClause Maybe DerivStrategy
ds Cxt
tys)
  = do { GenLocated SrcSpanAnnC (DerivClauseTys GhcPs)
tys' <- Cxt -> CvtM (LDerivClauseTys GhcPs)
cvtDerivClauseTys Cxt
tys
       ; Maybe (GenLocated SrcSpan (DerivStrategy GhcPs))
ds'  <- (DerivStrategy -> CvtM (GenLocated SrcSpan (DerivStrategy GhcPs)))
-> Maybe DerivStrategy
-> CvtM (Maybe (GenLocated SrcSpan (DerivStrategy GhcPs)))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse DerivStrategy -> CvtM (GenLocated SrcSpan (DerivStrategy GhcPs))
DerivStrategy -> CvtM (LDerivStrategy GhcPs)
cvtDerivStrategy Maybe DerivStrategy
ds
       ; HsDerivingClause GhcPs
-> CvtM (GenLocated SrcSpan (HsDerivingClause GhcPs))
forall a. a -> CvtM (Located a)
returnL (HsDerivingClause GhcPs
 -> CvtM (GenLocated SrcSpan (HsDerivingClause GhcPs)))
-> HsDerivingClause GhcPs
-> CvtM (GenLocated SrcSpan (HsDerivingClause GhcPs))
forall a b. (a -> b) -> a -> b
$ XCHsDerivingClause GhcPs
-> Maybe (LDerivStrategy GhcPs)
-> LDerivClauseTys GhcPs
-> HsDerivingClause GhcPs
forall pass.
XCHsDerivingClause pass
-> Maybe (LDerivStrategy pass)
-> LDerivClauseTys pass
-> HsDerivingClause pass
HsDerivingClause XCHsDerivingClause GhcPs
forall a. EpAnn a
noAnn Maybe (GenLocated SrcSpan (DerivStrategy GhcPs))
Maybe (LDerivStrategy GhcPs)
ds' GenLocated SrcSpanAnnC (DerivClauseTys GhcPs)
LDerivClauseTys GhcPs
tys' }

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

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

cvtSigType :: TH.Type -> CvtM (LHsSigType GhcPs)
cvtSigType :: Type -> CvtM (LHsSigType GhcPs)
cvtSigType = String -> Type -> CvtM (LHsSigType GhcPs)
cvtSigTypeKind String
"type"

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

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

       ; case Type
head_ty of
           TupleT Int
n
            | Just [GenLocated SrcSpanAnnA (HsType GhcPs)]
normals <- Maybe [GenLocated SrcSpanAnnA (HsType GhcPs)]
m_normals
            , [GenLocated SrcSpanAnnA (HsType GhcPs)]
normals [GenLocated SrcSpanAnnA (HsType GhcPs)] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthIs` Int
n         -- Saturated
            -> HsType GhcPs -> CvtM (GenLocated SrcSpanAnnA (HsType GhcPs))
forall e ann. e -> CvtM (GenLocated (SrcSpanAnn' (EpAnn ann)) e)
returnLA (XTupleTy GhcPs -> HsTupleSort -> [LHsType GhcPs] -> HsType GhcPs
forall pass.
XTupleTy pass -> HsTupleSort -> [LHsType pass] -> HsType pass
HsTupleTy XTupleTy GhcPs
forall a. EpAnn a
noAnn HsTupleSort
HsBoxedOrConstraintTuple [GenLocated SrcSpanAnnA (HsType GhcPs)]
[LHsType GhcPs]
normals)
            | Bool
otherwise
            -> HsType GhcPs -> HsTyPats GhcPs -> CvtM (LHsType GhcPs)
mk_apps
               (XTyVar GhcPs
-> PromotionFlag -> XRec GhcPs (IdP GhcPs) -> HsType GhcPs
forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar XTyVar GhcPs
forall a. EpAnn a
noAnn PromotionFlag
NotPromoted
                                     (RdrName -> LocatedN RdrName
forall a an. a -> LocatedAn an a
noLocA (TyCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName (Boxity -> Int -> TyCon
tupleTyCon Boxity
Boxed Int
n))))
               [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
HsTyPats GhcPs
tys'
           UnboxedTupleT Int
n
             | Just [GenLocated SrcSpanAnnA (HsType GhcPs)]
normals <- Maybe [GenLocated SrcSpanAnnA (HsType GhcPs)]
m_normals
             , [GenLocated SrcSpanAnnA (HsType GhcPs)]
normals [GenLocated SrcSpanAnnA (HsType GhcPs)] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthIs` Int
n               -- Saturated
             -> HsType GhcPs -> CvtM (GenLocated SrcSpanAnnA (HsType GhcPs))
forall e ann. e -> CvtM (GenLocated (SrcSpanAnn' (EpAnn ann)) e)
returnLA (XTupleTy GhcPs -> HsTupleSort -> [LHsType GhcPs] -> HsType GhcPs
forall pass.
XTupleTy pass -> HsTupleSort -> [LHsType pass] -> HsType pass
HsTupleTy XTupleTy GhcPs
forall a. EpAnn a
noAnn HsTupleSort
HsUnboxedTuple [GenLocated SrcSpanAnnA (HsType GhcPs)]
[LHsType GhcPs]
normals)
             | Bool
otherwise
             -> HsType GhcPs -> HsTyPats GhcPs -> CvtM (LHsType GhcPs)
mk_apps
                (XTyVar GhcPs
-> PromotionFlag -> XRec GhcPs (IdP GhcPs) -> HsType GhcPs
forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar XTyVar GhcPs
forall a. EpAnn a
noAnn PromotionFlag
NotPromoted
                                   (RdrName -> LocatedN RdrName
forall a an. a -> LocatedAn an a
noLocA (TyCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName (Boxity -> Int -> TyCon
tupleTyCon Boxity
Unboxed Int
n))))
                [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
HsTyPats GhcPs
tys'
           UnboxedSumT Int
n
             | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2
            -> SDoc -> CvtM (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a. SDoc -> CvtM a
failWith (SDoc -> CvtM (GenLocated SrcSpanAnnA (HsType GhcPs)))
-> SDoc -> CvtM (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a b. (a -> b) -> a -> b
$
                   [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Illegal sum arity:" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text (Int -> String
forall a. Show a => a -> String
show Int
n)
                        , Int -> SDoc -> SDoc
nest Int
2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
                            String -> SDoc
text String
"Sums must have an arity of at least 2" ]
             | Just [GenLocated SrcSpanAnnA (HsType GhcPs)]
normals <- Maybe [GenLocated SrcSpanAnnA (HsType GhcPs)]
m_normals
             , [GenLocated SrcSpanAnnA (HsType GhcPs)]
normals [GenLocated SrcSpanAnnA (HsType GhcPs)] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthIs` Int
n -- Saturated
             -> HsType GhcPs -> CvtM (GenLocated SrcSpanAnnA (HsType GhcPs))
forall e ann. e -> CvtM (GenLocated (SrcSpanAnn' (EpAnn ann)) e)
returnLA (XSumTy GhcPs -> [LHsType GhcPs] -> HsType GhcPs
forall pass. XSumTy pass -> [LHsType pass] -> HsType pass
HsSumTy XSumTy GhcPs
forall a. EpAnn a
noAnn [GenLocated SrcSpanAnnA (HsType GhcPs)]
[LHsType GhcPs]
normals)
             | Bool
otherwise
             -> HsType GhcPs -> HsTyPats GhcPs -> CvtM (LHsType GhcPs)
mk_apps
                (XTyVar GhcPs
-> PromotionFlag -> XRec GhcPs (IdP GhcPs) -> HsType GhcPs
forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar XTyVar GhcPs
forall a. EpAnn a
noAnn PromotionFlag
NotPromoted (RdrName -> LocatedN RdrName
forall a an. a -> LocatedAn an a
noLocA (TyCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName (Int -> TyCon
sumTyCon Int
n))))
                [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
HsTyPats GhcPs
tys'
           Type
ArrowT
             | Just [GenLocated SrcSpanAnnA (HsType GhcPs)]
normals <- Maybe [GenLocated SrcSpanAnnA (HsType GhcPs)]
m_normals
             , [GenLocated SrcSpanAnnA (HsType GhcPs)
x',GenLocated SrcSpanAnnA (HsType GhcPs)
y'] <- [GenLocated SrcSpanAnnA (HsType GhcPs)]
normals -> do
                 GenLocated SrcSpanAnnA (HsType GhcPs)
x'' <- case GenLocated SrcSpanAnnA (HsType GhcPs) -> HsType GhcPs
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (HsType GhcPs)
x' of
                          HsFunTy{}    -> HsType GhcPs -> CvtM (GenLocated SrcSpanAnnA (HsType GhcPs))
forall e ann. e -> CvtM (GenLocated (SrcSpanAnn' (EpAnn ann)) e)
returnLA (XParTy GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy XParTy GhcPs
forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (HsType GhcPs)
LHsType GhcPs
x')
                          HsForAllTy{} -> HsType GhcPs -> CvtM (GenLocated SrcSpanAnnA (HsType GhcPs))
forall e ann. e -> CvtM (GenLocated (SrcSpanAnn' (EpAnn ann)) e)
returnLA (XParTy GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy XParTy GhcPs
forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (HsType GhcPs)
LHsType GhcPs
x') -- #14646
                          HsQualTy{}   -> HsType GhcPs -> CvtM (GenLocated SrcSpanAnnA (HsType GhcPs))
forall e ann. e -> CvtM (GenLocated (SrcSpanAnn' (EpAnn ann)) e)
returnLA (XParTy GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy XParTy GhcPs
forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (HsType GhcPs)
LHsType GhcPs
x') -- #15324
                          HsType GhcPs
_            -> GenLocated SrcSpanAnnA (HsType GhcPs)
-> CvtM (GenLocated SrcSpanAnnA (HsType GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsType GhcPs)
 -> CvtM (GenLocated SrcSpanAnnA (HsType GhcPs)))
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> CvtM (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a b. (a -> b) -> a -> b
$
                                          PprPrec -> LHsType GhcPs -> LHsType GhcPs
forall (p :: Pass).
PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)
parenthesizeHsType PprPrec
sigPrec GenLocated SrcSpanAnnA (HsType GhcPs)
LHsType GhcPs
x'
                 let y'' :: LHsType GhcPs
y'' = PprPrec -> LHsType GhcPs -> LHsType GhcPs
forall (p :: Pass).
PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)
parenthesizeHsType PprPrec
sigPrec GenLocated SrcSpanAnnA (HsType GhcPs)
LHsType GhcPs
y'
                 HsType GhcPs -> CvtM (GenLocated SrcSpanAnnA (HsType GhcPs))
forall e ann. e -> CvtM (GenLocated (SrcSpanAnn' (EpAnn ann)) e)
returnLA (XFunTy GhcPs
-> HsArrow GhcPs -> LHsType GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass.
XFunTy pass
-> HsArrow pass -> LHsType pass -> LHsType pass -> HsType pass
HsFunTy XFunTy GhcPs
forall a. EpAnn a
noAnn (IsUnicodeSyntax -> HsArrow GhcPs
forall pass. IsUnicodeSyntax -> HsArrow pass
HsUnrestrictedArrow IsUnicodeSyntax
NormalSyntax) GenLocated SrcSpanAnnA (HsType GhcPs)
LHsType GhcPs
x'' LHsType GhcPs
y'')
             | Bool
otherwise
             -> HsType GhcPs -> HsTyPats GhcPs -> CvtM (LHsType GhcPs)
mk_apps
                (XTyVar GhcPs
-> PromotionFlag -> XRec GhcPs (IdP GhcPs) -> HsType GhcPs
forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar XTyVar GhcPs
forall a. EpAnn a
noAnn PromotionFlag
NotPromoted (RdrName -> LocatedN RdrName
forall a an. a -> LocatedAn an a
noLocA (TyCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName TyCon
unrestrictedFunTyCon)))
                [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
HsTyPats GhcPs
tys'
           Type
MulArrowT
             | Just [GenLocated SrcSpanAnnA (HsType GhcPs)]
normals <- Maybe [GenLocated SrcSpanAnnA (HsType GhcPs)]
m_normals
             , [GenLocated SrcSpanAnnA (HsType GhcPs)
w',GenLocated SrcSpanAnnA (HsType GhcPs)
x',GenLocated SrcSpanAnnA (HsType GhcPs)
y'] <- [GenLocated SrcSpanAnnA (HsType GhcPs)]
normals -> do
                 GenLocated SrcSpanAnnA (HsType GhcPs)
x'' <- case GenLocated SrcSpanAnnA (HsType GhcPs) -> HsType GhcPs
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (HsType GhcPs)
x' of
                          HsFunTy{}    -> HsType GhcPs -> CvtM (GenLocated SrcSpanAnnA (HsType GhcPs))
forall e ann. e -> CvtM (GenLocated (SrcSpanAnn' (EpAnn ann)) e)
returnLA (XParTy GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy XParTy GhcPs
forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (HsType GhcPs)
LHsType GhcPs
x')
                          HsForAllTy{} -> HsType GhcPs -> CvtM (GenLocated SrcSpanAnnA (HsType GhcPs))
forall e ann. e -> CvtM (GenLocated (SrcSpanAnn' (EpAnn ann)) e)
returnLA (XParTy GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy XParTy GhcPs
forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (HsType GhcPs)
LHsType GhcPs
x') -- #14646
                          HsQualTy{}   -> HsType GhcPs -> CvtM (GenLocated SrcSpanAnnA (HsType GhcPs))
forall e ann. e -> CvtM (GenLocated (SrcSpanAnn' (EpAnn ann)) e)
returnLA (XParTy GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy XParTy GhcPs
forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (HsType GhcPs)
LHsType GhcPs
x') -- #15324
                          HsType GhcPs
_            -> GenLocated SrcSpanAnnA (HsType GhcPs)
-> CvtM (GenLocated SrcSpanAnnA (HsType GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsType GhcPs)
 -> CvtM (GenLocated SrcSpanAnnA (HsType GhcPs)))
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> CvtM (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a b. (a -> b) -> a -> b
$
                                          PprPrec -> LHsType GhcPs -> LHsType GhcPs
forall (p :: Pass).
PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)
parenthesizeHsType PprPrec
sigPrec GenLocated SrcSpanAnnA (HsType GhcPs)
LHsType GhcPs
x'
                 let y'' :: LHsType GhcPs
y'' = PprPrec -> LHsType GhcPs -> LHsType GhcPs
forall (p :: Pass).
PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)
parenthesizeHsType PprPrec
sigPrec GenLocated SrcSpanAnnA (HsType GhcPs)
LHsType GhcPs
y'
                     w'' :: HsArrow GhcPs
w'' = LHsType GhcPs -> HsArrow GhcPs
hsTypeToArrow GenLocated SrcSpanAnnA (HsType GhcPs)
LHsType GhcPs
w'
                 HsType GhcPs -> CvtM (GenLocated SrcSpanAnnA (HsType GhcPs))
forall e ann. e -> CvtM (GenLocated (SrcSpanAnn' (EpAnn ann)) e)
returnLA (XFunTy GhcPs
-> HsArrow GhcPs -> LHsType GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass.
XFunTy pass
-> HsArrow pass -> LHsType pass -> LHsType pass -> HsType pass
HsFunTy XFunTy GhcPs
forall a. EpAnn a
noAnn HsArrow GhcPs
w'' GenLocated SrcSpanAnnA (HsType GhcPs)
LHsType GhcPs
x'' LHsType GhcPs
y'')
             | Bool
otherwise
             -> HsType GhcPs -> HsTyPats GhcPs -> CvtM (LHsType GhcPs)
mk_apps
                (XTyVar GhcPs
-> PromotionFlag -> XRec GhcPs (IdP GhcPs) -> HsType GhcPs
forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar XTyVar GhcPs
forall a. EpAnn a
noAnn PromotionFlag
NotPromoted (RdrName -> LocatedN RdrName
forall a an. a -> LocatedAn an a
noLocA (TyCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName TyCon
funTyCon)))
                [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
HsTyPats GhcPs
tys'
           Type
ListT
             | Just [GenLocated SrcSpanAnnA (HsType GhcPs)]
normals <- Maybe [GenLocated SrcSpanAnnA (HsType GhcPs)]
m_normals
             , [GenLocated SrcSpanAnnA (HsType GhcPs)
x'] <- [GenLocated SrcSpanAnnA (HsType GhcPs)]
normals ->
                HsType GhcPs -> CvtM (GenLocated SrcSpanAnnA (HsType GhcPs))
forall e ann. e -> CvtM (GenLocated (SrcSpanAnn' (EpAnn ann)) e)
returnLA (XListTy GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass. XListTy pass -> LHsType pass -> HsType pass
HsListTy XListTy GhcPs
forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (HsType GhcPs)
LHsType GhcPs
x')
             | Bool
otherwise
             -> HsType GhcPs -> HsTyPats GhcPs -> CvtM (LHsType GhcPs)
mk_apps
                (XTyVar GhcPs
-> PromotionFlag -> XRec GhcPs (IdP GhcPs) -> HsType GhcPs
forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar XTyVar GhcPs
forall a. EpAnn a
noAnn PromotionFlag
NotPromoted (RdrName -> LocatedN RdrName
forall a an. a -> LocatedAn an a
noLocA (TyCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName TyCon
listTyCon)))
                [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
HsTyPats GhcPs
tys'

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

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

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

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

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

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

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

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

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

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

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

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

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

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

           Type
StarT
             -> HsType GhcPs -> HsTyPats GhcPs -> CvtM (LHsType GhcPs)
mk_apps
                (XTyVar GhcPs
-> PromotionFlag -> XRec GhcPs (IdP GhcPs) -> HsType GhcPs
forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar XTyVar GhcPs
forall a. EpAnn a
noAnn PromotionFlag
NotPromoted
                                      (RdrName -> LocatedN RdrName
forall a an. a -> LocatedAn an a
noLocA (TyCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName TyCon
liftedTypeKindTyCon)))
                [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
HsTyPats GhcPs
tys'

           Type
ConstraintT
             -> HsType GhcPs -> HsTyPats GhcPs -> CvtM (LHsType GhcPs)
mk_apps
                (XTyVar GhcPs
-> PromotionFlag -> XRec GhcPs (IdP GhcPs) -> HsType GhcPs
forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar XTyVar GhcPs
forall a. EpAnn a
noAnn PromotionFlag
NotPromoted
                                      (RdrName -> LocatedN RdrName
forall a an. a -> LocatedAn an a
noLocA (TyCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName TyCon
constraintKindTyCon)))
                [HsArg
   (GenLocated SrcSpanAnnA (HsType GhcPs))
   (GenLocated SrcSpanAnnA (HsType GhcPs))]
HsTyPats GhcPs
tys'

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

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

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

hsTypeToArrow :: LHsType GhcPs -> HsArrow GhcPs
hsTypeToArrow :: LHsType GhcPs -> HsArrow GhcPs
hsTypeToArrow LHsType GhcPs
w = case GenLocated SrcSpanAnnA (HsType GhcPs) -> HsType GhcPs
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (HsType GhcPs)
LHsType GhcPs
w of
                     HsTyVar XTyVar GhcPs
_ PromotionFlag
_ (L SrcSpanAnnN
_ (RdrName -> Maybe Name
isExact_maybe -> Just Name
n))
                        | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
oneDataConName -> IsUnicodeSyntax -> Maybe AddEpAnn -> HsArrow GhcPs
forall pass. IsUnicodeSyntax -> Maybe AddEpAnn -> HsArrow pass
HsLinearArrow IsUnicodeSyntax
NormalSyntax Maybe AddEpAnn
forall a. Maybe a
Nothing
                        | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
manyDataConName -> IsUnicodeSyntax -> HsArrow GhcPs
forall pass. IsUnicodeSyntax -> HsArrow pass
HsUnrestrictedArrow IsUnicodeSyntax
NormalSyntax
                     HsType GhcPs
_ -> IsUnicodeSyntax -> Maybe AddEpAnn -> LHsType GhcPs -> HsArrow GhcPs
forall pass.
IsUnicodeSyntax -> Maybe AddEpAnn -> LHsType pass -> HsArrow pass
HsExplicitMult IsUnicodeSyntax
NormalSyntax Maybe AddEpAnn
forall a. Maybe a
Nothing LHsType GhcPs
w

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

cvtSigKind :: TH.Kind -> CvtM (LHsSigType GhcPs)
cvtSigKind :: Type -> CvtM (LHsSigType GhcPs)
cvtSigKind = String -> Type -> CvtM (LHsSigType GhcPs)
cvtSigTypeKind String
"kind"

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

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

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

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

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

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


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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

In general, the type signature of a pattern synonym

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

is of the form

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

with the following parts:

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

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

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

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

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

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

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

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

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

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

-}