{-# LANGUAGE ConstrainedClassMethods #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
module GHC.ThToHs
( convertToHsExpr
, convertToPat
, convertToHsDecls
, convertToHsType
, thRdrNameGuesses
)
where
import GHC.Prelude hiding (init, last, tail)
import GHC.Hs as Hs
import GHC.Tc.Errors.Types
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.Builtin.Types.Prim( fUNTyCon )
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.Lexeme
import GHC.Utils.Misc
import GHC.Data.FastString
import GHC.Utils.Panic
import Language.Haskell.Syntax.Basic (FieldLabelString(..))
import qualified Data.ByteString as BS
import Control.Monad( unless, ap )
import Control.Applicative( (<|>) )
import Data.Bifunctor (first)
import Data.Foldable (for_)
import Data.List.NonEmpty( NonEmpty (..), nonEmpty )
import qualified Data.List.NonEmpty as NE
import Data.Maybe( catMaybes, isNothing )
import Data.Word (Word64)
import GHC.Internal.TH.Syntax as TH
import Foreign.ForeignPtr
import Foreign.Ptr
import System.IO.Unsafe
convertToHsDecls :: Origin -> SrcSpan -> [TH.Dec] -> Either RunSpliceFailReason [LHsDecl GhcPs]
convertToHsDecls :: Origin
-> SrcSpan -> [Dec] -> Either RunSpliceFailReason [LHsDecl GhcPs]
convertToHsDecls Origin
origin SrcSpan
loc [Dec]
ds =
Origin
-> SrcSpan
-> CvtM' RunSpliceFailReason [LHsDecl GhcPs]
-> Either RunSpliceFailReason [LHsDecl GhcPs]
forall err a. Origin -> SrcSpan -> CvtM' err a -> Either err a
initCvt Origin
origin SrcSpan
loc (CvtM' RunSpliceFailReason [LHsDecl GhcPs]
-> Either RunSpliceFailReason [LHsDecl GhcPs])
-> CvtM' RunSpliceFailReason [LHsDecl GhcPs]
-> Either RunSpliceFailReason [LHsDecl GhcPs]
forall a b. (a -> b) -> a -> b
$ ([Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs))]
-> [LHsDecl GhcPs])
-> CvtM'
RunSpliceFailReason [Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs))]
-> CvtM' RunSpliceFailReason [LHsDecl GhcPs]
forall a b.
(a -> b)
-> CvtM' RunSpliceFailReason a -> CvtM' RunSpliceFailReason b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs))] -> [LHsDecl GhcPs]
[Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs))]
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a. [Maybe a] -> [a]
catMaybes ((Dec
-> CvtM'
RunSpliceFailReason
(Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs))))
-> [Dec]
-> CvtM'
RunSpliceFailReason [Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Dec
-> CvtM'
RunSpliceFailReason (Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
cvt_dec [Dec]
ds)
where
cvt_dec :: Dec -> CvtM' RunSpliceFailReason (Maybe (LHsDecl GhcPs))
cvt_dec Dec
d =
ThingBeingConverted
-> CvtM' ConversionFailReason (Maybe (LHsDecl GhcPs))
-> CvtM' RunSpliceFailReason (Maybe (LHsDecl GhcPs))
forall a.
ThingBeingConverted
-> CvtM' ConversionFailReason a -> CvtM' RunSpliceFailReason a
wrapMsg (Dec -> ThingBeingConverted
ConvDec Dec
d) (CvtM' ConversionFailReason (Maybe (LHsDecl GhcPs))
-> CvtM' RunSpliceFailReason (Maybe (LHsDecl GhcPs)))
-> CvtM' ConversionFailReason (Maybe (LHsDecl GhcPs))
-> CvtM' RunSpliceFailReason (Maybe (LHsDecl GhcPs))
forall a b. (a -> b) -> a -> b
$ Dec -> CvtM' ConversionFailReason (Maybe (LHsDecl GhcPs))
cvtDec Dec
d
convertToHsExpr :: Origin -> SrcSpan -> TH.Exp -> Either RunSpliceFailReason (LHsExpr GhcPs)
convertToHsExpr :: Origin
-> SrcSpan -> Exp -> Either RunSpliceFailReason (LHsExpr GhcPs)
convertToHsExpr Origin
origin SrcSpan
loc Exp
e
= Origin
-> SrcSpan
-> CvtM' RunSpliceFailReason (LHsExpr GhcPs)
-> Either RunSpliceFailReason (LHsExpr GhcPs)
forall err a. Origin -> SrcSpan -> CvtM' err a -> Either err a
initCvt Origin
origin SrcSpan
loc (CvtM' RunSpliceFailReason (LHsExpr GhcPs)
-> Either RunSpliceFailReason (LHsExpr GhcPs))
-> CvtM' RunSpliceFailReason (LHsExpr GhcPs)
-> Either RunSpliceFailReason (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ ThingBeingConverted
-> CvtM' ConversionFailReason (LHsExpr GhcPs)
-> CvtM' RunSpliceFailReason (LHsExpr GhcPs)
forall a.
ThingBeingConverted
-> CvtM' ConversionFailReason a -> CvtM' RunSpliceFailReason a
wrapMsg (Exp -> ThingBeingConverted
ConvExp Exp
e) (CvtM' ConversionFailReason (LHsExpr GhcPs)
-> CvtM' RunSpliceFailReason (LHsExpr GhcPs))
-> CvtM' ConversionFailReason (LHsExpr GhcPs)
-> CvtM' RunSpliceFailReason (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ Exp -> CvtM' ConversionFailReason (LHsExpr GhcPs)
cvtl Exp
e
convertToPat :: Origin -> SrcSpan -> TH.Pat -> Either RunSpliceFailReason (LPat GhcPs)
convertToPat :: Origin -> SrcSpan -> Pat -> Either RunSpliceFailReason (LPat GhcPs)
convertToPat Origin
origin SrcSpan
loc Pat
p
= Origin
-> SrcSpan
-> CvtM' RunSpliceFailReason (LPat GhcPs)
-> Either RunSpliceFailReason (LPat GhcPs)
forall err a. Origin -> SrcSpan -> CvtM' err a -> Either err a
initCvt Origin
origin SrcSpan
loc (CvtM' RunSpliceFailReason (LPat GhcPs)
-> Either RunSpliceFailReason (LPat GhcPs))
-> CvtM' RunSpliceFailReason (LPat GhcPs)
-> Either RunSpliceFailReason (LPat GhcPs)
forall a b. (a -> b) -> a -> b
$ ThingBeingConverted
-> CvtM' ConversionFailReason (LPat GhcPs)
-> CvtM' RunSpliceFailReason (LPat GhcPs)
forall a.
ThingBeingConverted
-> CvtM' ConversionFailReason a -> CvtM' RunSpliceFailReason a
wrapMsg (Pat -> ThingBeingConverted
ConvPat Pat
p) (CvtM' ConversionFailReason (LPat GhcPs)
-> CvtM' RunSpliceFailReason (LPat GhcPs))
-> CvtM' ConversionFailReason (LPat GhcPs)
-> CvtM' RunSpliceFailReason (LPat GhcPs)
forall a b. (a -> b) -> a -> b
$ Pat -> CvtM' ConversionFailReason (LPat GhcPs)
cvtPat Pat
p
convertToHsType :: Origin -> SrcSpan -> TH.Type -> Either RunSpliceFailReason (LHsType GhcPs)
convertToHsType :: Origin
-> SrcSpan -> Type -> Either RunSpliceFailReason (LHsType GhcPs)
convertToHsType Origin
origin SrcSpan
loc Type
t
= Origin
-> SrcSpan
-> CvtM' RunSpliceFailReason (LHsType GhcPs)
-> Either RunSpliceFailReason (LHsType GhcPs)
forall err a. Origin -> SrcSpan -> CvtM' err a -> Either err a
initCvt Origin
origin SrcSpan
loc (CvtM' RunSpliceFailReason (LHsType GhcPs)
-> Either RunSpliceFailReason (LHsType GhcPs))
-> CvtM' RunSpliceFailReason (LHsType GhcPs)
-> Either RunSpliceFailReason (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ ThingBeingConverted
-> CvtM' ConversionFailReason (LHsType GhcPs)
-> CvtM' RunSpliceFailReason (LHsType GhcPs)
forall a.
ThingBeingConverted
-> CvtM' ConversionFailReason a -> CvtM' RunSpliceFailReason a
wrapMsg (Type -> ThingBeingConverted
ConvType Type
t) (CvtM' ConversionFailReason (LHsType GhcPs)
-> CvtM' RunSpliceFailReason (LHsType GhcPs))
-> CvtM' ConversionFailReason (LHsType GhcPs)
-> CvtM' RunSpliceFailReason (LHsType GhcPs)
forall a b. (a -> b) -> a -> b
$ Type -> CvtM' ConversionFailReason (LHsType GhcPs)
cvtType Type
t
newtype CvtM' err a = CvtM { forall err a.
CvtM' err a -> Origin -> SrcSpan -> Either err (SrcSpan, a)
unCvtM :: Origin -> SrcSpan -> Either err (SrcSpan, a) }
deriving ((forall a b. (a -> b) -> CvtM' err a -> CvtM' err b)
-> (forall a b. a -> CvtM' err b -> CvtM' err a)
-> Functor (CvtM' err)
forall a b. a -> CvtM' err b -> CvtM' err a
forall a b. (a -> b) -> CvtM' err a -> CvtM' err b
forall err a b. a -> CvtM' err b -> CvtM' err a
forall err a b. (a -> b) -> CvtM' err a -> CvtM' err b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall err a b. (a -> b) -> CvtM' err a -> CvtM' err b
fmap :: forall a b. (a -> b) -> CvtM' err a -> CvtM' err b
$c<$ :: forall err a b. a -> CvtM' err b -> CvtM' err a
<$ :: forall a b. a -> CvtM' err b -> CvtM' err a
Functor)
type CvtM = CvtM' ConversionFailReason
instance Applicative (CvtM' err) where
pure :: forall a. a -> CvtM' err a
pure a
x = (Origin -> SrcSpan -> Either err (SrcSpan, a)) -> CvtM' err a
forall err a.
(Origin -> SrcSpan -> Either err (SrcSpan, a)) -> CvtM' err a
CvtM ((Origin -> SrcSpan -> Either err (SrcSpan, a)) -> CvtM' err a)
-> (Origin -> SrcSpan -> Either err (SrcSpan, a)) -> CvtM' err a
forall a b. (a -> b) -> a -> b
$ \Origin
_ SrcSpan
loc -> (SrcSpan, a) -> Either err (SrcSpan, a)
forall a b. b -> Either a b
Right (SrcSpan
loc,a
x)
<*> :: forall a b. CvtM' err (a -> b) -> CvtM' err a -> CvtM' err b
(<*>) = CvtM' err (a -> b) -> CvtM' err a -> CvtM' err b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
instance Monad (CvtM' err) where
(CvtM Origin -> SrcSpan -> Either err (SrcSpan, a)
m) >>= :: forall a b. CvtM' err a -> (a -> CvtM' err b) -> CvtM' err b
>>= a -> CvtM' err b
k = (Origin -> SrcSpan -> Either err (SrcSpan, b)) -> CvtM' err b
forall err a.
(Origin -> SrcSpan -> Either err (SrcSpan, a)) -> CvtM' err a
CvtM ((Origin -> SrcSpan -> Either err (SrcSpan, b)) -> CvtM' err b)
-> (Origin -> SrcSpan -> Either err (SrcSpan, b)) -> CvtM' err b
forall a b. (a -> b) -> a -> b
$ \Origin
origin SrcSpan
loc -> case Origin -> SrcSpan -> Either err (SrcSpan, a)
m Origin
origin SrcSpan
loc of
Left err
err -> err -> Either err (SrcSpan, b)
forall a b. a -> Either a b
Left err
err
Right (SrcSpan
loc',a
v) -> CvtM' err b -> Origin -> SrcSpan -> Either err (SrcSpan, b)
forall err a.
CvtM' err a -> Origin -> SrcSpan -> Either err (SrcSpan, a)
unCvtM (a -> CvtM' err b
k a
v) Origin
origin SrcSpan
loc'
orOnFail :: CvtM' err a -> CvtM' err a -> CvtM' err a
(CvtM Origin -> SrcSpan -> Either err (SrcSpan, a)
m1) orOnFail :: forall err a. CvtM' err a -> CvtM' err a -> CvtM' err a
`orOnFail` (CvtM Origin -> SrcSpan -> Either err (SrcSpan, a)
m2) = (Origin -> SrcSpan -> Either err (SrcSpan, a)) -> CvtM' err a
forall err a.
(Origin -> SrcSpan -> Either err (SrcSpan, a)) -> CvtM' err a
CvtM ((Origin -> SrcSpan -> Either err (SrcSpan, a)) -> CvtM' err a)
-> (Origin -> SrcSpan -> Either err (SrcSpan, a)) -> CvtM' err a
forall a b. (a -> b) -> a -> b
$ \Origin
origin SrcSpan
l -> Either err (SrcSpan, a)
-> Either err (SrcSpan, a) -> Either err (SrcSpan, a)
forall {a} {b}. Either a b -> Either a b -> Either a b
choose (Origin -> SrcSpan -> Either err (SrcSpan, a)
m1 Origin
origin SrcSpan
l) (Origin -> SrcSpan -> Either err (SrcSpan, a)
m2 Origin
origin SrcSpan
l)
where
choose :: Either a b -> Either a b -> Either a b
choose r :: Either a b
r@Right{} Either a b
_ = Either a b
r
choose Either a b
_ r :: Either a b
r@Right{} = Either a b
r
choose err :: Either a b
err@Left{} Either a b
_ = Either a b
err
infixl 3 `orOnFail`
mapCvtMError :: (err1 -> err2) -> CvtM' err1 a -> CvtM' err2 a
mapCvtMError :: forall err1 err2 a. (err1 -> err2) -> CvtM' err1 a -> CvtM' err2 a
mapCvtMError err1 -> err2
f (CvtM Origin -> SrcSpan -> Either err1 (SrcSpan, a)
m) = (Origin -> SrcSpan -> Either err2 (SrcSpan, a)) -> CvtM' err2 a
forall err a.
(Origin -> SrcSpan -> Either err (SrcSpan, a)) -> CvtM' err a
CvtM ((Origin -> SrcSpan -> Either err2 (SrcSpan, a)) -> CvtM' err2 a)
-> (Origin -> SrcSpan -> Either err2 (SrcSpan, a)) -> CvtM' err2 a
forall a b. (a -> b) -> a -> b
$ \Origin
origin SrcSpan
loc -> (err1 -> err2)
-> Either err1 (SrcSpan, a) -> Either err2 (SrcSpan, a)
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first err1 -> err2
f (Either err1 (SrcSpan, a) -> Either err2 (SrcSpan, a))
-> Either err1 (SrcSpan, a) -> Either err2 (SrcSpan, a)
forall a b. (a -> b) -> a -> b
$ Origin -> SrcSpan -> Either err1 (SrcSpan, a)
m Origin
origin SrcSpan
loc
initCvt :: Origin -> SrcSpan -> CvtM' err a -> Either err a
initCvt :: forall err a. Origin -> SrcSpan -> CvtM' err a -> Either err a
initCvt Origin
origin SrcSpan
loc (CvtM Origin -> SrcSpan -> Either err (SrcSpan, a)
m) = ((SrcSpan, a) -> a) -> Either err (SrcSpan, a) -> Either err a
forall a b. (a -> b) -> Either err a -> Either err b
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 err (SrcSpan, a)
m Origin
origin SrcSpan
loc)
force :: a -> CvtM ()
force :: forall a. a -> CvtM ()
force a
a = a
a a -> CvtM () -> CvtM ()
forall a b. a -> b -> b
`seq` () -> CvtM ()
forall a. a -> CvtM' ConversionFailReason a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
failWith :: ConversionFailReason -> CvtM a
failWith :: forall a. ConversionFailReason -> CvtM a
failWith ConversionFailReason
m = (Origin -> SrcSpan -> Either ConversionFailReason (SrcSpan, a))
-> CvtM' ConversionFailReason a
forall err a.
(Origin -> SrcSpan -> Either err (SrcSpan, a)) -> CvtM' err a
CvtM (\Origin
_ SrcSpan
_ -> ConversionFailReason -> Either ConversionFailReason (SrcSpan, a)
forall a b. a -> Either a b
Left ConversionFailReason
m)
getOrigin :: CvtM Origin
getOrigin :: CvtM Origin
getOrigin = (Origin
-> SrcSpan -> Either ConversionFailReason (SrcSpan, Origin))
-> CvtM Origin
forall err a.
(Origin -> SrcSpan -> Either err (SrcSpan, a)) -> CvtM' err a
CvtM (\Origin
origin SrcSpan
loc -> (SrcSpan, Origin) -> Either ConversionFailReason (SrcSpan, Origin)
forall a b. b -> Either a b
Right (SrcSpan
loc,Origin
origin))
getL :: CvtM SrcSpan
getL :: CvtM SrcSpan
getL = (Origin
-> SrcSpan -> Either ConversionFailReason (SrcSpan, SrcSpan))
-> CvtM SrcSpan
forall err a.
(Origin -> SrcSpan -> Either err (SrcSpan, a)) -> CvtM' err a
CvtM (\Origin
_ SrcSpan
loc -> (SrcSpan, SrcSpan)
-> Either ConversionFailReason (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 ConversionFailReason (SrcSpan, ()))
-> CvtM ()
forall err a.
(Origin -> SrcSpan -> Either err (SrcSpan, a)) -> CvtM' err a
CvtM (\Origin
_ SrcSpan
_ -> (SrcSpan, ()) -> Either ConversionFailReason (SrcSpan, ())
forall a b. b -> Either a b
Right (SrcSpan
loc, ()))
returnLA :: (NoAnn ann) => e -> CvtM (LocatedAn ann e)
returnLA :: forall ann e. NoAnn ann => e -> CvtM (LocatedAn ann e)
returnLA e
x = (Origin
-> SrcSpan
-> Either ConversionFailReason (SrcSpan, LocatedAn ann e))
-> CvtM' ConversionFailReason (LocatedAn ann e)
forall err a.
(Origin -> SrcSpan -> Either err (SrcSpan, a)) -> CvtM' err a
CvtM (\Origin
_ SrcSpan
loc -> (SrcSpan, LocatedAn ann e)
-> Either ConversionFailReason (SrcSpan, LocatedAn ann e)
forall a b. b -> Either a b
Right (SrcSpan
loc, EpAnn ann -> e -> LocatedAn ann e
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> EpAnn ann
forall e. HasAnnotation e => SrcSpan -> e
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' ConversionFailReason (LocatedA a)
-> CvtM' ConversionFailReason (Maybe (LocatedA a))
forall a b.
(a -> b)
-> CvtM' ConversionFailReason a -> CvtM' ConversionFailReason b
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' ConversionFailReason (LocatedA a)
-> CvtM' ConversionFailReason (Maybe (LocatedA a)))
-> (a -> CvtM' ConversionFailReason (LocatedA a))
-> a
-> CvtM' ConversionFailReason (Maybe (LocatedA a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> CvtM' ConversionFailReason (LocatedA a)
forall ann e. NoAnn ann => e -> CvtM (LocatedAn ann e)
returnLA
wrapParLA :: (NoAnn ann) => (LocatedAn ann a -> b) -> a -> CvtM b
wrapParLA :: forall ann a b. NoAnn ann => (LocatedAn ann a -> b) -> a -> CvtM b
wrapParLA LocatedAn ann a -> b
add_par a
x = (Origin -> SrcSpan -> Either ConversionFailReason (SrcSpan, b))
-> CvtM' ConversionFailReason b
forall err a.
(Origin -> SrcSpan -> Either err (SrcSpan, a)) -> CvtM' err a
CvtM (\Origin
_ SrcSpan
loc -> (SrcSpan, b) -> Either ConversionFailReason (SrcSpan, b)
forall a b. b -> Either a b
Right (SrcSpan
loc, LocatedAn ann a -> b
add_par (EpAnn ann -> a -> LocatedAn ann a
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> EpAnn ann
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
loc) a
x)))
wrapMsg :: ThingBeingConverted -> CvtM' ConversionFailReason a -> CvtM' RunSpliceFailReason a
wrapMsg :: forall a.
ThingBeingConverted
-> CvtM' ConversionFailReason a -> CvtM' RunSpliceFailReason a
wrapMsg ThingBeingConverted
what = (ConversionFailReason -> RunSpliceFailReason)
-> CvtM' ConversionFailReason a -> CvtM' RunSpliceFailReason a
forall err1 err2 a. (err1 -> err2) -> CvtM' err1 a -> CvtM' err2 a
mapCvtMError (ThingBeingConverted -> ConversionFailReason -> RunSpliceFailReason
ConversionFail ThingBeingConverted
what)
wrapL :: CvtM a -> CvtM (Located a)
wrapL :: forall a. CvtM a -> CvtM (Located a)
wrapL (CvtM Origin -> SrcSpan -> Either ConversionFailReason (SrcSpan, a)
m) = (Origin
-> SrcSpan -> Either ConversionFailReason (SrcSpan, Located a))
-> CvtM' ConversionFailReason (Located a)
forall err a.
(Origin -> SrcSpan -> Either err (SrcSpan, a)) -> CvtM' err a
CvtM ((Origin
-> SrcSpan -> Either ConversionFailReason (SrcSpan, Located a))
-> CvtM' ConversionFailReason (Located a))
-> (Origin
-> SrcSpan -> Either ConversionFailReason (SrcSpan, Located a))
-> CvtM' ConversionFailReason (Located a)
forall a b. (a -> b) -> a -> b
$ \Origin
origin SrcSpan
loc -> case Origin -> SrcSpan -> Either ConversionFailReason (SrcSpan, a)
m Origin
origin SrcSpan
loc of
Left ConversionFailReason
err -> ConversionFailReason
-> Either ConversionFailReason (SrcSpan, Located a)
forall a b. a -> Either a b
Left ConversionFailReason
err
Right (SrcSpan
loc', a
v) -> (SrcSpan, Located a)
-> Either ConversionFailReason (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 ConversionFailReason (SrcSpan, a)
m) = (Origin
-> SrcSpan -> Either ConversionFailReason (SrcSpan, LocatedN a))
-> CvtM' ConversionFailReason (LocatedN a)
forall err a.
(Origin -> SrcSpan -> Either err (SrcSpan, a)) -> CvtM' err a
CvtM ((Origin
-> SrcSpan -> Either ConversionFailReason (SrcSpan, LocatedN a))
-> CvtM' ConversionFailReason (LocatedN a))
-> (Origin
-> SrcSpan -> Either ConversionFailReason (SrcSpan, LocatedN a))
-> CvtM' ConversionFailReason (LocatedN a)
forall a b. (a -> b) -> a -> b
$ \Origin
origin SrcSpan
loc -> case Origin -> SrcSpan -> Either ConversionFailReason (SrcSpan, a)
m Origin
origin SrcSpan
loc of
Left ConversionFailReason
err -> ConversionFailReason
-> Either ConversionFailReason (SrcSpan, LocatedN a)
forall a b. a -> Either a b
Left ConversionFailReason
err
Right (SrcSpan
loc', a
v) -> (SrcSpan, LocatedN a)
-> Either ConversionFailReason (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 e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
loc) a
v)
wrapLA :: CvtM a -> CvtM (LocatedA a)
wrapLA :: forall a. CvtM a -> CvtM (LocatedA a)
wrapLA (CvtM Origin -> SrcSpan -> Either ConversionFailReason (SrcSpan, a)
m) = (Origin
-> SrcSpan -> Either ConversionFailReason (SrcSpan, LocatedA a))
-> CvtM' ConversionFailReason (LocatedA a)
forall err a.
(Origin -> SrcSpan -> Either err (SrcSpan, a)) -> CvtM' err a
CvtM ((Origin
-> SrcSpan -> Either ConversionFailReason (SrcSpan, LocatedA a))
-> CvtM' ConversionFailReason (LocatedA a))
-> (Origin
-> SrcSpan -> Either ConversionFailReason (SrcSpan, LocatedA a))
-> CvtM' ConversionFailReason (LocatedA a)
forall a b. (a -> b) -> a -> b
$ \Origin
origin SrcSpan
loc -> case Origin -> SrcSpan -> Either ConversionFailReason (SrcSpan, a)
m Origin
origin SrcSpan
loc of
Left ConversionFailReason
err -> ConversionFailReason
-> Either ConversionFailReason (SrcSpan, LocatedA a)
forall a b. a -> Either a b
Left ConversionFailReason
err
Right (SrcSpan
loc', a
v) -> (SrcSpan, LocatedA a)
-> Either ConversionFailReason (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 e. HasAnnotation e => SrcSpan -> e
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'
ConversionFailReason
[Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs))]
-> CvtM'
ConversionFailReason [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a b.
(a -> b)
-> CvtM' ConversionFailReason a -> CvtM' ConversionFailReason b
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'
ConversionFailReason
[Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs))]
-> CvtM'
ConversionFailReason [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
-> ([Dec]
-> CvtM'
ConversionFailReason
[Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs))])
-> [Dec]
-> CvtM'
ConversionFailReason [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Dec
-> CvtM'
ConversionFailReason
(Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs))))
-> [Dec]
-> CvtM'
ConversionFailReason
[Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Dec -> CvtM' ConversionFailReason (Maybe (LHsDecl GhcPs))
Dec
-> CvtM'
ConversionFailReason
(Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
cvtDec
cvtDec :: TH.Dec -> CvtM (Maybe (LHsDecl GhcPs))
cvtDec :: Dec -> CvtM' ConversionFailReason (Maybe (LHsDecl GhcPs))
cvtDec (TH.ValD Pat
pat Body
body [Dec]
ds)
| TH.VarP Name
s <- Pat
pat
= do { s' <- Name -> CvtM (LocatedN RdrName)
vNameN Name
s
; cl' <- cvtClause (mkPrefixFunRhs s' noAnn) (Clause [] body ds)
; th_origin <- getOrigin
; returnJustLA $ Hs.ValD noExtField $ mkFunBind th_origin s' [cl'] }
| Bool
otherwise
= do { pat' <- Pat -> CvtM' ConversionFailReason (LPat GhcPs)
cvtPat Pat
pat
; body' <- cvtGuard body
; ds' <- cvtLocalDecs WhereClause ds
; returnJustLA $ Hs.ValD noExtField $
PatBind { pat_lhs = pat'
, pat_rhs = GRHSs emptyComments body' ds'
, pat_ext = noExtField
, pat_mult = HsNoMultAnn noExtField
} }
cvtDec (TH.FunD Name
nm [Clause]
cls)
| [Clause] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Clause]
cls
= ConversionFailReason
-> CvtM' ConversionFailReason (Maybe (LHsDecl GhcPs))
forall a. ConversionFailReason -> CvtM a
failWith (ConversionFailReason
-> CvtM' ConversionFailReason (Maybe (LHsDecl GhcPs)))
-> ConversionFailReason
-> CvtM' ConversionFailReason (Maybe (LHsDecl GhcPs))
forall a b. (a -> b) -> a -> b
$ Name -> ConversionFailReason
FunBindLacksEquations Name
nm
| Bool
otherwise
= do { nm' <- Name -> CvtM (LocatedN RdrName)
vNameN Name
nm
; cls' <- mapM (cvtClause (mkPrefixFunRhs nm' noAnn)) cls
; th_origin <- getOrigin
; returnJustLA $ Hs.ValD noExtField $ mkFunBind th_origin nm' cls' }
cvtDec (TH.SigD Name
nm Type
typ)
= do { nm' <- Name -> CvtM (LocatedN RdrName)
vNameN Name
nm
; ty' <- cvtSigType typ
; returnJustLA $ Hs.SigD noExtField
(TypeSig noAnn [nm'] (mkHsWildCardBndrs ty')) }
cvtDec (TH.KiSigD Name
nm Type
ki)
= do { nm' <- Name -> CvtM (LocatedN RdrName)
tconNameN Name
nm
; ki' <- cvtSigKind ki
; let sig' = XStandaloneKindSig GhcPs
-> LIdP GhcPs -> LHsSigType GhcPs -> StandaloneKindSig GhcPs
forall pass.
XStandaloneKindSig pass
-> LIdP pass -> LHsSigType pass -> StandaloneKindSig pass
StandaloneKindSig (EpToken "type", TokDcolon)
XStandaloneKindSig GhcPs
forall a. NoAnn a => a
noAnn LIdP GhcPs
LocatedN RdrName
nm' LHsSigType GhcPs
GenLocated SrcSpanAnnA (HsSigType GhcPs)
ki'
; returnJustLA $ Hs.KindSigD noExtField sig' }
cvtDec (TH.InfixD Fixity
fx NamespaceSpecifier
th_ns_spec Name
nm)
= do { nm' <- Name -> CvtM (LocatedN RdrName)
vcNameN Name
nm
; returnJustLA (Hs.SigD noExtField (FixSig noAnn
(FixitySig ns_spec [nm'] (cvtFixity fx)))) }
where
ns_spec :: NamespaceSpecifier
ns_spec = case NamespaceSpecifier
th_ns_spec of
NamespaceSpecifier
TH.NoNamespaceSpecifier -> NamespaceSpecifier
Hs.NoNamespaceSpecifier
NamespaceSpecifier
TH.TypeNamespaceSpecifier -> EpToken "type" -> NamespaceSpecifier
Hs.TypeNamespaceSpecifier EpToken "type"
forall a. NoAnn a => a
noAnn
NamespaceSpecifier
TH.DataNamespaceSpecifier -> EpToken "data" -> NamespaceSpecifier
Hs.DataNamespaceSpecifier EpToken "data"
forall a. NoAnn a => a
noAnn
cvtDec (TH.DefaultD [Type]
tys)
= do { tys' <- (Type
-> CvtM'
ConversionFailReason (GenLocated SrcSpanAnnA (HsType GhcPs)))
-> [Type]
-> CvtM'
ConversionFailReason [GenLocated SrcSpanAnnA (HsType GhcPs)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Type -> CvtM' ConversionFailReason (LHsType GhcPs)
Type
-> CvtM'
ConversionFailReason (GenLocated SrcSpanAnnA (HsType GhcPs))
cvtType [Type]
tys
; returnJustLA (Hs.DefD noExtField $ DefaultDecl noAnn Nothing tys') }
cvtDec (PragmaD Pragma
prag)
= Pragma -> CvtM' ConversionFailReason (Maybe (LHsDecl GhcPs))
cvtPragmaD Pragma
prag
cvtDec (TySynD Name
tc [TyVarBndr BndrVis]
tvs Type
rhs)
= do { (_, tc', tvs') <- [Type]
-> Name
-> [TyVarBndr BndrVis]
-> CvtM (LHsContext GhcPs, LocatedN RdrName, LHsQTyVars GhcPs)
cvt_tycl_hdr [] Name
tc [TyVarBndr BndrVis]
tvs
; rhs' <- cvtType rhs
; returnJustLA $ TyClD noExtField $
SynDecl { tcdSExt = noAnn, tcdLName = tc', tcdTyVars = tvs'
, tcdFixity = Prefix
, tcdRhs = rhs' } }
cvtDec (DataD [Type]
ctxt Name
tc [TyVarBndr BndrVis]
tvs Maybe Type
ksig [Con]
constrs [DerivClause]
derivs)
= [Type]
-> Name
-> [TyVarBndr BndrVis]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> CvtM' ConversionFailReason (Maybe (LHsDecl GhcPs))
cvtDataDec [Type]
ctxt Name
tc [TyVarBndr BndrVis]
tvs Maybe Type
ksig [Con]
constrs [DerivClause]
derivs
cvtDec (NewtypeD [Type]
ctxt Name
tc [TyVarBndr BndrVis]
tvs Maybe Type
ksig Con
constr [DerivClause]
derivs)
= do { (ctxt', tc', tvs') <- [Type]
-> Name
-> [TyVarBndr BndrVis]
-> CvtM (LHsContext GhcPs, LocatedN RdrName, LHsQTyVars GhcPs)
cvt_tycl_hdr [Type]
ctxt Name
tc [TyVarBndr BndrVis]
tvs
; ksig' <- cvtKind `traverse` ksig
; con' <- cvtDataDefnCons False ksig $ NewTypeCon constr
; derivs' <- cvtDerivs derivs
; let defn = HsDataDefn { dd_ext :: XCHsDataDefn GhcPs
dd_ext = XCHsDataDefn GhcPs
AnnDataDefn
forall a. NoAnn a => a
noAnn
, dd_cType :: Maybe (XRec GhcPs CType)
dd_cType = Maybe (XRec GhcPs CType)
Maybe (GenLocated SrcSpanAnnP CType)
forall a. Maybe a
Nothing
, dd_ctxt :: Maybe (LHsContext GhcPs)
dd_ctxt = LHsContext GhcPs -> Maybe (LHsContext GhcPs)
mkHsContextMaybe LHsContext GhcPs
GenLocated
(EpAnn AnnContext) [GenLocated SrcSpanAnnA (HsType GhcPs)]
ctxt'
, dd_kindSig :: Maybe (LHsType GhcPs)
dd_kindSig = Maybe (LHsType GhcPs)
Maybe (GenLocated SrcSpanAnnA (HsType GhcPs))
ksig'
, dd_cons :: DataDefnCons (LConDecl GhcPs)
dd_cons = DataDefnCons (LConDecl GhcPs)
con'
, dd_derivs :: HsDeriving GhcPs
dd_derivs = HsDeriving GhcPs
[GenLocated EpAnnCO (HsDerivingClause GhcPs)]
derivs' }
; returnJustLA $ TyClD noExtField $
DataDecl { tcdDExt = noExtField
, tcdLName = tc', tcdTyVars = tvs'
, tcdFixity = Prefix
, tcdDataDefn = defn } }
cvtDec (TypeDataD Name
tc [TyVarBndr BndrVis]
tvs Maybe Type
ksig [Con]
constrs)
= Name
-> [TyVarBndr BndrVis]
-> Maybe Type
-> [Con]
-> CvtM' ConversionFailReason (Maybe (LHsDecl GhcPs))
cvtTypeDataDec Name
tc [TyVarBndr BndrVis]
tvs Maybe Type
ksig [Con]
constrs
cvtDec (ClassD [Type]
ctxt Name
cl [TyVarBndr BndrVis]
tvs [FunDep]
fds [Dec]
decs)
= do { (cxt', tc', tvs') <- [Type]
-> Name
-> [TyVarBndr BndrVis]
-> CvtM (LHsContext GhcPs, LocatedN RdrName, LHsQTyVars GhcPs)
cvt_tycl_hdr [Type]
ctxt Name
cl [TyVarBndr BndrVis]
tvs
; fds' <- mapM cvt_fundep fds
; (binds', sigs', fams', at_defs', adts') <- cvt_ci_decs ClssDecl decs
; unless (null adts')
(failWith $ DefaultDataInstDecl adts')
; returnJustLA $ TyClD noExtField $
ClassDecl { tcdCExt = (noAnn, EpNoLayout, NoAnnSortKey)
, tcdCtxt = mkHsContextMaybe cxt', tcdLName = tc', tcdTyVars = tvs'
, tcdFixity = Prefix
, tcdFDs = fds', tcdSigs = Hs.mkClassOpSigs sigs'
, tcdMeths = binds'
, tcdATs = fams', tcdATDefs = at_defs', tcdDocs = [] }
}
cvtDec (InstanceD Maybe Overlap
o [Type]
ctxt Type
ty [Dec]
decs)
= do { (binds', sigs', fams', ats', adts') <- THDeclDescriptor
-> [Dec]
-> CvtM
(LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],
[LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs])
cvt_ci_decs THDeclDescriptor
InstanceDecl [Dec]
decs
; for_ (nonEmpty fams') $ \ NonEmpty (GenLocated SrcSpanAnnA (FamilyDecl GhcPs))
bad_fams ->
ConversionFailReason -> CvtM' ConversionFailReason (ZonkAny 1)
forall a. ConversionFailReason -> CvtM a
failWith (THDeclDescriptor -> IllegalDecls -> ConversionFailReason
IllegalDeclaration THDeclDescriptor
InstanceDecl (IllegalDecls -> ConversionFailReason)
-> IllegalDecls -> ConversionFailReason
forall a b. (a -> b) -> a -> b
$ NonEmpty (LFamilyDecl GhcPs) -> IllegalDecls
IllegalFamDecls NonEmpty (LFamilyDecl GhcPs)
NonEmpty (GenLocated SrcSpanAnnA (FamilyDecl GhcPs))
bad_fams)
; ctxt' <- cvtContext funPrec ctxt
; (L loc ty') <- cvtType ty
; let 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
$
[Type]
-> SrcSpanAnnA
-> LHsContext GhcPs
-> LHsType GhcPs
-> LHsType GhcPs
mkHsQualTy [Type]
ctxt SrcSpanAnnA
loc LHsContext GhcPs
GenLocated
(EpAnn AnnContext) [GenLocated SrcSpanAnnA (HsType 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'
; returnJustLA $ InstD noExtField $ ClsInstD noExtField $
ClsInstDecl { cid_ext = (Nothing, noAnn, NoAnnSortKey), cid_poly_ty = inst_ty'
, cid_binds = binds'
, cid_sigs = Hs.mkClassOpSigs sigs'
, cid_tyfam_insts = ats', cid_datafam_insts = adts'
, cid_overlap_mode
= fmap (L (l2l loc) . overlap) o } }
where
overlap :: Overlap -> OverlapMode
overlap Overlap
pragma =
case Overlap
pragma of
Overlap
TH.Overlaps -> SourceText -> OverlapMode
Hs.Overlaps (FastString -> SourceText
SourceText (FastString -> SourceText) -> FastString -> SourceText
forall a b. (a -> b) -> a -> b
$ String -> FastString
fsLit String
"{-# OVERLAPS")
Overlap
TH.Overlappable -> SourceText -> OverlapMode
Hs.Overlappable (FastString -> SourceText
SourceText (FastString -> SourceText) -> FastString -> SourceText
forall a b. (a -> b) -> a -> b
$ String -> FastString
fsLit String
"{-# OVERLAPPABLE")
Overlap
TH.Overlapping -> SourceText -> OverlapMode
Hs.Overlapping (FastString -> SourceText
SourceText (FastString -> SourceText) -> FastString -> SourceText
forall a b. (a -> b) -> a -> b
$ String -> FastString
fsLit String
"{-# OVERLAPPING")
Overlap
TH.Incoherent -> SourceText -> OverlapMode
Hs.Incoherent (FastString -> SourceText
SourceText (FastString -> SourceText) -> FastString -> SourceText
forall a b. (a -> b) -> a -> b
$ String -> FastString
fsLit String
"{-# INCOHERENT")
cvtDec (ForeignD Foreign
ford)
= do { ford' <- Foreign -> CvtM (ForeignDecl GhcPs)
cvtForD Foreign
ford
; returnJustLA $ ForD noExtField ford' }
cvtDec (DataFamilyD Name
tc [TyVarBndr BndrVis]
tvs Maybe Type
kind)
= do { (_, tc', tvs') <- [Type]
-> Name
-> [TyVarBndr BndrVis]
-> CvtM (LHsContext GhcPs, LocatedN RdrName, LHsQTyVars GhcPs)
cvt_tycl_hdr [] Name
tc [TyVarBndr BndrVis]
tvs
; result <- cvtMaybeKindToFamilyResultSig kind
; returnJustLA $ TyClD noExtField $ FamDecl noExtField $
FamilyDecl noAnn DataFamily TopLevel tc' tvs' Prefix result Nothing }
cvtDec (DataInstD [Type]
ctxt Maybe [TyVarBndr ()]
bndrs Type
tys Maybe Type
ksig [Con]
constrs [DerivClause]
derivs)
= do { (ctxt', tc', bndrs', typats') <- [Type]
-> Maybe [TyVarBndr ()]
-> Type
-> CvtM
(LHsContext GhcPs, LocatedN RdrName, HsOuterFamEqnTyVarBndrs GhcPs,
HsFamEqnPats GhcPs)
cvt_datainst_hdr [Type]
ctxt Maybe [TyVarBndr ()]
bndrs Type
tys
; ksig' <- cvtKind `traverse` ksig
; cons' <- cvtDataDefnCons False ksig $ DataTypeCons False constrs
; derivs' <- cvtDerivs derivs
; let defn = HsDataDefn { dd_ext :: XCHsDataDefn GhcPs
dd_ext = XCHsDataDefn GhcPs
AnnDataDefn
forall a. NoAnn a => a
noAnn
, dd_cType :: Maybe (XRec GhcPs CType)
dd_cType = Maybe (XRec GhcPs CType)
Maybe (GenLocated SrcSpanAnnP CType)
forall a. Maybe a
Nothing
, dd_ctxt :: Maybe (LHsContext GhcPs)
dd_ctxt = LHsContext GhcPs -> Maybe (LHsContext GhcPs)
mkHsContextMaybe LHsContext GhcPs
GenLocated
(EpAnn AnnContext) [GenLocated SrcSpanAnnA (HsType GhcPs)]
ctxt'
, dd_kindSig :: Maybe (LHsType GhcPs)
dd_kindSig = Maybe (LHsType GhcPs)
Maybe (GenLocated SrcSpanAnnA (HsType GhcPs))
ksig'
, dd_cons :: DataDefnCons (LConDecl GhcPs)
dd_cons = DataDefnCons (LConDecl GhcPs)
cons'
, dd_derivs :: HsDeriving GhcPs
dd_derivs = HsDeriving GhcPs
[GenLocated EpAnnCO (HsDerivingClause GhcPs)]
derivs' }
; returnJustLA $ InstD noExtField $ DataFamInstD
{ dfid_ext = noExtField
, dfid_inst = DataFamInstDecl { dfid_eqn =
FamEqn { feqn_ext = noAnn
, feqn_tycon = tc'
, feqn_bndrs = bndrs'
, feqn_pats = typats'
, feqn_rhs = defn
, feqn_fixity = Prefix } }}}
cvtDec (NewtypeInstD [Type]
ctxt Maybe [TyVarBndr ()]
bndrs Type
tys Maybe Type
ksig Con
constr [DerivClause]
derivs)
= do { (ctxt', tc', bndrs', typats') <- [Type]
-> Maybe [TyVarBndr ()]
-> Type
-> CvtM
(LHsContext GhcPs, LocatedN RdrName, HsOuterFamEqnTyVarBndrs GhcPs,
HsFamEqnPats GhcPs)
cvt_datainst_hdr [Type]
ctxt Maybe [TyVarBndr ()]
bndrs Type
tys
; ksig' <- cvtKind `traverse` ksig
; con' <- cvtDataDefnCons False ksig $ NewTypeCon constr
; derivs' <- cvtDerivs derivs
; let defn = HsDataDefn { dd_ext :: XCHsDataDefn GhcPs
dd_ext = XCHsDataDefn GhcPs
AnnDataDefn
forall a. NoAnn a => a
noAnn
, dd_cType :: Maybe (XRec GhcPs CType)
dd_cType = Maybe (XRec GhcPs CType)
Maybe (GenLocated SrcSpanAnnP CType)
forall a. Maybe a
Nothing
, dd_ctxt :: Maybe (LHsContext GhcPs)
dd_ctxt = LHsContext GhcPs -> Maybe (LHsContext GhcPs)
mkHsContextMaybe LHsContext GhcPs
GenLocated
(EpAnn AnnContext) [GenLocated SrcSpanAnnA (HsType GhcPs)]
ctxt'
, dd_kindSig :: Maybe (LHsType GhcPs)
dd_kindSig = Maybe (LHsType GhcPs)
Maybe (GenLocated SrcSpanAnnA (HsType GhcPs))
ksig'
, dd_cons :: DataDefnCons (LConDecl GhcPs)
dd_cons = DataDefnCons (LConDecl GhcPs)
con'
, dd_derivs :: HsDeriving GhcPs
dd_derivs = HsDeriving GhcPs
[GenLocated EpAnnCO (HsDerivingClause GhcPs)]
derivs' }
; returnJustLA $ InstD noExtField $ DataFamInstD
{ dfid_ext = noExtField
, dfid_inst = DataFamInstDecl { dfid_eqn =
FamEqn { feqn_ext = noAnn
, feqn_tycon = tc'
, feqn_bndrs = bndrs'
, feqn_pats = typats'
, feqn_rhs = defn
, feqn_fixity = Prefix } }}}
cvtDec (TySynInstD TySynEqn
eqn)
= do { (L _ eqn') <- TySynEqn -> CvtM (LTyFamInstEqn GhcPs)
cvtTySynEqn TySynEqn
eqn
; returnJustLA $ InstD noExtField $ TyFamInstD
{ tfid_ext = noExtField
, tfid_inst = TyFamInstDecl { tfid_xtn = noAnn, tfid_eqn = eqn' } }}
cvtDec (OpenTypeFamilyD TypeFamilyHead
head)
= do { (tc', tyvars', result', injectivity') <- TypeFamilyHead
-> CvtM
(LocatedN RdrName, LHsQTyVars GhcPs, LFamilyResultSig GhcPs,
Maybe (LInjectivityAnn GhcPs))
cvt_tyfam_head TypeFamilyHead
head
; returnJustLA $ TyClD noExtField $ FamDecl noExtField $
FamilyDecl noAnn OpenTypeFamily TopLevel tc' tyvars' Prefix result' injectivity'
}
cvtDec (ClosedTypeFamilyD TypeFamilyHead
head [TySynEqn]
eqns)
= do { (tc', tyvars', result', injectivity') <- TypeFamilyHead
-> CvtM
(LocatedN RdrName, LHsQTyVars GhcPs, LFamilyResultSig GhcPs,
Maybe (LInjectivityAnn GhcPs))
cvt_tyfam_head TypeFamilyHead
head
; eqns' <- mapM cvtTySynEqn eqns
; returnJustLA $ TyClD noExtField $ FamDecl noExtField $
FamilyDecl noAnn (ClosedTypeFamily (Just eqns')) TopLevel tc' tyvars' Prefix
result' injectivity' }
cvtDec (TH.RoleAnnotD Name
tc [Role]
roles)
= do { tc' <- Name -> CvtM (LocatedN RdrName)
tconNameN Name
tc
; roles' <- traverse (returnLA . cvtRole) roles
; returnJustLA
$ Hs.RoleAnnotD noExtField (RoleAnnotDecl noAnn tc' roles') }
cvtDec (TH.StandaloneDerivD Maybe DerivStrategy
ds [Type]
cxt Type
ty)
= do { cxt' <- PprPrec -> [Type] -> CvtM (LHsContext GhcPs)
cvtContext PprPrec
funPrec [Type]
cxt
; ds' <- traverse cvtDerivStrategy ds
; (L loc ty') <- cvtType ty
; let 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
$
[Type]
-> SrcSpanAnnA
-> LHsContext GhcPs
-> LHsType GhcPs
-> LHsType GhcPs
mkHsQualTy [Type]
cxt SrcSpanAnnA
loc LHsContext GhcPs
GenLocated
(EpAnn AnnContext) [GenLocated SrcSpanAnnA (HsType 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'
; returnJustLA $ DerivD noExtField $
DerivDecl { deriv_ext = (Nothing, noAnn)
, deriv_strategy = ds'
, deriv_type = mkHsWildCardBndrs inst_ty'
, deriv_overlap_mode = Nothing } }
cvtDec (TH.DefaultSigD Name
nm Type
typ)
= do { nm' <- Name -> CvtM (LocatedN RdrName)
vNameN Name
nm
; ty' <- cvtSigType typ
; returnJustLA $ Hs.SigD noExtField
$ ClassOpSig noAnn True [nm'] ty'}
cvtDec (TH.PatSynD Name
nm PatSynArgs
args PatSynDir
dir Pat
pat)
= do { nm' <- Name -> CvtM (LocatedN RdrName)
cNameN Name
nm
; args' <- cvtArgs args
; dir' <- cvtDir nm' dir
; pat' <- cvtPat pat
; returnJustLA $ Hs.ValD noExtField $ PatSynBind noExtField $
PSB noAnn nm' args' pat' dir' }
where
cvtArgs :: PatSynArgs
-> CvtM'
ConversionFailReason
(HsConDetails Void (LocatedN RdrName) [RecordPatSynField GhcPs])
cvtArgs (TH.PrefixPatSyn [Name]
args) = [Void]
-> [LocatedN RdrName]
-> HsConDetails Void (LocatedN RdrName) [RecordPatSynField GhcPs]
forall tyarg arg rec.
[tyarg] -> [arg] -> HsConDetails tyarg arg rec
Hs.PrefixCon [Void]
noTypeArgs ([LocatedN RdrName]
-> HsConDetails Void (LocatedN RdrName) [RecordPatSynField GhcPs])
-> CvtM' ConversionFailReason [LocatedN RdrName]
-> CvtM'
ConversionFailReason
(HsConDetails Void (LocatedN RdrName) [RecordPatSynField GhcPs])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name -> CvtM (LocatedN RdrName))
-> [Name] -> CvtM' ConversionFailReason [LocatedN RdrName]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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 GhcPs]
forall tyarg arg rec. arg -> arg -> HsConDetails tyarg arg rec
Hs.InfixCon (LocatedN RdrName
-> LocatedN RdrName
-> HsConDetails Void (LocatedN RdrName) [RecordPatSynField GhcPs])
-> CvtM (LocatedN RdrName)
-> CvtM'
ConversionFailReason
(LocatedN RdrName
-> HsConDetails Void (LocatedN RdrName) [RecordPatSynField GhcPs])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> CvtM (LocatedN RdrName)
vNameN Name
a1 CvtM'
ConversionFailReason
(LocatedN RdrName
-> HsConDetails Void (LocatedN RdrName) [RecordPatSynField GhcPs])
-> CvtM (LocatedN RdrName)
-> CvtM'
ConversionFailReason
(HsConDetails Void (LocatedN RdrName) [RecordPatSynField GhcPs])
forall a b.
CvtM' ConversionFailReason (a -> b)
-> CvtM' ConversionFailReason a -> CvtM' ConversionFailReason b
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 { let mk_fld :: Name -> CvtM (LocatedN RdrName)
mk_fld = String -> Name -> CvtM (LocatedN RdrName)
fldNameN (Name -> String
nameBase Name
nm)
; sels' <- (Name -> CvtM' ConversionFailReason (FieldOcc GhcPs))
-> [Name] -> CvtM' ConversionFailReason [FieldOcc GhcPs]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((LocatedN RdrName -> FieldOcc GhcPs)
-> CvtM (LocatedN RdrName)
-> CvtM' ConversionFailReason (FieldOcc GhcPs)
forall a b.
(a -> b)
-> CvtM' ConversionFailReason a -> CvtM' ConversionFailReason b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ (L SrcSpanAnnN
li RdrName
i) -> XCFieldOcc GhcPs -> LIdP GhcPs -> FieldOcc GhcPs
forall pass. XCFieldOcc pass -> LIdP pass -> FieldOcc pass
FieldOcc XCFieldOcc GhcPs
NoExtField
noExtField (SrcSpanAnnN -> RdrName -> LocatedN RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
li RdrName
i)) (CvtM (LocatedN RdrName)
-> CvtM' ConversionFailReason (FieldOcc GhcPs))
-> (Name -> CvtM (LocatedN RdrName))
-> Name
-> CvtM' ConversionFailReason (FieldOcc GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> CvtM (LocatedN RdrName)
mk_fld) [Name]
sels
; vars' <- mapM (vNameN . mkNameS . nameBase) sels
; return $ Hs.RecCon $ zipWith RecordPatSynField sels' vars' }
cvtDir :: LocatedN RdrName
-> PatSynDir -> CvtM' ConversionFailReason (HsPatSynDir GhcPs)
cvtDir LocatedN RdrName
_ PatSynDir
Unidir = HsPatSynDir GhcPs -> CvtM' ConversionFailReason (HsPatSynDir GhcPs)
forall a. a -> CvtM' ConversionFailReason a
forall (m :: * -> *) a. Monad m => a -> m a
return HsPatSynDir GhcPs
forall id. HsPatSynDir id
Unidirectional
cvtDir LocatedN RdrName
_ PatSynDir
ImplBidir = HsPatSynDir GhcPs -> CvtM' ConversionFailReason (HsPatSynDir GhcPs)
forall a. a -> CvtM' ConversionFailReason a
forall (m :: * -> *) a. Monad m => a -> m a
return HsPatSynDir GhcPs
forall id. HsPatSynDir id
ImplicitBidirectional
cvtDir LocatedN RdrName
n (ExplBidir [Clause]
cls) =
do { ms <- (Clause
-> CvtM'
ConversionFailReason
(GenLocated
SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))))
-> [Clause]
-> CvtM'
ConversionFailReason
[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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (HsMatchContextPs -> Clause -> CvtM (LMatch GhcPs (LHsExpr GhcPs))
cvtClause (LocatedN RdrName -> AnnFunRhs -> HsMatchContext (LocatedN RdrName)
forall fn. fn -> AnnFunRhs -> HsMatchContext fn
mkPrefixFunRhs LocatedN RdrName
n AnnFunRhs
forall a. NoAnn a => a
noAnn)) [Clause]
cls
; th_origin <- getOrigin
; wrapParLA (ExplicitBidirectional . mkMatchGroup th_origin) ms }
cvtDec (TH.PatSynSigD Name
nm Type
ty)
= do { nm' <- Name -> CvtM (LocatedN RdrName)
cNameN Name
nm
; ty' <- cvtPatSynSigTy ty
; returnJustLA $ Hs.SigD noExtField $ PatSynSig noAnn [nm'] ty'}
cvtDec (TH.ImplicitParamBindD String
_ Exp
_)
= ConversionFailReason
-> CvtM'
ConversionFailReason
(Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
forall a. ConversionFailReason -> CvtM a
failWith ConversionFailReason
InvalidImplicitParamBinding
cvtDataDec :: TH.Cxt -> TH.Name -> [TH.TyVarBndr TH.BndrVis]
-> Maybe TH.Kind -> [TH.Con] -> [TH.DerivClause]
-> CvtM (Maybe (LHsDecl GhcPs))
cvtDataDec :: [Type]
-> Name
-> [TyVarBndr BndrVis]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> CvtM' ConversionFailReason (Maybe (LHsDecl GhcPs))
cvtDataDec = Bool
-> [Type]
-> Name
-> [TyVarBndr BndrVis]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> CvtM' ConversionFailReason (Maybe (LHsDecl GhcPs))
cvtGenDataDec Bool
False
cvtTypeDataDec :: TH.Name -> [TH.TyVarBndr TH.BndrVis] -> Maybe TH.Kind -> [TH.Con]
-> CvtM (Maybe (LHsDecl GhcPs))
cvtTypeDataDec :: Name
-> [TyVarBndr BndrVis]
-> Maybe Type
-> [Con]
-> CvtM' ConversionFailReason (Maybe (LHsDecl GhcPs))
cvtTypeDataDec Name
tc [TyVarBndr BndrVis]
tvs Maybe Type
ksig [Con]
constrs
= Bool
-> [Type]
-> Name
-> [TyVarBndr BndrVis]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> CvtM' ConversionFailReason (Maybe (LHsDecl GhcPs))
cvtGenDataDec Bool
True [] Name
tc [TyVarBndr BndrVis]
tvs Maybe Type
ksig [Con]
constrs []
cvtGenDataDec :: Bool -> TH.Cxt -> TH.Name -> [TH.TyVarBndr TH.BndrVis]
-> Maybe TH.Kind -> [TH.Con] -> [TH.DerivClause]
-> CvtM (Maybe (LHsDecl GhcPs))
cvtGenDataDec :: Bool
-> [Type]
-> Name
-> [TyVarBndr BndrVis]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> CvtM' ConversionFailReason (Maybe (LHsDecl GhcPs))
cvtGenDataDec Bool
type_data [Type]
ctxt Name
tc [TyVarBndr BndrVis]
tvs Maybe Type
ksig [Con]
constrs [DerivClause]
derivs
= do { (ctxt', tc', tvs') <- [Type]
-> Name
-> [TyVarBndr BndrVis]
-> CvtM (LHsContext GhcPs, LocatedN RdrName, LHsQTyVars GhcPs)
cvt_tycl_hdr [Type]
ctxt Name
tc [TyVarBndr BndrVis]
tvs
; ksig' <- cvtKind `traverse` ksig
; cons' <- cvtDataDefnCons type_data ksig $
DataTypeCons type_data constrs
; derivs' <- cvtDerivs derivs
; let defn = HsDataDefn { dd_ext :: XCHsDataDefn GhcPs
dd_ext = XCHsDataDefn GhcPs
AnnDataDefn
forall a. NoAnn a => a
noAnn
, dd_cType :: Maybe (XRec GhcPs CType)
dd_cType = Maybe (XRec GhcPs CType)
Maybe (GenLocated SrcSpanAnnP CType)
forall a. Maybe a
Nothing
, dd_ctxt :: Maybe (LHsContext GhcPs)
dd_ctxt = LHsContext GhcPs -> Maybe (LHsContext GhcPs)
mkHsContextMaybe LHsContext GhcPs
GenLocated
(EpAnn AnnContext) [GenLocated SrcSpanAnnA (HsType GhcPs)]
ctxt'
, dd_kindSig :: Maybe (LHsType GhcPs)
dd_kindSig = Maybe (LHsType GhcPs)
Maybe (GenLocated SrcSpanAnnA (HsType GhcPs))
ksig'
, dd_cons :: DataDefnCons (LConDecl GhcPs)
dd_cons = DataDefnCons (LConDecl GhcPs)
cons'
, dd_derivs :: HsDeriving GhcPs
dd_derivs = HsDeriving GhcPs
[GenLocated EpAnnCO (HsDerivingClause GhcPs)]
derivs' }
; returnJustLA $ TyClD noExtField $
DataDecl { tcdDExt = noExtField
, tcdLName = tc', tcdTyVars = tvs'
, tcdFixity = Prefix
, tcdDataDefn = defn } }
cvtDataDefnCons ::
Bool -> Maybe TH.Kind ->
DataDefnCons TH.Con -> CvtM (DataDefnCons (LConDecl GhcPs))
cvtDataDefnCons :: Bool
-> Maybe Type
-> DataDefnCons Con
-> CvtM (DataDefnCons (LConDecl GhcPs))
cvtDataDefnCons Bool
type_data Maybe Type
ksig DataDefnCons Con
constrs
= do { let isGadtCon :: Con -> Bool
isGadtCon (GadtC [Name]
_ [BangType]
_ Type
_) = Bool
True
isGadtCon (RecGadtC [Name]
_ [VarBangType]
_ Type
_) = Bool
True
isGadtCon (ForallC [TyVarBndr Specificity]
_ [Type]
_ Con
c) = Con -> Bool
isGadtCon Con
c
isGadtCon Con
_ = Bool
False
isGadtDecl :: Bool
isGadtDecl = (Con -> Bool) -> DataDefnCons Con -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Con -> Bool
isGadtCon DataDefnCons Con
constrs
isH98Decl :: Bool
isH98Decl = (Con -> Bool) -> DataDefnCons 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) DataDefnCons Con
constrs
con_name :: Name -> CvtM (LocatedN RdrName)
con_name
| Bool
type_data = Name -> CvtM (LocatedN RdrName)
tconNameN
| Bool
otherwise = Name -> CvtM (LocatedN RdrName)
cNameN
; Bool -> CvtM () -> CvtM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
isGadtDecl Bool -> Bool -> Bool
|| Bool
isH98Decl)
(ConversionFailReason -> CvtM ()
forall a. ConversionFailReason -> CvtM a
failWith ConversionFailReason
CannotMixGADTConsWith98Cons)
; 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)
(ConversionFailReason -> CvtM ()
forall a. ConversionFailReason -> CvtM a
failWith ConversionFailReason
KindSigsOnlyAllowedOnGADTs)
; let first_datacon :: Con
first_datacon =
case DataDefnCons Con -> Maybe Con
forall a. DataDefnCons a -> Maybe a
firstDataDefnCon DataDefnCons Con
constrs of
Maybe Con
Nothing -> String -> Con
forall a. HasCallStack => String -> a
panic String
"cvtDataDefnCons: empty list of constructors"
Just Con
con -> Con
con
first_datacon_name :: Name
first_datacon_name =
case Con -> [Name]
get_cons_names Con
first_datacon of
[] -> String -> Name
forall a. HasCallStack => String -> a
panic String
"cvtDataDefnCons: data constructor with no names"
Name
c:[Name]
_ -> Name
c
; (Con
-> CvtM'
ConversionFailReason (GenLocated SrcSpanAnnA (ConDecl GhcPs)))
-> DataDefnCons Con
-> CvtM'
ConversionFailReason
(DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcPs)))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> DataDefnCons a -> m (DataDefnCons b)
mapM (Name
-> (Name -> CvtM (LocatedN RdrName))
-> Con
-> CvtM (LConDecl GhcPs)
cvtConstr Name
first_datacon_name Name -> CvtM (LocatedN RdrName)
con_name) DataDefnCons Con
constrs }
cvtTySynEqn :: TySynEqn -> CvtM (LTyFamInstEqn GhcPs)
cvtTySynEqn :: TySynEqn -> CvtM (LTyFamInstEqn GhcPs)
cvtTySynEqn (TySynEqn Maybe [TyVarBndr ()]
mb_bndrs Type
lhs Type
rhs)
= do { mb_bndrs' <- ([TyVarBndr ()]
-> CvtM'
ConversionFailReason
[GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)])
-> Maybe [TyVarBndr ()]
-> CvtM'
ConversionFailReason
(Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)])
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse ((TyVarBndr ()
-> CvtM'
ConversionFailReason
(GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)))
-> [TyVarBndr ()]
-> CvtM'
ConversionFailReason
[GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM TyVarBndr () -> CvtM (LHsTyVarBndr () GhcPs)
TyVarBndr ()
-> CvtM'
ConversionFailReason
(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 = Maybe [LHsTyVarBndr () GhcPs] -> HsOuterFamEqnTyVarBndrs GhcPs
mkHsOuterFamEqnTyVarBndrs Maybe [LHsTyVarBndr () GhcPs]
Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)]
mb_bndrs'
; (head_ty, args) <- split_ty_app lhs
; case head_ty of
ConT Name
nm -> do { nm' <- Name -> CvtM (LocatedN RdrName)
tconNameN Name
nm
; rhs' <- cvtType rhs
; let args' = (HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))
-> HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs)))
-> [HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
-> [HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
forall a b. (a -> b) -> [a] -> [b]
map LHsTypeArg GhcPs -> LHsTypeArg GhcPs
HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))
-> HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))
wrap_tyarg [HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
args
; returnLA
$ FamEqn { feqn_ext = noAnn
, feqn_tycon = nm'
, feqn_bndrs = outer_bndrs
, feqn_pats = args'
, feqn_fixity = Prefix
, feqn_rhs = rhs' } }
InfixT Type
t1 Name
nm Type
t2 -> do { nm' <- Name -> CvtM (LocatedN RdrName)
tconNameN Name
nm
; args' <- mapM cvtType [t1,t2]
; rhs' <- cvtType rhs
; returnLA
$ FamEqn { feqn_ext = noAnn
, feqn_tycon = nm'
, feqn_bndrs = outer_bndrs
, feqn_pats =
(map (HsValArg noExtField) args') ++ args
, feqn_fixity = Hs.Infix
, feqn_rhs = rhs' } }
Type
_ -> ConversionFailReason
-> CvtM'
ConversionFailReason
(GenLocated
SrcSpanAnnA (FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))))
forall a. ConversionFailReason -> CvtM a
failWith (ConversionFailReason
-> CvtM'
ConversionFailReason
(GenLocated
SrcSpanAnnA
(FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))))
-> ConversionFailReason
-> CvtM'
ConversionFailReason
(GenLocated
SrcSpanAnnA (FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))))
forall a b. (a -> b) -> a -> b
$ Type -> ConversionFailReason
InvalidTyFamInstLHS Type
lhs
}
cvt_ci_decs :: THDeclDescriptor -> [TH.Dec]
-> CvtM (LHsBinds GhcPs,
[LSig GhcPs],
[LFamilyDecl GhcPs],
[LTyFamInstDecl GhcPs],
[LDataFamInstDecl GhcPs])
cvt_ci_decs :: THDeclDescriptor
-> [Dec]
-> CvtM
(LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],
[LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs])
cvt_ci_decs THDeclDescriptor
declDescr [Dec]
decs
= do { decs' <- [Dec] -> CvtM [LHsDecl GhcPs]
cvtDecs [Dec]
decs
; let (ats', bind_sig_decs') = partitionWith is_tyfam_inst decs'
; let (adts', no_ats') = partitionWith is_datafam_inst bind_sig_decs'
; let (sigs', prob_binds') = partitionWith is_sig no_ats'
; let (binds', prob_fams') = partitionWith is_bind prob_binds'
; let (fams', bads) = partitionWith is_fam_decl prob_fams'
; for_ (nonEmpty bads) $ \ NonEmpty (GenLocated SrcSpanAnnA (HsDecl GhcPs))
bad_decls ->
ConversionFailReason -> CvtM' ConversionFailReason (ZonkAny 0)
forall a. ConversionFailReason -> CvtM a
failWith (THDeclDescriptor -> IllegalDecls -> ConversionFailReason
IllegalDeclaration THDeclDescriptor
declDescr (IllegalDecls -> ConversionFailReason)
-> IllegalDecls -> ConversionFailReason
forall a b. (a -> b) -> a -> b
$ NonEmpty (LHsDecl GhcPs) -> IllegalDecls
IllegalDecls NonEmpty (LHsDecl GhcPs)
NonEmpty (GenLocated SrcSpanAnnA (HsDecl GhcPs))
bad_decls)
; return (binds', sigs', fams', ats', adts') }
cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr TH.BndrVis]
-> CvtM ( LHsContext GhcPs
, LocatedN RdrName
, LHsQTyVars GhcPs)
cvt_tycl_hdr :: [Type]
-> Name
-> [TyVarBndr BndrVis]
-> CvtM (LHsContext GhcPs, LocatedN RdrName, LHsQTyVars GhcPs)
cvt_tycl_hdr [Type]
cxt Name
tc [TyVarBndr BndrVis]
tvs
= do { cxt' <- PprPrec -> [Type] -> CvtM (LHsContext GhcPs)
cvtContext PprPrec
funPrec [Type]
cxt
; tc' <- tconNameN tc
; tvs' <- cvtTvs tvs
; return (cxt', tc', mkHsQTvs tvs')
}
cvt_datainst_hdr :: TH.Cxt -> Maybe [TH.TyVarBndr ()] -> TH.Type
-> CvtM ( LHsContext GhcPs
, LocatedN RdrName
, HsOuterFamEqnTyVarBndrs GhcPs
, HsFamEqnPats GhcPs)
cvt_datainst_hdr :: [Type]
-> Maybe [TyVarBndr ()]
-> Type
-> CvtM
(LHsContext GhcPs, LocatedN RdrName, HsOuterFamEqnTyVarBndrs GhcPs,
HsFamEqnPats GhcPs)
cvt_datainst_hdr [Type]
cxt Maybe [TyVarBndr ()]
bndrs Type
tys
= do { cxt' <- PprPrec -> [Type] -> CvtM (LHsContext GhcPs)
cvtContext PprPrec
funPrec [Type]
cxt
; bndrs' <- traverse (mapM cvt_tv) bndrs
; let outer_bndrs = Maybe [LHsTyVarBndr () GhcPs] -> HsOuterFamEqnTyVarBndrs GhcPs
mkHsOuterFamEqnTyVarBndrs Maybe [LHsTyVarBndr () GhcPs]
Maybe [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)]
bndrs'
; (head_ty, args) <- split_ty_app tys
; case head_ty of
ConT Name
nm -> do { nm' <- Name -> CvtM (LocatedN RdrName)
tconNameN Name
nm
; let args' = (HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))
-> HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs)))
-> [HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
-> [HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
forall a b. (a -> b) -> [a] -> [b]
map LHsTypeArg GhcPs -> LHsTypeArg GhcPs
HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))
-> HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))
wrap_tyarg [HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
args
; return (cxt', nm', outer_bndrs, args') }
InfixT Type
t1 Name
nm Type
t2 -> do { nm' <- Name -> CvtM (LocatedN RdrName)
tconNameN Name
nm
; args' <- mapM cvtType [t1,t2]
; return (cxt', nm', outer_bndrs,
((map (HsValArg noExtField) args') ++ args)) }
Type
_ -> ConversionFailReason
-> CvtM'
ConversionFailReason
(GenLocated
(EpAnn AnnContext) [GenLocated SrcSpanAnnA (HsType GhcPs)],
LocatedN RdrName, HsOuterFamEqnTyVarBndrs GhcPs,
[HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))])
forall a. ConversionFailReason -> CvtM a
failWith (ConversionFailReason
-> CvtM'
ConversionFailReason
(GenLocated
(EpAnn AnnContext) [GenLocated SrcSpanAnnA (HsType GhcPs)],
LocatedN RdrName, HsOuterFamEqnTyVarBndrs GhcPs,
[HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]))
-> ConversionFailReason
-> CvtM'
ConversionFailReason
(GenLocated
(EpAnn AnnContext) [GenLocated SrcSpanAnnA (HsType GhcPs)],
LocatedN RdrName, HsOuterFamEqnTyVarBndrs GhcPs,
[HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))])
forall a b. (a -> b) -> a -> b
$ Type -> ConversionFailReason
InvalidTypeInstanceHeader 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 BndrVis]
tyvars FamilyResultSig
result Maybe InjectivityAnn
injectivity)
= do { (_, tc', tyvars') <- [Type]
-> Name
-> [TyVarBndr BndrVis]
-> CvtM (LHsContext GhcPs, LocatedN RdrName, LHsQTyVars GhcPs)
cvt_tycl_hdr [] Name
tc [TyVarBndr BndrVis]
tyvars
; result' <- cvtFamilyResultSig result
; injectivity' <- traverse cvtInjectivityAnnotation injectivity
; return (tc', tyvars', result', injectivity') }
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 LHsDecl GhcPs
GenLocated SrcSpanAnnA (HsDecl 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 LHsDecl GhcPs
GenLocated SrcSpanAnnA (HsDecl 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 LHsDecl GhcPs
GenLocated SrcSpanAnnA (HsDecl 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 LHsDecl GhcPs
GenLocated SrcSpanAnnA (HsDecl 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 LHsDecl GhcPs
GenLocated SrcSpanAnnA (HsDecl 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
cvtConstr :: TH.Name
-> (TH.Name -> CvtM (LocatedN RdrName))
-> TH.Con -> CvtM (LConDecl GhcPs)
cvtConstr :: Name
-> (Name -> CvtM (LocatedN RdrName))
-> Con
-> CvtM (LConDecl GhcPs)
cvtConstr Name
_ Name -> CvtM (LocatedN RdrName)
do_con_name (NormalC Name
c [BangType]
strtys)
= do { c' <- Name -> CvtM (LocatedN RdrName)
do_con_name Name
c
; tys' <- mapM cvt_arg strtys
; returnLA $ mkConDeclH98 noAnn c' Nothing Nothing (PrefixCon noTypeArgs (map hsLinear tys')) }
cvtConstr Name
parent_con Name -> CvtM (LocatedN RdrName)
do_con_name (RecC Name
c [VarBangType]
varstrtys)
= do { c' <- Name -> CvtM (LocatedN RdrName)
do_con_name Name
c
; args' <- mapM (cvt_id_arg parent_con) varstrtys
; con_decl <- wrapParLA (mkConDeclH98 noAnn c' Nothing Nothing . RecCon) args'
; returnLA con_decl }
cvtConstr Name
_ Name -> CvtM (LocatedN RdrName)
do_con_name (InfixC BangType
st1 Name
c BangType
st2)
= do { c' <- Name -> CvtM (LocatedN RdrName)
do_con_name Name
c
; st1' <- cvt_arg st1
; st2' <- cvt_arg st2
; returnLA $ mkConDeclH98 noAnn c' Nothing Nothing
(InfixCon (hsLinear st1') (hsLinear st2')) }
cvtConstr Name
parent_con Name -> CvtM (LocatedN RdrName)
do_con_name (ForallC [TyVarBndr Specificity]
tvs [Type]
ctxt Con
con)
= do { tvs' <- [TyVarBndr Specificity] -> CvtM [LHsTyVarBndr Specificity GhcPs]
forall flag flag'.
CvtFlag flag flag' =>
[TyVarBndr flag] -> CvtM [LHsTyVarBndr flag' GhcPs]
cvtTvs [TyVarBndr Specificity]
tvs
; ctxt' <- cvtContext funPrec ctxt
; L _ con' <- cvtConstr parent_con do_con_name con
; returnLA $ add_forall tvs' ctxt' con' }
where
add_cxt :: GenLocated
(EpAnn AnnContext) [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> Maybe (GenLocated l [GenLocated SrcSpanAnnA (HsType GhcPs)])
-> Maybe (LHsContext GhcPs)
add_cxt GenLocated
(EpAnn AnnContext) [GenLocated SrcSpanAnnA (HsType GhcPs)]
lcxt Maybe (GenLocated l [GenLocated SrcSpanAnnA (HsType GhcPs)])
Nothing = LHsContext GhcPs -> Maybe (LHsContext GhcPs)
mkHsContextMaybe LHsContext GhcPs
GenLocated
(EpAnn AnnContext) [GenLocated SrcSpanAnnA (HsType GhcPs)]
lcxt
add_cxt (L EpAnn AnnContext
loc [GenLocated SrcSpanAnnA (HsType GhcPs)]
cxt1) (Just (L l
_ [GenLocated SrcSpanAnnA (HsType GhcPs)]
cxt2))
= GenLocated
(EpAnn AnnContext) [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> Maybe
(GenLocated
(EpAnn AnnContext) [GenLocated SrcSpanAnnA (HsType GhcPs)])
forall a. a -> Maybe a
Just (EpAnn AnnContext
-> [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> GenLocated
(EpAnn AnnContext) [GenLocated SrcSpanAnnA (HsType GhcPs)]
forall l e. l -> e -> GenLocated l e
L EpAnn AnnContext
loc ([GenLocated SrcSpanAnnA (HsType GhcPs)]
cxt1 [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> [GenLocated SrcSpanAnnA (HsType GhcPs)]
forall a. [a] -> [a] -> [a]
++ [GenLocated SrcSpanAnnA (HsType GhcPs)]
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 HsOuterSigTyVarBndrs 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 = L l outer_bndrs'
, con_mb_cxt = add_cxt cxt' cxt }
where
outer_bndrs' :: HsOuterSigTyVarBndrs GhcPs
outer_bndrs'
| [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)]
all_tvs = HsOuterSigTyVarBndrs GhcPs
forall flag. HsOuterTyVarBndrs flag GhcPs
mkHsOuterImplicit
| Bool
otherwise = EpAnnForallInvis
-> [LHsTyVarBndr Specificity GhcPs] -> HsOuterSigTyVarBndrs GhcPs
forall flag.
EpAnnForallInvis
-> [LHsTyVarBndr flag GhcPs] -> HsOuterTyVarBndrs flag GhcPs
mkHsOuterExplicit EpAnnForallInvis
forall a. NoAnn a => a
noAnn [LHsTyVarBndr Specificity GhcPs]
[GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)]
all_tvs
all_tvs :: [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)]
all_tvs = [LHsTyVarBndr Specificity GhcPs]
[GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)]
tvs' [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)]
-> [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)]
-> [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)]
forall a. [a] -> [a] -> [a]
++ [LHsTyVarBndr Specificity (NoGhcTc GhcPs)]
[GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)]
outer_exp_tvs
outer_exp_tvs :: [LHsTyVarBndr Specificity (NoGhcTc GhcPs)]
outer_exp_tvs = HsOuterSigTyVarBndrs GhcPs
-> [LHsTyVarBndr Specificity (NoGhcTc GhcPs)]
forall flag (p :: Pass).
HsOuterTyVarBndrs flag (GhcPass p)
-> [LHsTyVarBndr flag (NoGhcTc (GhcPass p))]
hsOuterExplicitBndrs HsOuterSigTyVarBndrs 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 = not (null all_tvs)
, con_ex_tvs = all_tvs
, con_mb_cxt = add_cxt cxt' cxt }
where
all_tvs :: [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)]
all_tvs = [LHsTyVarBndr Specificity GhcPs]
[GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)]
tvs' [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)]
-> [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)]
-> [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)]
forall a. [a] -> [a] -> [a]
++ [LHsTyVarBndr Specificity GhcPs]
[GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)]
ex_tvs
cvtConstr Name
_ Name -> CvtM (LocatedN RdrName)
do_con_name (GadtC [Name]
c [BangType]
strtys Type
ty) = case [Name] -> Maybe (NonEmpty Name)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [Name]
c of
Maybe (NonEmpty Name)
Nothing -> ConversionFailReason
-> CvtM'
ConversionFailReason (GenLocated SrcSpanAnnA (ConDecl GhcPs))
forall a. ConversionFailReason -> CvtM a
failWith ConversionFailReason
GadtNoCons
Just NonEmpty Name
c -> do
{ c' <- (Name -> CvtM (LocatedN RdrName))
-> NonEmpty Name
-> CvtM' ConversionFailReason (NonEmpty (LocatedN RdrName))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NonEmpty a -> m (NonEmpty b)
mapM Name -> CvtM (LocatedN RdrName)
do_con_name NonEmpty Name
c
; args <- mapM cvt_arg strtys
; ty' <- cvtType ty
; mk_gadt_decl c' (PrefixConGADT noExtField $ map hsLinear args) ty'}
cvtConstr Name
parent_con Name -> CvtM (LocatedN RdrName)
do_con_name (RecGadtC [Name]
c [VarBangType]
varstrtys Type
ty) = case [Name] -> Maybe (NonEmpty Name)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [Name]
c of
Maybe (NonEmpty Name)
Nothing -> ConversionFailReason
-> CvtM'
ConversionFailReason (GenLocated SrcSpanAnnA (ConDecl GhcPs))
forall a. ConversionFailReason -> CvtM a
failWith ConversionFailReason
RecGadtNoCons
Just NonEmpty Name
c -> do
{ c' <- (Name -> CvtM (LocatedN RdrName))
-> NonEmpty Name
-> CvtM' ConversionFailReason (NonEmpty (LocatedN RdrName))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NonEmpty a -> m (NonEmpty b)
mapM Name -> CvtM (LocatedN RdrName)
do_con_name NonEmpty Name
c
; ty' <- cvtType ty
; rec_flds <- mapM (cvt_id_arg parent_con) varstrtys
; lrec_flds <- returnLA rec_flds
; mk_gadt_decl c' (RecConGADT noAnn lrec_flds) ty' }
mk_gadt_decl :: NonEmpty (LocatedN RdrName) -> HsConDeclGADTDetails GhcPs -> LHsType GhcPs
-> CvtM (LConDecl GhcPs)
mk_gadt_decl :: NonEmpty (LocatedN RdrName)
-> HsConDeclGADTDetails GhcPs
-> LHsType GhcPs
-> CvtM (LConDecl GhcPs)
mk_gadt_decl NonEmpty (LocatedN RdrName)
names HsConDeclGADTDetails GhcPs
args LHsType GhcPs
res_ty
= do bndrs <- HsOuterSigTyVarBndrs GhcPs
-> CvtM (GenLocated SrcSpanAnnA (HsOuterSigTyVarBndrs GhcPs))
forall ann e. NoAnn ann => e -> CvtM (LocatedAn ann e)
returnLA HsOuterSigTyVarBndrs GhcPs
forall flag. HsOuterTyVarBndrs flag GhcPs
mkHsOuterImplicit
returnLA $ ConDeclGADT
{ con_g_ext = noAnn
, con_names = names
, con_bndrs = bndrs
, con_mb_cxt = Nothing
, con_g_args = args
, con_res_ty = res_ty
, con_doc = 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' ConversionFailReason (LHsType GhcPs)
cvt_arg (Bang SourceUnpackedness
su SourceStrictness
ss, Type
ty)
= do { ty'' <- Type -> CvtM' ConversionFailReason (LHsType GhcPs)
cvtType Type
ty
; let ty' = PprPrec -> LHsType GhcPs -> LHsType GhcPs
forall (p :: Pass).
PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)
parenthesizeHsType PprPrec
appPrec LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
ty''
su' = SourceUnpackedness -> SrcUnpackedness
cvtSrcUnpackedness SourceUnpackedness
su
ss' = SourceStrictness -> SrcStrictness
cvtSrcStrictness SourceStrictness
ss
; returnLA $ HsBangTy (noAnn, NoSourceText) (HsBang su' ss') ty' }
cvt_id_arg :: TH.Name
-> (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField GhcPs)
cvt_id_arg :: Name -> VarBangType -> CvtM (LConDeclField GhcPs)
cvt_id_arg Name
parent_con (Name
i, Bang
str, Type
ty)
= do { L li i' <- String -> Name -> CvtM (LocatedN RdrName)
fldNameN (Name -> String
nameBase Name
parent_con) Name
i
; ty' <- cvt_arg (str,ty)
; returnLA $ ConDeclField
{ cd_fld_ext = noAnn
, cd_fld_names
= [L (l2l li) $ FieldOcc noExtField (L li i')]
, cd_fld_type = ty'
, cd_fld_doc = Nothing} }
cvtDerivs :: [TH.DerivClause] -> CvtM (HsDeriving GhcPs)
cvtDerivs :: [DerivClause] -> CvtM (HsDeriving GhcPs)
cvtDerivs [DerivClause]
cs = do { (DerivClause
-> CvtM'
ConversionFailReason (GenLocated EpAnnCO (HsDerivingClause GhcPs)))
-> [DerivClause]
-> CvtM'
ConversionFailReason [GenLocated EpAnnCO (HsDerivingClause GhcPs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM DerivClause -> CvtM (LHsDerivingClause GhcPs)
DerivClause
-> CvtM'
ConversionFailReason (GenLocated EpAnnCO (HsDerivingClause GhcPs))
cvtDerivClause [DerivClause]
cs }
cvt_fundep :: TH.FunDep -> CvtM (LHsFunDep GhcPs)
cvt_fundep :: FunDep -> CvtM (LHsFunDep GhcPs)
cvt_fundep (TH.FunDep [Name]
xs [Name]
ys) = do { xs' <- (Name -> CvtM (LocatedN RdrName))
-> [Name] -> CvtM' ConversionFailReason [LocatedN RdrName]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Name -> CvtM (LocatedN RdrName)
tNameN [Name]
xs
; ys' <- mapM tNameN ys
; returnLA (Hs.FunDep noAnn xs' ys') }
cvtForD :: Foreign -> CvtM (ForeignDecl GhcPs)
cvtForD :: Foreign -> CvtM (ForeignDecl GhcPs)
cvtForD (ImportF Callconv
callconv Safety
safety String
from Name
nm Type
ty) =
do { ls <- CvtM SrcSpan
getL
; let l = SrcSpan -> EpaLocation
forall a b. (HasLoc a, HasAnnotation b) => a -> b
l2l SrcSpan
ls
; if
| callconv == TH.Prim || callconv == TH.JavaScript
-> mk_imp (CImport (L l $ quotedSourceText from) (L l (cvt_conv callconv)) (L l safety') Nothing
(CFunction (StaticTarget (SourceText fromtxt)
fromtxt Nothing
True)))
| Just impspec <- parseCImport (L l (cvt_conv callconv)) (L l safety')
(mkFastString (TH.nameBase nm))
from (L ls $ quotedSourceText from)
-> mk_imp impspec
| otherwise
-> failWith $ InvalidCCallImpent from }
where
fromtxt :: FastString
fromtxt = String -> FastString
mkFastString String
from
mk_imp :: ForeignImport GhcPs -> CvtM (ForeignDecl GhcPs)
mk_imp ForeignImport GhcPs
impspec
= do { nm' <- Name -> CvtM (LocatedN RdrName)
vNameN Name
nm
; ty' <- cvtSigType ty
; return (ForeignImport { fd_i_ext = noAnn
, fd_name = nm'
, fd_sig_ty = ty'
, fd_fi = 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 { nm' <- Name -> CvtM (LocatedN RdrName)
vNameN Name
nm
; ty' <- cvtSigType ty
; ls <- getL
; let l = SrcSpan -> EpaLocation
forall a b. (HasLoc a, HasAnnotation b) => a -> b
l2l SrcSpan
ls
; let astxt = String -> FastString
mkFastString String
as
; let e = XCExport GhcPs -> XRec GhcPs CExportSpec -> ForeignExport GhcPs
forall pass.
XCExport pass -> XRec pass CExportSpec -> ForeignExport pass
CExport (EpaLocation -> SourceText -> GenLocated EpaLocation SourceText
forall l e. l -> e -> GenLocated l e
L EpaLocation
l (FastString -> SourceText
SourceText FastString
astxt)) (EpaLocation -> CExportSpec -> GenLocated EpaLocation CExportSpec
forall l e. l -> e -> GenLocated l e
L EpaLocation
l (SourceText -> FastString -> CCallConv -> CExportSpec
CExportStatic (FastString -> SourceText
SourceText FastString
astxt)
FastString
astxt
(Callconv -> CCallConv
cvt_conv Callconv
callconv)))
; return $ ForeignExport { fd_e_ext = noAnn
, fd_name = nm'
, fd_sig_ty = ty'
, fd_fe = e } }
cvt_conv :: TH.Callconv -> CCallConv
cvt_conv :: Callconv -> CCallConv
cvt_conv Callconv
TH.CCall = CCallConv
CCallConv
cvt_conv Callconv
TH.StdCall = CCallConv
StdCallConv
cvt_conv Callconv
TH.CApi = CCallConv
CApiConv
cvt_conv Callconv
TH.Prim = CCallConv
PrimCallConv
cvt_conv Callconv
TH.JavaScript = CCallConv
JavaScriptCallConv
cvtPragmaD :: Pragma -> CvtM (Maybe (LHsDecl GhcPs))
cvtPragmaD :: Pragma -> CvtM' ConversionFailReason (Maybe (LHsDecl GhcPs))
cvtPragmaD (InlineP Name
nm Inline
inline RuleMatch
rm Phases
phases)
= do {
nm' <- Name -> CvtM (LocatedN RdrName)
vcNameN Name
nm
; let dflt = Inline -> Activation
dfltActivation Inline
inline
; let src Inline
TH.NoInline = String -> FastString
fsLit String
"{-# NOINLINE"
src Inline
TH.Inline = String -> FastString
fsLit String
"{-# INLINE"
src Inline
TH.Inlinable = String -> FastString
fsLit String
"{-# INLINABLE"
; let ip = InlinePragma { inl_src :: SourceText
inl_src = Inline -> SourceText
toSrcTxt Inline
inline
, inl_inline :: InlineSpec
inl_inline = Inline -> SourceText -> InlineSpec
cvtInline Inline
inline (Inline -> SourceText
toSrcTxt Inline
inline)
, inl_rule :: RuleMatchInfo
inl_rule = RuleMatch -> RuleMatchInfo
cvtRuleMatch RuleMatch
rm
, inl_act :: Activation
inl_act = Phases -> Activation -> Activation
cvtPhases Phases
phases Activation
dflt
, inl_sat :: Maybe SumAlt
inl_sat = Maybe SumAlt
forall a. Maybe a
Nothing }
where
toSrcTxt :: Inline -> SourceText
toSrcTxt Inline
a = FastString -> SourceText
SourceText (FastString -> SourceText) -> FastString -> SourceText
forall a b. (a -> b) -> a -> b
$ Inline -> FastString
src Inline
a
; returnJustLA $ Hs.SigD noExtField $ InlineSig noAnn nm' ip }
cvtPragmaD (OpaqueP Name
nm)
= do { nm' <- Name -> CvtM (LocatedN RdrName)
vNameN Name
nm
; let ip = InlinePragma { inl_src :: SourceText
inl_src = SourceText
srcTxt
, inl_inline :: InlineSpec
inl_inline = SourceText -> InlineSpec
Opaque SourceText
srcTxt
, inl_rule :: RuleMatchInfo
inl_rule = RuleMatchInfo
Hs.FunLike
, inl_act :: Activation
inl_act = Activation
NeverActive
, inl_sat :: Maybe SumAlt
inl_sat = Maybe SumAlt
forall a. Maybe a
Nothing }
where
srcTxt :: SourceText
srcTxt = FastString -> SourceText
SourceText (FastString -> SourceText) -> FastString -> SourceText
forall a b. (a -> b) -> a -> b
$ String -> FastString
fsLit String
"{-# OPAQUE"
; returnJustLA $ Hs.SigD noExtField $ InlineSig noAnn nm' ip }
cvtPragmaD (SpecialiseP Name
nm Type
ty Maybe Inline
inline Phases
phases)
= do { nm' <- Name -> CvtM (LocatedN RdrName)
vNameN Name
nm
; ty' <- cvtSigType ty
; let src Inline
TH.NoInline = String -> FastString
fsLit String
"{-# SPECIALISE NOINLINE"
src Inline
TH.Inline = String -> FastString
fsLit String
"{-# SPECIALISE INLINE"
src Inline
TH.Inlinable = String -> FastString
fsLit String
"{-# SPECIALISE INLINE"
; let (inline', dflt, srcText) = case inline of
Just Inline
inline1 -> (Inline -> SourceText -> InlineSpec
cvtInline Inline
inline1 (Inline -> SourceText
toSrcTxt Inline
inline1), Inline -> Activation
dfltActivation Inline
inline1,
Inline -> SourceText
toSrcTxt Inline
inline1)
Maybe Inline
Nothing -> (InlineSpec
NoUserInlinePrag, Activation
AlwaysActive,
FastString -> SourceText
SourceText (FastString -> SourceText) -> FastString -> SourceText
forall a b. (a -> b) -> a -> b
$ String -> FastString
fsLit String
"{-# SPECIALISE")
where
toSrcTxt Inline
a = FastString -> SourceText
SourceText (FastString -> SourceText) -> FastString -> SourceText
forall a b. (a -> b) -> a -> b
$ Inline -> FastString
src Inline
a
; let ip = InlinePragma { inl_src :: SourceText
inl_src = SourceText
srcText
, inl_inline :: InlineSpec
inl_inline = InlineSpec
inline'
, inl_rule :: RuleMatchInfo
inl_rule = RuleMatchInfo
Hs.FunLike
, inl_act :: Activation
inl_act = Phases -> Activation -> Activation
cvtPhases Phases
phases Activation
dflt
, inl_sat :: Maybe SumAlt
inl_sat = Maybe SumAlt
forall a. Maybe a
Nothing }
; returnJustLA $ Hs.SigD noExtField $ SpecSig noAnn nm' [ty'] ip }
cvtPragmaD (SpecialiseInstP Type
ty)
= do { ty' <- Type -> CvtM (LHsSigType GhcPs)
cvtSigType Type
ty
; returnJustLA $ Hs.SigD noExtField $
SpecInstSig (noAnn, (SourceText $ fsLit "{-# SPECIALISE")) ty' }
cvtPragmaD (RuleP String
nm Maybe [TyVarBndr ()]
ty_bndrs [RuleBndr]
tm_bndrs Exp
lhs Exp
rhs Phases
phases)
= do { let nm' :: FastString
nm' = String -> FastString
mkFastString String
nm
; rd_name' <- FastString -> CvtM (LocatedAn NoEpAnns FastString)
forall ann e. NoAnn ann => e -> CvtM (LocatedAn ann e)
returnLA FastString
nm'
; let act = Phases -> Activation -> Activation
cvtPhases Phases
phases Activation
AlwaysActive
; ty_bndrs' <- traverse cvtTvs ty_bndrs
; tm_bndrs' <- mapM cvtRuleBndr tm_bndrs
; lhs' <- cvtl lhs
; rhs' <- cvtl rhs
; rule <- returnLA $
HsRule { rd_ext = (noAnn, quotedSourceText nm)
, rd_name = rd_name'
, rd_act = act
, rd_tyvs = ty_bndrs'
, rd_tmvs = tm_bndrs'
, rd_lhs = lhs'
, rd_rhs = rhs' }
; returnJustLA $ Hs.RuleD noExtField
$ HsRules { rds_ext = (noAnn, SourceText $ fsLit "{-# RULES")
, rds_rules = [rule] }
}
cvtPragmaD (AnnP AnnTarget
target Exp
exp)
= do { exp' <- Exp -> CvtM' ConversionFailReason (LHsExpr GhcPs)
cvtl Exp
exp
; target' <- case target of
AnnTarget
ModuleAnnotation -> AnnProvenance GhcPs
-> CvtM' ConversionFailReason (AnnProvenance GhcPs)
forall a. a -> CvtM' ConversionFailReason a
forall (m :: * -> *) a. Monad m => a -> m a
return AnnProvenance GhcPs
forall pass. AnnProvenance pass
ModuleAnnProvenance
TypeAnnotation Name
n -> do
n' <- Name -> CvtM RdrName
tconName Name
n
wrapParLA TypeAnnProvenance n'
ValueAnnotation Name
n -> do
n' <- Name -> CvtM RdrName
vcName Name
n
wrapParLA ValueAnnProvenance n'
; returnJustLA $ Hs.AnnD noExtField
$ HsAnnotation (noAnn, (SourceText $ fsLit "{-# ANN")) target' exp'
}
cvtPragmaD (LineP SumAlt
line String
file)
= do { SrcSpan -> CvtM ()
setL (SrcLoc -> SrcSpan
srcLocSpan (FastString -> SumAlt -> SumAlt -> SrcLoc
mkSrcLoc (String -> FastString
fsLit String
file) SumAlt
line SumAlt
1))
; Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs))
-> CvtM'
ConversionFailReason
(Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
forall a. a -> CvtM' ConversionFailReason a
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 { cls' <- (Name -> CvtM (LocatedN RdrName))
-> [Name] -> CvtM' ConversionFailReason [LocatedN RdrName]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Name -> CvtM (LocatedN RdrName)
cNameN [Name]
cls
; mty' <- traverse tconNameN mty
; returnJustLA $ Hs.SigD noExtField
$ CompleteMatchSig (noAnn, NoSourceText) cls' mty' }
cvtPragmaD (SCCP Name
nm Maybe String
str) = do
nm' <- Name -> CvtM (LocatedN RdrName)
vcNameN Name
nm
str' <- traverse (\String
s ->
StringLiteral
-> CvtM' ConversionFailReason (LocatedAn NoEpAnns StringLiteral)
forall ann e. NoAnn ann => e -> CvtM (LocatedAn ann e)
returnLA (StringLiteral
-> CvtM' ConversionFailReason (LocatedAn NoEpAnns StringLiteral))
-> StringLiteral
-> CvtM' ConversionFailReason (LocatedAn NoEpAnns StringLiteral)
forall a b. (a -> b) -> a -> b
$ SourceText
-> FastString -> Maybe NoCommentsLocation -> StringLiteral
StringLiteral SourceText
NoSourceText (String -> FastString
mkFastString String
s) Maybe NoCommentsLocation
forall a. Maybe a
Nothing) str
returnJustLA $ Hs.SigD noExtField
$ SCCFunSig (noAnn, SourceText $ fsLit "{-# SCC") nm' str'
dfltActivation :: TH.Inline -> Activation
dfltActivation :: Inline -> Activation
dfltActivation Inline
TH.NoInline = Activation
NeverActive
dfltActivation Inline
_ = Activation
AlwaysActive
cvtInline :: TH.Inline -> SourceText -> Hs.InlineSpec
cvtInline :: Inline -> SourceText -> InlineSpec
cvtInline Inline
TH.NoInline SourceText
srcText = SourceText -> InlineSpec
Hs.NoInline SourceText
srcText
cvtInline Inline
TH.Inline SourceText
srcText = SourceText -> InlineSpec
Hs.Inline SourceText
srcText
cvtInline Inline
TH.Inlinable SourceText
srcText = SourceText -> InlineSpec
Hs.Inlinable SourceText
srcText
cvtRuleMatch :: TH.RuleMatch -> RuleMatchInfo
cvtRuleMatch :: RuleMatch -> RuleMatchInfo
cvtRuleMatch RuleMatch
TH.ConLike = RuleMatchInfo
Hs.ConLike
cvtRuleMatch RuleMatch
TH.FunLike = RuleMatchInfo
Hs.FunLike
cvtPhases :: TH.Phases -> Activation -> Activation
cvtPhases :: Phases -> Activation -> Activation
cvtPhases Phases
AllPhases Activation
dflt = Activation
dflt
cvtPhases (FromPhase SumAlt
i) Activation
_ = SourceText -> SumAlt -> Activation
ActiveAfter SourceText
NoSourceText SumAlt
i
cvtPhases (BeforePhase SumAlt
i) Activation
_ = SourceText -> SumAlt -> Activation
ActiveBefore SourceText
NoSourceText SumAlt
i
cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.LRuleBndr GhcPs)
cvtRuleBndr :: RuleBndr -> CvtM (LRuleBndr GhcPs)
cvtRuleBndr (RuleVar Name
n)
= do { n' <- Name -> CvtM (LocatedN RdrName)
vNameN Name
n
; returnLA $ Hs.RuleBndr noAnn n' }
cvtRuleBndr (TypedRuleVar Name
n Type
ty)
= do { n' <- Name -> CvtM (LocatedN RdrName)
vNameN Name
n
; ty' <- cvtType ty
; returnLA $ Hs.RuleBndrSig noAnn n' $ mkHsPatSigType noAnn ty' }
cvtLocalDecs :: THDeclDescriptor -> [TH.Dec] -> CvtM (HsLocalBinds GhcPs)
cvtLocalDecs :: THDeclDescriptor -> [Dec] -> CvtM (HsLocalBinds GhcPs)
cvtLocalDecs THDeclDescriptor
declDescr [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 a. a -> CvtM' ConversionFailReason a
forall (m :: * -> *) a. Monad m => a -> m a
return (XEmptyLocalBinds GhcPs GhcPs -> HsLocalBinds GhcPs
forall idL idR. XEmptyLocalBinds idL idR -> HsLocalBindsLR idL idR
EmptyLocalBinds XEmptyLocalBinds GhcPs GhcPs
NoExtField
noExtField)
([], [Dec]
_) -> do
ds' <- [Dec] -> CvtM [LHsDecl GhcPs]
cvtDecs [Dec]
ds
let (binds, prob_sigs) = partitionWith is_bind ds'
let (sigs, bads) = partitionWith is_sig prob_sigs
for_ (nonEmpty bads) $ \ NonEmpty (GenLocated SrcSpanAnnA (HsDecl GhcPs))
bad_decls ->
ConversionFailReason -> CvtM' ConversionFailReason (ZonkAny 2)
forall a. ConversionFailReason -> CvtM a
failWith (THDeclDescriptor -> IllegalDecls -> ConversionFailReason
IllegalDeclaration THDeclDescriptor
declDescr (IllegalDecls -> ConversionFailReason)
-> IllegalDecls -> ConversionFailReason
forall a b. (a -> b) -> a -> b
$ NonEmpty (LHsDecl GhcPs) -> IllegalDecls
IllegalDecls NonEmpty (LHsDecl GhcPs)
NonEmpty (GenLocated SrcSpanAnnA (HsDecl GhcPs))
bad_decls)
return (HsValBinds noAnn (ValBinds NoAnnSortKey binds sigs))
([(String, Exp)]
ip_binds, []) -> do
binds <- ((String, Exp)
-> CvtM'
ConversionFailReason (GenLocated SrcSpanAnnA (IPBind GhcPs)))
-> [(String, Exp)]
-> CvtM'
ConversionFailReason [GenLocated SrcSpanAnnA (IPBind GhcPs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((String
-> Exp
-> CvtM'
ConversionFailReason (GenLocated SrcSpanAnnA (IPBind GhcPs)))
-> (String, Exp)
-> CvtM'
ConversionFailReason (GenLocated SrcSpanAnnA (IPBind GhcPs))
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> Exp -> CvtM (LIPBind GhcPs)
String
-> Exp
-> CvtM'
ConversionFailReason (GenLocated SrcSpanAnnA (IPBind GhcPs))
cvtImplicitParamBind) [(String, Exp)]
ip_binds
return (HsIPBinds noAnn (IPBinds noExtField binds))
(((String, Exp)
_:[(String, Exp)]
_), (Dec
_:[Dec]
_)) ->
ConversionFailReason -> CvtM (HsLocalBinds GhcPs)
forall a. ConversionFailReason -> CvtM a
failWith ConversionFailReason
ImplicitParamsWithOtherBinds
cvtClause :: HsMatchContextPs -> TH.Clause -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))
cvtClause :: HsMatchContextPs -> Clause -> CvtM (LMatch GhcPs (LHsExpr GhcPs))
cvtClause HsMatchContextPs
ctxt (Clause [Pat]
ps Body
body [Dec]
wheres)
= do { ps' <- [Pat] -> CvtM [LPat GhcPs]
forall (f :: * -> *).
Traversable f =>
f Pat -> CvtM (f (LPat GhcPs))
cvtPats [Pat]
ps
; let 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'
; g' <- cvtGuard body
; ds' <- cvtLocalDecs WhereClause wheres
; returnLA $ Hs.Match noExtField ctxt (noLocA pps) (GRHSs emptyComments g' ds') }
cvtImplicitParamBind :: String -> TH.Exp -> CvtM (LIPBind GhcPs)
cvtImplicitParamBind :: String -> Exp -> CvtM (LIPBind GhcPs)
cvtImplicitParamBind String
n Exp
e = do
n' <- CvtM HsIPName -> CvtM (GenLocated SrcSpan HsIPName)
forall a. CvtM a -> CvtM (Located a)
wrapL (String -> CvtM HsIPName
ipName String
n)
e' <- cvtl e
returnLA (IPBind noAnn (reLoc n') e')
cvtl :: TH.Exp -> CvtM (LHsExpr GhcPs)
cvtl :: Exp -> CvtM' ConversionFailReason (LHsExpr GhcPs)
cvtl Exp
e = CvtM (HsExpr GhcPs)
-> CvtM'
ConversionFailReason (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 { s' <- Name -> CvtM RdrName
vName Name
s; wrapParLA (HsVar noExtField) s' }
cvt (ConE Name
s) = do { s' <- Name -> CvtM RdrName
dName Name
s; wrapParLA (HsVar noExtField) 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 XOverLitE GhcPs
NoExtField
noExtField)
(PprPrec -> HsOverLit GhcPs -> Bool
forall x. PprPrec -> HsOverLit x -> Bool
hsOverLitNeedsParens PprPrec
appPrec)
| Bool
otherwise = (Lit -> CvtM (HsLit GhcPs))
-> (HsLit GhcPs -> HsExpr GhcPs)
-> (HsLit GhcPs -> Bool)
-> CvtM (HsExpr GhcPs)
forall (l :: * -> *).
(Lit -> CvtM (l GhcPs))
-> (l GhcPs -> HsExpr GhcPs)
-> (l GhcPs -> Bool)
-> CvtM (HsExpr GhcPs)
go Lit -> CvtM (HsLit GhcPs)
cvtLit (XLitE GhcPs -> HsLit GhcPs -> HsExpr GhcPs
forall p. XLitE p -> HsLit p -> HsExpr p
HsLit XLitE GhcPs
NoExtField
noExtField)
(PprPrec -> HsLit GhcPs -> Bool
forall (x :: Pass).
IsPass x =>
PprPrec -> HsLit (GhcPass 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' <- Lit -> CvtM (l GhcPs)
cvt_lit Lit
l
let e' = l GhcPs -> HsExpr GhcPs
mk_expr l GhcPs
l'
if is_compound_lit l' then wrapParLA gHsPar e' else pure e'
cvt (AppE Exp
e1 Exp
e2) = do { e1' <- PprPrec -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (p :: Pass).
IsPass p =>
PprPrec -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
parenthesizeHsExpr PprPrec
opPrec (GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> CvtM'
ConversionFailReason (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> CvtM'
ConversionFailReason (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> CvtM' ConversionFailReason (LHsExpr GhcPs)
cvtl Exp
e1
; e2' <- parenthesizeHsExpr appPrec <$> cvtl e2
; return $ HsApp noExtField e1' e2' }
cvt (AppTypeE Exp
e Type
t) = do { e' <- PprPrec -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (p :: Pass).
IsPass p =>
PprPrec -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
parenthesizeHsExpr PprPrec
opPrec (GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> CvtM'
ConversionFailReason (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> CvtM'
ConversionFailReason (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> CvtM' ConversionFailReason (LHsExpr GhcPs)
cvtl Exp
e
; t' <- parenthesizeHsType appPrec <$> cvtType t
; return $ HsAppType noAnn e'
$ mkHsWildCardBndrs t' }
cvt (LamE [] Exp
e) = Exp -> CvtM (HsExpr GhcPs)
cvt Exp
e
cvt (LamE [Pat]
ps Exp
e) = do { ps' <- [Pat] -> CvtM [LPat GhcPs]
forall (f :: * -> *).
Traversable f =>
f Pat -> CvtM (f (LPat GhcPs))
cvtPats [Pat]
ps; e' <- cvtl e
; let 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'
; th_origin <- getOrigin
; wrapParLA (HsLam noAnn LamSingle . mkMatchGroup th_origin)
[mkSimpleMatch (LamAlt LamSingle) (noLocA pats) e']}
cvt (LamCaseE [Match]
ms) = do { ms' <- (Match -> CvtM (LMatch GhcPs (LHsExpr GhcPs)))
-> [Match]
-> CvtM' ConversionFailReason [LMatch GhcPs (LHsExpr GhcPs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (HsMatchContextPs -> Match -> CvtM (LMatch GhcPs (LHsExpr GhcPs))
cvtMatch (HsMatchContextPs -> Match -> CvtM (LMatch GhcPs (LHsExpr GhcPs)))
-> HsMatchContextPs -> Match -> CvtM (LMatch GhcPs (LHsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ HsLamVariant -> HsMatchContextPs
forall fn. HsLamVariant -> HsMatchContext fn
LamAlt HsLamVariant
LamCase) [Match]
ms
; th_origin <- getOrigin
; wrapParLA (HsLam noAnn LamCase . mkMatchGroup th_origin) ms'
}
cvt (LamCasesE [Clause]
ms)
| [Clause] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Clause]
ms = ConversionFailReason -> CvtM (HsExpr GhcPs)
forall a. ConversionFailReason -> CvtM a
failWith ConversionFailReason
CasesExprWithoutAlts
| Bool
otherwise = do { ms' <- (Clause -> CvtM (LMatch GhcPs (LHsExpr GhcPs)))
-> [Clause]
-> CvtM' ConversionFailReason [LMatch GhcPs (LHsExpr GhcPs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (HsMatchContextPs -> Clause -> CvtM (LMatch GhcPs (LHsExpr GhcPs))
cvtClause (HsMatchContextPs -> Clause -> CvtM (LMatch GhcPs (LHsExpr GhcPs)))
-> HsMatchContextPs
-> Clause
-> CvtM (LMatch GhcPs (LHsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ HsLamVariant -> HsMatchContextPs
forall fn. HsLamVariant -> HsMatchContext fn
LamAlt HsLamVariant
LamCases) [Clause]
ms
; th_origin <- getOrigin
; wrapParLA (HsLam noAnn LamCases . mkMatchGroup th_origin) 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 SumAlt
alt SumAlt
arity) = do { e' <- Exp -> CvtM' ConversionFailReason (LHsExpr GhcPs)
cvtl Exp
e
; unboxedSumChecks alt arity
; return $ ExplicitSum noAnn alt arity e'}
cvt (CondE Exp
x Exp
y Exp
z) = do { x' <- Exp -> CvtM' ConversionFailReason (LHsExpr GhcPs)
cvtl Exp
x; y' <- cvtl y; z' <- cvtl z;
; return $ mkHsIf x' y' z' noAnn }
cvt (MultiIfE [(Guard, Exp)]
alts)
| [(Guard, Exp)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Guard, Exp)]
alts = ConversionFailReason -> CvtM (HsExpr GhcPs)
forall a. ConversionFailReason -> CvtM a
failWith ConversionFailReason
MultiWayIfWithoutAlts
| Bool
otherwise = do { alts' <- ((Guard, Exp)
-> CvtM'
ConversionFailReason
(GenLocated
EpAnnCO (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))))
-> [(Guard, Exp)]
-> CvtM'
ConversionFailReason
[GenLocated
EpAnnCO (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Guard, Exp) -> CvtM (LGRHS GhcPs (LHsExpr GhcPs))
(Guard, Exp)
-> CvtM'
ConversionFailReason
(GenLocated
EpAnnCO (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
cvtpair [(Guard, Exp)]
alts
; return $ HsMultiIf noAnn alts' }
cvt (LetE [Dec]
ds Exp
e) = do { ds' <- THDeclDescriptor -> [Dec] -> CvtM (HsLocalBinds GhcPs)
cvtLocalDecs THDeclDescriptor
LetExpression [Dec]
ds
; e' <- cvtl e; return $ HsLet noAnn ds' e'}
cvt (CaseE Exp
e [Match]
ms) = do { e' <- Exp -> CvtM' ConversionFailReason (LHsExpr GhcPs)
cvtl Exp
e; ms' <- mapM (cvtMatch CaseAlt) ms
; th_origin <- getOrigin
; wrapParLA (HsCase noAnn e' . mkMatchGroup th_origin) ms' }
cvt (DoE Maybe ModName
m [Stmt]
ss) = HsDoFlavour -> [Stmt] -> CvtM (HsExpr GhcPs)
cvtHsDo (Maybe ModuleName -> HsDoFlavour
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) = HsDoFlavour -> [Stmt] -> CvtM (HsExpr GhcPs)
cvtHsDo (Maybe ModuleName -> HsDoFlavour
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) = HsDoFlavour -> [Stmt] -> CvtM (HsExpr GhcPs)
cvtHsDo HsDoFlavour
ListComp [Stmt]
ss
cvt (ArithSeqE Range
dd) = do { dd' <- Range -> CvtM (ArithSeqInfo GhcPs)
cvtDD Range
dd
; return $ ArithSeq noAnn Nothing dd' }
cvt (ListE [Exp]
xs)
| Just String
s <- [Exp] -> Maybe String
allCharLs [Exp]
xs = do { l' <- Lit -> CvtM (HsLit GhcPs)
cvtLit (String -> Lit
StringL String
s)
; return (HsLit noExtField l') }
| Bool
otherwise = do { xs' <- (Exp
-> CvtM'
ConversionFailReason (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> [Exp]
-> CvtM'
ConversionFailReason [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Exp -> CvtM' ConversionFailReason (LHsExpr GhcPs)
Exp
-> CvtM'
ConversionFailReason (GenLocated SrcSpanAnnA (HsExpr GhcPs))
cvtl [Exp]
xs
; return $ ExplicitList noAnn xs'
}
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 { x' <- Exp -> CvtM' ConversionFailReason (LHsExpr GhcPs)
cvtl Exp
x
; s' <- cvtl s
; y' <- cvtl y
; let px = PprPrec -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (p :: Pass).
IsPass p =>
PprPrec -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
parenthesizeHsExpr PprPrec
opPrec LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
x'
py = PprPrec -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (p :: Pass).
IsPass p =>
PprPrec -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
parenthesizeHsExpr PprPrec
opPrec LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
y'
; wrapParLA gHsPar
$ OpApp noExtField px s' py }
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 { s' <- Exp -> CvtM' ConversionFailReason (LHsExpr GhcPs)
cvtl Exp
s; y' <- cvtl y
; wrapParLA gHsPar $
SectionR noExtField s' y' }
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 { x' <- Exp -> CvtM' ConversionFailReason (LHsExpr GhcPs)
cvtl Exp
x; s' <- cvtl s
; wrapParLA gHsPar $
SectionL noExtField x' 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 { s' <- Exp -> CvtM' ConversionFailReason (LHsExpr GhcPs)
cvtl Exp
s
; return $ gHsPar s' }
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 { x' <- Exp -> CvtM' ConversionFailReason (LHsExpr GhcPs)
cvtl Exp
x
; let 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 LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
x'
; cvtOpApp x'' s y }
cvt (ParensE Exp
e) = do { e' <- Exp -> CvtM' ConversionFailReason (LHsExpr GhcPs)
cvtl Exp
e; return $ gHsPar e' }
cvt (SigE Exp
e Type
t) = do { e' <- Exp -> CvtM' ConversionFailReason (LHsExpr GhcPs)
cvtl Exp
e; t' <- cvtSigType t
; let pe = PprPrec -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (p :: Pass).
IsPass p =>
PprPrec -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
parenthesizeHsExpr PprPrec
sigPrec LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
e'
; return $ ExprWithTySig noAnn pe (mkHsWildCardBndrs t') }
cvt (RecConE Name
c [FieldExp]
flds) = do { c' <- Name -> CvtM (LocatedN RdrName)
cNameN Name
c
; flds' <- mapM (cvtFld (wrapParLA mkFieldOcc)) flds
; return $ mkRdrRecordCon c' (HsRecFields noExtField flds' Nothing) noAnn }
cvt (RecUpdE Exp
e [FieldExp]
flds) = do { e' <- Exp -> CvtM' ConversionFailReason (LHsExpr GhcPs)
cvtl Exp
e
; flds'
<- mapM (cvtFld (wrapParLA mkFieldOcc))
flds
; return $ RecordUpd noAnn e' $
RegularRecUpdFields
{ xRecUpdFields = noExtField
, recUpdFields = flds' } }
cvt (StaticE Exp
e) = (LHsExpr GhcPs -> HsExpr GhcPs)
-> CvtM' ConversionFailReason (LHsExpr GhcPs)
-> CvtM (HsExpr GhcPs)
forall a b.
(a -> b)
-> CvtM' ConversionFailReason a -> CvtM' ConversionFailReason b
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
EpToken "static"
forall a. NoAnn a => a
noAnn) (CvtM' ConversionFailReason (LHsExpr GhcPs) -> CvtM (HsExpr GhcPs))
-> CvtM' ConversionFailReason (LHsExpr GhcPs)
-> CvtM (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ Exp -> CvtM' ConversionFailReason (LHsExpr GhcPs)
cvtl Exp
e
cvt (UnboundVarE Name
s) = do
{ s' <- Name -> CvtM RdrName
vcName Name
s
; wrapParLA (HsVar noExtField) s' }
cvt (LabelE String
s) = HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall a. a -> CvtM' ConversionFailReason a
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 -> FastString -> HsExpr GhcPs
forall p. XOverLabel p -> FastString -> HsExpr p
HsOverLabel XOverLabel GhcPs
SourceText
NoSourceText (String -> FastString
fsLit String
s)
cvt (ImplicitParamVarE String
n) = do { n' <- String -> CvtM HsIPName
ipName String
n; return $ HsIPVar noExtField n' }
cvt (GetFieldE Exp
exp String
f) = do { e' <- Exp -> CvtM' ConversionFailReason (LHsExpr GhcPs)
cvtl Exp
exp
; return $ HsGetField noExtField e'
(L noSrcSpanA (DotFieldOcc noAnn (L noSrcSpanA (FieldLabelString (fsLit f))))) }
cvt (ProjectionE NonEmpty String
xs) = HsExpr GhcPs -> CvtM (HsExpr GhcPs)
forall a. a -> CvtM' ConversionFailReason a
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 (DotFieldOcc GhcPs) -> HsExpr GhcPs
forall p. XProjection p -> NonEmpty (DotFieldOcc p) -> HsExpr p
HsProjection XProjection GhcPs
AnnProjection
forall a. NoAnn a => a
noAnn (NonEmpty (DotFieldOcc GhcPs) -> HsExpr GhcPs)
-> NonEmpty (DotFieldOcc GhcPs) -> HsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ (String -> DotFieldOcc GhcPs)
-> NonEmpty String -> NonEmpty (DotFieldOcc GhcPs)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
(XCDotFieldOcc GhcPs
-> XRec GhcPs FieldLabelString -> DotFieldOcc GhcPs
forall p.
XCDotFieldOcc p -> XRec p FieldLabelString -> DotFieldOcc p
DotFieldOcc XCDotFieldOcc GhcPs
AnnFieldLabel
forall a. NoAnn a => a
noAnn (GenLocated SrcSpanAnnN FieldLabelString -> DotFieldOcc GhcPs)
-> (String -> GenLocated SrcSpanAnnN FieldLabelString)
-> String
-> DotFieldOcc GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpanAnnN
-> FieldLabelString -> GenLocated SrcSpanAnnN FieldLabelString
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
forall e. HasAnnotation e => e
noSrcSpanA (FieldLabelString -> GenLocated SrcSpanAnnN FieldLabelString)
-> (String -> FieldLabelString)
-> String
-> GenLocated SrcSpanAnnN FieldLabelString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FastString -> FieldLabelString
FieldLabelString (FastString -> FieldLabelString)
-> (String -> FastString) -> String -> FieldLabelString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> FastString
fsLit) NonEmpty String
xs
cvt (TypedSpliceE Exp
e) = do { e' <- PprPrec -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (p :: Pass).
IsPass p =>
PprPrec -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
parenthesizeHsExpr PprPrec
appPrec (GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> CvtM'
ConversionFailReason (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> CvtM'
ConversionFailReason (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> CvtM' ConversionFailReason (LHsExpr GhcPs)
cvtl Exp
e
; return $ HsTypedSplice noAnn e' }
cvt (TypedBracketE Exp
e) = do { e' <- Exp -> CvtM' ConversionFailReason (LHsExpr GhcPs)
cvtl Exp
e
; return $ HsTypedBracket noAnn e' }
cvt (TypeE Type
t) = do { t' <- Type -> CvtM' ConversionFailReason (LHsType GhcPs)
cvtType Type
t
; return $ HsEmbTy noAnn (mkHsWildCardBndrs t') }
cvt (ConstrainedE [Exp]
ctx Exp
body) = do { ctx' <- (Exp
-> CvtM'
ConversionFailReason (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> [Exp]
-> CvtM'
ConversionFailReason [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Exp -> CvtM' ConversionFailReason (LHsExpr GhcPs)
Exp
-> CvtM'
ConversionFailReason (GenLocated SrcSpanAnnA (HsExpr GhcPs))
cvtl [Exp]
ctx
; body' <- cvtl body
; return $ HsQual noExtField (L noAnn ctx') body' }
cvt (ForallE [TyVarBndr Specificity]
tvs Exp
body) =
do { tvs' <- [TyVarBndr Specificity] -> CvtM [LHsTyVarBndr Specificity GhcPs]
forall flag flag'.
CvtFlag flag flag' =>
[TyVarBndr flag] -> CvtM [LHsTyVarBndr flag' GhcPs]
cvtTvs [TyVarBndr Specificity]
tvs
; body' <- cvtl body
; let tele = NameSpace -> HsForAllTelescope GhcPs -> HsForAllTelescope GhcPs
setTelescopeBndrsNameSpace NameSpace
varName (HsForAllTelescope GhcPs -> HsForAllTelescope GhcPs)
-> HsForAllTelescope GhcPs -> HsForAllTelescope GhcPs
forall a b. (a -> b) -> a -> b
$
EpAnnForallInvis
-> [LHsTyVarBndr Specificity GhcPs] -> HsForAllTelescope GhcPs
forall (p :: Pass).
EpAnnForallInvis
-> [LHsTyVarBndr Specificity (GhcPass p)]
-> HsForAllTelescope (GhcPass p)
mkHsForAllInvisTele EpAnnForallInvis
forall a. NoAnn a => a
noAnn [LHsTyVarBndr Specificity GhcPs]
[GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)]
tvs'
; return $ HsForAll noExtField tele body' }
cvt (ForallVisE [TyVarBndr ()]
tvs Exp
body) =
do { tvs' <- [TyVarBndr ()] -> CvtM [LHsTyVarBndr () GhcPs]
forall flag flag'.
CvtFlag flag flag' =>
[TyVarBndr flag] -> CvtM [LHsTyVarBndr flag' GhcPs]
cvtTvs [TyVarBndr ()]
tvs
; body' <- cvtl body
; let tele = NameSpace -> HsForAllTelescope GhcPs -> HsForAllTelescope GhcPs
setTelescopeBndrsNameSpace NameSpace
varName (HsForAllTelescope GhcPs -> HsForAllTelescope GhcPs)
-> HsForAllTelescope GhcPs -> HsForAllTelescope GhcPs
forall a b. (a -> b) -> a -> b
$
EpAnnForallVis
-> [LHsTyVarBndr () GhcPs] -> HsForAllTelescope GhcPs
forall (p :: Pass).
EpAnnForallVis
-> [LHsTyVarBndr () (GhcPass p)] -> HsForAllTelescope (GhcPass p)
mkHsForAllVisTele EpAnnForallVis
forall a. NoAnn a => a
noAnn [LHsTyVarBndr () GhcPs]
[GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)]
tvs'
; return $ HsForAll noExtField tele body' }
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 = ConversionFailReason -> CvtM a
forall a. ConversionFailReason -> CvtM a
failWith ConversionFailReason
NonVarInInfixExpr
cvtFld :: (RdrName -> CvtM t) -> (TH.Name, TH.Exp)
-> CvtM (LHsFieldBind GhcPs (LocatedA t) (LHsExpr GhcPs))
cvtFld :: forall t.
(RdrName -> CvtM t)
-> FieldExp
-> CvtM (LHsFieldBind GhcPs (LocatedA t) (LHsExpr GhcPs))
cvtFld RdrName -> CvtM t
f (Name
v,Exp
e)
= do { v' <- Name -> CvtM (LocatedA RdrName)
vNameL Name
v
; lhs' <- traverse f v'
; e' <- cvtl e
; returnLA $ HsFieldBind { hfbAnn = noAnn
, hfbLHS = la2la lhs'
, hfbRHS = e'
, hfbPun = False} }
cvtDD :: Range -> CvtM (ArithSeqInfo GhcPs)
cvtDD :: Range -> CvtM (ArithSeqInfo GhcPs)
cvtDD (FromR Exp
x) = do { x' <- Exp -> CvtM' ConversionFailReason (LHsExpr GhcPs)
cvtl Exp
x; return $ From x' }
cvtDD (FromThenR Exp
x Exp
y) = do { x' <- Exp -> CvtM' ConversionFailReason (LHsExpr GhcPs)
cvtl Exp
x; y' <- cvtl y; return $ FromThen x' y' }
cvtDD (FromToR Exp
x Exp
y) = do { x' <- Exp -> CvtM' ConversionFailReason (LHsExpr GhcPs)
cvtl Exp
x; y' <- cvtl y; return $ FromTo x' y' }
cvtDD (FromThenToR Exp
x Exp
y Exp
z) = do { x' <- Exp -> CvtM' ConversionFailReason (LHsExpr GhcPs)
cvtl Exp
x; y' <- cvtl y; z' <- cvtl z; return $ FromThenTo x' y' 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' ConversionFailReason (HsTupArg GhcPs)
cvtl_maybe Maybe Exp
Nothing = HsTupArg GhcPs -> CvtM' ConversionFailReason (HsTupArg GhcPs)
forall a. a -> CvtM' ConversionFailReason a
forall (m :: * -> *) a. Monad m => a -> m a
return (EpAnn Bool -> HsTupArg GhcPs
missingTupArg EpAnn Bool
forall a. NoAnn a => a
noAnn)
cvtl_maybe (Just Exp
e) = (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> HsTupArg GhcPs)
-> CvtM'
ConversionFailReason (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> CvtM' ConversionFailReason (HsTupArg GhcPs)
forall a b.
(a -> b)
-> CvtM' ConversionFailReason a -> CvtM' ConversionFailReason b
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
NoExtField
noExtField) (Exp -> CvtM' ConversionFailReason (LHsExpr GhcPs)
cvtl Exp
e)
; es' <- (Maybe Exp -> CvtM' ConversionFailReason (HsTupArg GhcPs))
-> [Maybe Exp] -> CvtM' ConversionFailReason [HsTupArg GhcPs]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Maybe Exp -> CvtM' ConversionFailReason (HsTupArg GhcPs)
cvtl_maybe [Maybe Exp]
es
; return $ ExplicitTuple
noAnn
es'
boxity }
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 { l <- CvtM (HsExpr GhcPs)
-> CvtM'
ConversionFailReason (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. CvtM a -> CvtM (LocatedA a)
wrapLA (CvtM (HsExpr GhcPs)
-> CvtM'
ConversionFailReason (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> CvtM (HsExpr GhcPs)
-> CvtM'
ConversionFailReason (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
; cvtOpApp l op2 z }
cvtOpApp LHsExpr GhcPs
x Exp
op Exp
y
= do { op' <- Exp -> CvtM' ConversionFailReason (LHsExpr GhcPs)
cvtl Exp
op
; y' <- cvtl y
; return (OpApp noExtField x op' y') }
cvtHsDo :: HsDoFlavour -> [TH.Stmt] -> CvtM (HsExpr GhcPs)
cvtHsDo :: HsDoFlavour -> [Stmt] -> CvtM (HsExpr GhcPs)
cvtHsDo HsDoFlavour
do_or_lc [Stmt]
stmts = case [Stmt] -> Maybe (NonEmpty Stmt)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [Stmt]
stmts of
Maybe (NonEmpty Stmt)
Nothing -> ConversionFailReason -> CvtM (HsExpr GhcPs)
forall a. ConversionFailReason -> CvtM a
failWith ConversionFailReason
EmptyStmtListInDoBlock
Just NonEmpty Stmt
stmts -> do
{ stmts' <- (Stmt
-> CvtM'
ConversionFailReason
(GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))))
-> NonEmpty Stmt
-> CvtM'
ConversionFailReason
(NonEmpty
(GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NonEmpty a -> f (NonEmpty b)
traverse Stmt -> CvtM (LStmt GhcPs (LHsExpr GhcPs))
Stmt
-> CvtM'
ConversionFailReason
(GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
cvtStmt NonEmpty Stmt
stmts
; let stmts'' = NonEmpty
(GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> [GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall a. NonEmpty a -> [a]
NE.init NonEmpty
(GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
stmts'
last' = NonEmpty
(GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. NonEmpty a -> a
NE.last NonEmpty
(GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
stmts'
; last'' <- case 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'
ConversionFailReason
(GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
forall a. a -> CvtM' ConversionFailReason a
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)))
_ -> ConversionFailReason
-> CvtM'
ConversionFailReason
(GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
forall a. ConversionFailReason -> CvtM a
failWith (GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> ConversionFailReason
bad_last GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
last')
; wrapParLA (HsDo noAnn do_or_lc) (stmts'' ++ [last'']) }
where
bad_last :: GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> ConversionFailReason
bad_last GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
stmt = HsDoFlavour -> LStmt GhcPs (LHsExpr GhcPs) -> ConversionFailReason
IllegalLastStatement HsDoFlavour
do_or_lc LStmt GhcPs (LHsExpr GhcPs)
GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
stmt
cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt GhcPs (LHsExpr GhcPs)]
cvtStmts :: [Stmt] -> CvtM [LStmt GhcPs (LHsExpr GhcPs)]
cvtStmts = (Stmt
-> CvtM'
ConversionFailReason
(GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))))
-> [Stmt]
-> CvtM'
ConversionFailReason
[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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Stmt -> CvtM (LStmt GhcPs (LHsExpr GhcPs))
Stmt
-> CvtM'
ConversionFailReason
(GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
cvtStmt
cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt GhcPs (LHsExpr GhcPs))
cvtStmt :: Stmt -> CvtM (LStmt GhcPs (LHsExpr GhcPs))
cvtStmt (NoBindS Exp
e) = do { e' <- Exp -> CvtM' ConversionFailReason (LHsExpr GhcPs)
cvtl Exp
e; returnLA $ mkBodyStmt e' }
cvtStmt (TH.BindS Pat
p Exp
e) = do { p' <- Pat -> CvtM' ConversionFailReason (LPat GhcPs)
cvtPat Pat
p; e' <- cvtl e; returnLA $ mkPsBindStmt noAnn p' e' }
cvtStmt (TH.LetS [Dec]
ds) = do { ds' <- THDeclDescriptor -> [Dec] -> CvtM (HsLocalBinds GhcPs)
cvtLocalDecs THDeclDescriptor
LetBinding [Dec]
ds
; returnLA $ LetStmt noAnn ds' }
cvtStmt (TH.ParS [[Stmt]]
dss) = do { dss' <- ([Stmt] -> CvtM' ConversionFailReason (ParStmtBlock GhcPs GhcPs))
-> [[Stmt]]
-> CvtM' ConversionFailReason [ParStmtBlock GhcPs GhcPs]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM [Stmt] -> CvtM' ConversionFailReason (ParStmtBlock GhcPs GhcPs)
forall {p :: Pass} {idR}.
(SyntaxExprGhc p ~ SyntaxExpr idR,
XParStmtBlock GhcPs idR ~ NoExtField, IsPass p) =>
[Stmt] -> CvtM' ConversionFailReason (ParStmtBlock GhcPs idR)
cvt_one [[Stmt]]
dss
; returnLA $ ParStmt noExtField dss' noExpr noSyntaxExpr }
where
cvt_one :: [Stmt] -> CvtM' ConversionFailReason (ParStmtBlock GhcPs idR)
cvt_one [Stmt]
ds = do { ds' <- [Stmt] -> CvtM [LStmt GhcPs (LHsExpr GhcPs)]
cvtStmts [Stmt]
ds
; return (ParStmtBlock noExtField ds' undefined noSyntaxExpr) }
cvtStmt (TH.RecS [Stmt]
ss) = do { ss' <- (Stmt
-> CvtM'
ConversionFailReason
(GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))))
-> [Stmt]
-> CvtM'
ConversionFailReason
[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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Stmt -> CvtM (LStmt GhcPs (LHsExpr GhcPs))
Stmt
-> CvtM'
ConversionFailReason
(GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
cvtStmt [Stmt]
ss
; rec_stmt <- wrapParLA (mkRecStmt noAnn) ss'
; returnLA rec_stmt }
cvtMatch :: HsMatchContextPs -> TH.Match -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))
cvtMatch :: HsMatchContextPs -> Match -> CvtM (LMatch GhcPs (LHsExpr GhcPs))
cvtMatch HsMatchContextPs
ctxt (TH.Match Pat
p Body
body [Dec]
decs)
= do { p' <- Pat -> CvtM' ConversionFailReason (LPat GhcPs)
cvtPat Pat
p
; let 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 (LPat GhcPs -> Pat GhcPs
forall (p :: Pass). IsPass p => LPat (GhcPass p) -> Pat (GhcPass p)
gParPat LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
p')
GenLocated SrcSpanAnnA (Pat GhcPs)
_ -> GenLocated SrcSpanAnnA (Pat GhcPs)
p'
; g' <- cvtGuard body
; decs' <- cvtLocalDecs WhereClause decs
; returnLA $ Hs.Match noExtField ctxt (noLocA [lp]) (GRHSs emptyComments g' decs') }
cvtGuard :: TH.Body -> CvtM [LGRHS GhcPs (LHsExpr GhcPs)]
cvtGuard :: Body -> CvtM [LGRHS GhcPs (LHsExpr GhcPs)]
cvtGuard (GuardedB [(Guard, Exp)]
pairs) = ((Guard, Exp)
-> CvtM'
ConversionFailReason
(GenLocated
EpAnnCO (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))))
-> [(Guard, Exp)]
-> CvtM'
ConversionFailReason
[GenLocated
EpAnnCO (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Guard, Exp) -> CvtM (LGRHS GhcPs (LHsExpr GhcPs))
(Guard, Exp)
-> CvtM'
ConversionFailReason
(GenLocated
EpAnnCO (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
cvtpair [(Guard, Exp)]
pairs
cvtGuard (NormalB Exp
e) = do { e' <- Exp -> CvtM' ConversionFailReason (LHsExpr GhcPs)
cvtl Exp
e
; g' <- returnLA $ GRHS noAnn [] e'; return [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 { ge' <- Exp -> CvtM' ConversionFailReason (LHsExpr GhcPs)
cvtl Exp
ge; rhs' <- cvtl rhs
; g' <- returnLA $ mkBodyStmt ge'
; returnLA $ GRHS noAnn [g'] rhs' }
cvtpair (PatG [Stmt]
gs,Exp
rhs) = do { gs' <- [Stmt] -> CvtM [LStmt GhcPs (LHsExpr GhcPs)]
cvtStmts [Stmt]
gs; rhs' <- cvtl rhs
; returnLA $ GRHS noAnn gs' 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 a. a -> CvtM' ConversionFailReason a
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 a. a -> CvtM' ConversionFailReason a
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' :: FastString
s' = String -> FastString
mkFastString String
s }
; FastString -> CvtM ()
forall a. a -> CvtM ()
force FastString
s'
; HsOverLit GhcPs -> CvtM (HsOverLit GhcPs)
forall a. a -> CvtM' ConversionFailReason a
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 -> FastString -> HsOverLit GhcPs
mkHsIsString (String -> SourceText
quotedSourceText String
s) FastString
s'
}
cvtOverLit Lit
_ = String -> CvtM (HsOverLit GhcPs)
forall a. HasCallStack => String -> a
panic String
"Convert.cvtOverLit: Unexpected overloaded literal"
allCharLs :: [TH.Exp] -> Maybe String
allCharLs :: [Exp] -> Maybe String
allCharLs [Exp]
xs
= case [Exp]
xs of
LitE (CharL Char
c) : [Exp]
ys -> String -> [Exp] -> Maybe String
go [Char
c] [Exp]
ys
[Exp]
_ -> 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 a. a -> CvtM' ConversionFailReason a
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 XHsIntPrim GhcPs
SourceText
NoSourceText Integer
i }
cvtLit (WordPrimL Integer
w) = do { Integer -> CvtM ()
forall a. a -> CvtM ()
force Integer
w; HsLit GhcPs -> CvtM (HsLit GhcPs)
forall a. a -> CvtM' ConversionFailReason a
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 XHsWordPrim GhcPs
SourceText
NoSourceText Integer
w }
cvtLit (FloatPrimL Rational
f)
= do { Rational -> CvtM ()
forall a. a -> CvtM ()
force Rational
f; HsLit GhcPs -> CvtM (HsLit GhcPs)
forall a. a -> CvtM' ConversionFailReason a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsLit GhcPs -> CvtM (HsLit GhcPs))
-> HsLit GhcPs -> CvtM (HsLit GhcPs)
forall a b. (a -> b) -> a -> b
$ XHsFloatPrim GhcPs -> FractionalLit -> HsLit GhcPs
forall x. XHsFloatPrim x -> FractionalLit -> HsLit x
HsFloatPrim XHsFloatPrim GhcPs
NoExtField
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 a. a -> CvtM' ConversionFailReason a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsLit GhcPs -> CvtM (HsLit GhcPs))
-> HsLit GhcPs -> CvtM (HsLit GhcPs)
forall a b. (a -> b) -> a -> b
$ XHsDoublePrim GhcPs -> FractionalLit -> HsLit GhcPs
forall x. XHsDoublePrim x -> FractionalLit -> HsLit x
HsDoublePrim XHsDoublePrim GhcPs
NoExtField
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 a. a -> CvtM' ConversionFailReason a
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 XHsChar GhcPs
SourceText
NoSourceText Char
c }
cvtLit (CharPrimL Char
c) = do { Char -> CvtM ()
forall a. a -> CvtM ()
force Char
c; HsLit GhcPs -> CvtM (HsLit GhcPs)
forall a. a -> CvtM' ConversionFailReason a
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 XHsCharPrim GhcPs
SourceText
NoSourceText Char
c }
cvtLit (StringL String
s) = do { let { s' :: FastString
s' = String -> FastString
mkFastString String
s }
; FastString -> CvtM ()
forall a. a -> CvtM ()
force FastString
s'
; HsLit GhcPs -> CvtM (HsLit GhcPs)
forall a. a -> CvtM' ConversionFailReason a
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 -> FastString -> HsLit GhcPs
forall x. XHsString x -> FastString -> HsLit x
HsString (String -> SourceText
quotedSourceText String
s) FastString
s' }
cvtLit (StringPrimL [Word8]
s) = do { let { !s' :: ByteString
s' = [Word8] -> ByteString
BS.pack [Word8]
s }
; HsLit GhcPs -> CvtM (HsLit GhcPs)
forall a. a -> CvtM' ConversionFailReason a
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 XHsStringPrim GhcPs
SourceText
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 -> SumAlt -> Ptr CChar
forall a b. Ptr a -> SumAlt -> Ptr b
`plusPtr` Word -> SumAlt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
off, Word -> SumAlt
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 a. a -> CvtM' ConversionFailReason a
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 XHsStringPrim GhcPs
SourceText
NoSourceText ByteString
bs
cvtLit Lit
_ = String -> CvtM (HsLit GhcPs)
forall a. HasCallStack => String -> a
panic String
"Convert.cvtLit: Unexpected literal"
quotedSourceText :: String -> SourceText
quotedSourceText :: String -> SourceText
quotedSourceText String
s = FastString -> SourceText
SourceText (FastString -> SourceText) -> FastString -> SourceText
forall a b. (a -> b) -> a -> b
$ String -> FastString
fsLit (String -> FastString) -> String -> FastString
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 :: Traversable f => f (TH.Pat) -> CvtM (f (Hs.LPat GhcPs))
cvtPats :: forall (f :: * -> *).
Traversable f =>
f Pat -> CvtM (f (LPat GhcPs))
cvtPats f Pat
pats = (Pat
-> CvtM' ConversionFailReason (GenLocated SrcSpanAnnA (Pat GhcPs)))
-> f Pat
-> CvtM'
ConversionFailReason (f (GenLocated SrcSpanAnnA (Pat GhcPs)))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> f a -> m (f b)
mapM Pat -> CvtM' ConversionFailReason (LPat GhcPs)
Pat
-> CvtM' ConversionFailReason (GenLocated SrcSpanAnnA (Pat GhcPs))
cvtPat f Pat
pats
{-# SPECIALISE cvtPats :: [TH.Pat] -> CvtM [Hs.LPat GhcPs] #-}
{-# SPECIALISE cvtPats :: NonEmpty (TH.Pat) -> CvtM (NonEmpty (Hs.LPat GhcPs)) #-}
cvtPat :: TH.Pat -> CvtM (Hs.LPat GhcPs)
cvtPat :: Pat -> CvtM' ConversionFailReason (LPat GhcPs)
cvtPat Pat
pat = CvtM (Pat GhcPs)
-> CvtM' ConversionFailReason (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 { l' <- Lit -> CvtM (HsOverLit GhcPs)
cvtOverLit Lit
l
; l'' <- returnLA l'
; return (mkNPat l'' Nothing noAnn) }
| Bool
otherwise = do { l' <- Lit -> CvtM (HsLit GhcPs)
cvtLit Lit
l; return $ Hs.LitPat noExtField l' }
cvtp (TH.VarP Name
s) = do { s' <- Name -> CvtM RdrName
vName Name
s
; wrapParLA (Hs.VarPat noExtField) s' }
cvtp (TupP [Pat]
ps) = do { ps' <- [Pat] -> CvtM [LPat GhcPs]
forall (f :: * -> *).
Traversable f =>
f Pat -> CvtM (f (LPat GhcPs))
cvtPats [Pat]
ps
; return $ TuplePat noAnn ps' Boxed }
cvtp (UnboxedTupP [Pat]
ps) = do { ps' <- [Pat] -> CvtM [LPat GhcPs]
forall (f :: * -> *).
Traversable f =>
f Pat -> CvtM (f (LPat GhcPs))
cvtPats [Pat]
ps
; return $ TuplePat noAnn ps' Unboxed }
cvtp (UnboxedSumP Pat
p SumAlt
alt SumAlt
arity)
= do { p' <- Pat -> CvtM' ConversionFailReason (LPat GhcPs)
cvtPat Pat
p
; unboxedSumChecks alt arity
; return $ SumPat noAnn p' alt arity }
cvtp (ConP Name
s [Type]
ts [Pat]
ps) = do { s' <- Name -> CvtM (LocatedN RdrName)
dNameN Name
s
; ps' <- cvtPats ps
; ts' <- mapM cvtType ts
; let 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'
pts = (GenLocated SrcSpanAnnA (HsType GhcPs) -> HsConPatTyArg GhcPs)
-> [GenLocated SrcSpanAnnA (HsType GhcPs)] -> [HsConPatTyArg GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map (\GenLocated SrcSpanAnnA (HsType GhcPs)
t -> XConPatTyArg GhcPs -> HsTyPat GhcPs -> HsConPatTyArg GhcPs
forall p. XConPatTyArg p -> HsTyPat p -> HsConPatTyArg p
HsConPatTyArg EpToken "@"
XConPatTyArg GhcPs
forall a. NoAnn a => a
noAnn (LHsType GhcPs -> HsTyPat GhcPs
mkHsTyPat LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
t)) [GenLocated SrcSpanAnnA (HsType GhcPs)]
ts'
; return $ ConPat
{ pat_con_ext = noAnn
, pat_con = s'
, pat_args = PrefixCon pts pps
}
}
cvtp (InfixP Pat
p1 Name
s Pat
p2) = do { s' <- Name -> CvtM (LocatedN RdrName)
dNameN Name
s; p1' <- cvtPat p1; p2' <- cvtPat p2
; wrapParLA gParPat $
ConPat
{ pat_con_ext = noAnn
, pat_con = s'
, pat_args = InfixCon
(parenthesizePat opPrec p1')
(parenthesizePat opPrec p2')
}
}
cvtp (UInfixP Pat
p1 Name
s Pat
p2) = do { p1' <- Pat -> CvtM' ConversionFailReason (LPat GhcPs)
cvtPat Pat
p1; cvtOpAppP p1' s p2 }
cvtp (ParensP Pat
p) = do { p' <- Pat -> CvtM' ConversionFailReason (LPat GhcPs)
cvtPat Pat
p;
; case unLoc p' of
ParPat {} -> Pat GhcPs -> CvtM (Pat GhcPs)
forall a. a -> CvtM' ConversionFailReason a
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 a. a -> CvtM' ConversionFailReason a
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
$ LPat GhcPs -> Pat GhcPs
forall (p :: Pass). IsPass p => LPat (GhcPass p) -> Pat (GhcPass p)
gParPat LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
p' }
cvtp (TildeP Pat
p) = do { p' <- Pat -> CvtM' ConversionFailReason (LPat GhcPs)
cvtPat Pat
p; return $ LazyPat noAnn p' }
cvtp (BangP Pat
p) = do { p' <- Pat -> CvtM' ConversionFailReason (LPat GhcPs)
cvtPat Pat
p; return $ BangPat noAnn p' }
cvtp (TH.AsP Name
s Pat
p) = do { s' <- Name -> CvtM (LocatedN RdrName)
vNameN Name
s; p' <- cvtPat p
; return $ AsPat noAnn s' p' }
cvtp Pat
TH.WildP = Pat GhcPs -> CvtM (Pat GhcPs)
forall a. a -> CvtM' ConversionFailReason a
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 XWildPat GhcPs
NoExtField
noExtField
cvtp (RecP Name
c [FieldPat]
fs) = do { c' <- Name -> CvtM (LocatedN RdrName)
cNameN Name
c; fs' <- mapM cvtPatFld fs
; return $ ConPat
{ pat_con_ext = noAnn
, pat_con = c'
, pat_args = Hs.RecCon $ HsRecFields noExtField fs' Nothing
}
}
cvtp (ListP [Pat]
ps) = do { ps' <- [Pat] -> CvtM [LPat GhcPs]
forall (f :: * -> *).
Traversable f =>
f Pat -> CvtM (f (LPat GhcPs))
cvtPats [Pat]
ps
; return
$ ListPat noAnn ps'}
cvtp (SigP Pat
p Type
t) = do { p' <- Pat -> CvtM' ConversionFailReason (LPat GhcPs)
cvtPat Pat
p; t' <- cvtType t
; let pp = PprPrec -> LPat GhcPs -> LPat GhcPs
forall (p :: Pass).
IsPass p =>
PprPrec -> LPat (GhcPass p) -> LPat (GhcPass p)
parenthesizePat PprPrec
sigPrec LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
p'
; return $ SigPat noAnn pp (mkHsPatSigType noAnn t') }
cvtp (ViewP Exp
e Pat
p) = do { e' <- Exp -> CvtM' ConversionFailReason (LHsExpr GhcPs)
cvtl Exp
e; p' <- cvtPat p
; wrapParLA gParPat $ ViewPat noAnn e' p'}
cvtp (TypeP Type
t) = do { t' <- Type -> CvtM' ConversionFailReason (LHsType GhcPs)
cvtType Type
t
; return $ EmbTyPat noAnn (mkHsTyPat t') }
cvtp (InvisP Type
t) = do { t' <- PprPrec -> LHsType GhcPs -> LHsType GhcPs
forall (p :: Pass).
PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)
parenthesizeHsType PprPrec
appPrec (GenLocated SrcSpanAnnA (HsType GhcPs)
-> GenLocated SrcSpanAnnA (HsType GhcPs))
-> CvtM'
ConversionFailReason (GenLocated SrcSpanAnnA (HsType GhcPs))
-> CvtM'
ConversionFailReason (GenLocated SrcSpanAnnA (HsType GhcPs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> CvtM' ConversionFailReason (LHsType GhcPs)
cvtType Type
t
; pure (InvisPat noAnnSpecified (mkHsTyPat t'))}
cvtp (OrP NonEmpty Pat
ps) = do { ps' <- NonEmpty Pat -> CvtM (NonEmpty (LPat GhcPs))
forall (f :: * -> *).
Traversable f =>
f Pat -> CvtM (f (LPat GhcPs))
cvtPats NonEmpty Pat
ps
; pure (OrPat noExtField ps')}
noAnnSpecified :: XInvisPat GhcPs
noAnnSpecified :: XInvisPat GhcPs
noAnnSpecified = (EpToken "@"
forall a. NoAnn a => a
noAnn, Specificity
Hs.SpecifiedSpec)
cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField GhcPs (LPat GhcPs))
cvtPatFld :: FieldPat -> CvtM (LHsRecField GhcPs (LPat GhcPs))
cvtPatFld (Name
s,Pat
p)
= do { L ls s' <- Name -> CvtM (LocatedN RdrName)
vNameN Name
s
; p' <- cvtPat p
; returnLA $ HsFieldBind { hfbAnn = noAnn
, hfbLHS
= L (l2l ls) $ mkFieldOcc (L (l2l ls) s')
, hfbRHS = p'
, hfbPun = False} }
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 { l <- CvtM (Pat GhcPs)
-> CvtM' ConversionFailReason (GenLocated SrcSpanAnnA (Pat GhcPs))
forall a. CvtM a -> CvtM (LocatedA a)
wrapLA (CvtM (Pat GhcPs)
-> CvtM' ConversionFailReason (GenLocated SrcSpanAnnA (Pat GhcPs)))
-> CvtM (Pat GhcPs)
-> CvtM' ConversionFailReason (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
; cvtOpAppP l op2 z }
cvtOpAppP LPat GhcPs
x Name
op Pat
y
= do { op' <- Name -> CvtM (LocatedN RdrName)
cNameN Name
op
; y' <- cvtPat y
; return $ ConPat
{ pat_con_ext = noAnn
, pat_con = op'
, pat_args = InfixCon x y'
}
}
class CvtFlag flag flag' | flag -> flag' where
cvtFlag :: flag -> flag'
instance CvtFlag () () where
cvtFlag :: () -> ()
cvtFlag () = ()
instance CvtFlag TH.Specificity Hs.Specificity where
cvtFlag :: Specificity -> Specificity
cvtFlag Specificity
TH.SpecifiedSpec = Specificity
Hs.SpecifiedSpec
cvtFlag Specificity
TH.InferredSpec = Specificity
Hs.InferredSpec
instance CvtFlag TH.BndrVis (HsBndrVis GhcPs) where
cvtFlag :: BndrVis -> HsBndrVis GhcPs
cvtFlag BndrVis
TH.BndrReq = XBndrRequired GhcPs -> HsBndrVis GhcPs
forall pass. XBndrRequired pass -> HsBndrVis pass
HsBndrRequired NoExtField
XBndrRequired GhcPs
noExtField
cvtFlag BndrVis
TH.BndrInvis = XBndrInvisible GhcPs -> HsBndrVis GhcPs
forall pass. XBndrInvisible pass -> HsBndrVis pass
HsBndrInvisible EpToken "@"
XBndrInvisible GhcPs
forall a. NoAnn a => a
noAnn
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'
ConversionFailReason
(GenLocated SrcSpanAnnA (HsTyVarBndr flag' GhcPs)))
-> [TyVarBndr flag]
-> CvtM'
ConversionFailReason
[GenLocated SrcSpanAnnA (HsTyVarBndr flag' GhcPs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM TyVarBndr flag -> CvtM (XRec GhcPs (HsTyVarBndr flag' GhcPs))
TyVarBndr flag
-> CvtM'
ConversionFailReason
(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 { nm' <- Name -> CvtM (LocatedN RdrName)
tNameN Name
nm
; let fl' = flag -> flag'
forall flag flag'. CvtFlag flag flag' => flag -> flag'
cvtFlag flag
fl
; returnLA $ HsTvb { tvb_ext = noAnn
, tvb_flag = fl'
, tvb_var = HsBndrVar noExtField nm'
, tvb_kind = HsBndrNoKind noExtField } }
cvt_tv (TH.KindedTV Name
nm flag
fl Type
ki)
= do { nm' <- Name -> CvtM (LocatedN RdrName)
tNameN Name
nm
; let fl' = flag -> flag'
forall flag flag'. CvtFlag flag flag' => flag -> flag'
cvtFlag flag
fl
; ki' <- cvtKind ki
; returnLA $ HsTvb { tvb_ext = noAnn
, tvb_flag = fl'
, tvb_var = HsBndrVar noExtField nm'
, tvb_kind = HsBndrKind noExtField 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 -> [Type] -> CvtM (LHsContext GhcPs)
cvtContext PprPrec
p [Type]
tys = do { preds' <- (Type
-> CvtM'
ConversionFailReason (GenLocated SrcSpanAnnA (HsType GhcPs)))
-> [Type]
-> CvtM'
ConversionFailReason [GenLocated SrcSpanAnnA (HsType GhcPs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Type -> CvtM' ConversionFailReason (LHsType GhcPs)
Type
-> CvtM'
ConversionFailReason (GenLocated SrcSpanAnnA (HsType GhcPs))
cvtPred [Type]
tys
; parenthesizeHsContext p <$> returnLA preds' }
cvtPred :: TH.Pred -> CvtM (LHsType GhcPs)
cvtPred :: Type -> CvtM' ConversionFailReason (LHsType GhcPs)
cvtPred = Type -> CvtM' ConversionFailReason (LHsType GhcPs)
cvtType
cvtDerivClauseTys :: TH.Cxt -> CvtM (LDerivClauseTys GhcPs)
cvtDerivClauseTys :: [Type] -> CvtM (LDerivClauseTys GhcPs)
cvtDerivClauseTys [Type]
tys
= do { tys' <- (Type
-> CvtM'
ConversionFailReason (GenLocated SrcSpanAnnA (HsSigType GhcPs)))
-> [Type]
-> CvtM'
ConversionFailReason [GenLocated SrcSpanAnnA (HsSigType GhcPs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Type -> CvtM (LHsSigType GhcPs)
Type
-> CvtM'
ConversionFailReason (GenLocated SrcSpanAnnA (HsSigType GhcPs))
cvtSigType [Type]
tys
; case 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 LIdP GhcPs
_) }))]
-> GenLocated (EpAnn AnnContext) (DerivClauseTys GhcPs)
-> CvtM'
ConversionFailReason
(GenLocated (EpAnn AnnContext) (DerivClauseTys GhcPs))
forall a. a -> CvtM' ConversionFailReason a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated (EpAnn AnnContext) (DerivClauseTys GhcPs)
-> CvtM'
ConversionFailReason
(GenLocated (EpAnn AnnContext) (DerivClauseTys GhcPs)))
-> GenLocated (EpAnn AnnContext) (DerivClauseTys GhcPs)
-> CvtM'
ConversionFailReason
(GenLocated (EpAnn AnnContext) (DerivClauseTys GhcPs))
forall a b. (a -> b) -> a -> b
$ EpAnn AnnContext
-> DerivClauseTys GhcPs
-> GenLocated (EpAnn AnnContext) (DerivClauseTys GhcPs)
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnA -> EpAnn AnnContext
forall a b. (HasLoc a, HasAnnotation b) => a -> b
l2l SrcSpanAnnA
l) (DerivClauseTys GhcPs
-> GenLocated (EpAnn AnnContext) (DerivClauseTys GhcPs))
-> DerivClauseTys GhcPs
-> GenLocated (EpAnn AnnContext) (DerivClauseTys GhcPs)
forall a b. (a -> b) -> a -> b
$ XDctSingle GhcPs -> LHsSigType GhcPs -> DerivClauseTys GhcPs
forall pass.
XDctSingle pass -> LHsSigType pass -> DerivClauseTys pass
DctSingle XDctSingle GhcPs
NoExtField
noExtField LHsSigType GhcPs
GenLocated SrcSpanAnnA (HsSigType GhcPs)
ty'
[GenLocated SrcSpanAnnA (HsSigType GhcPs)]
_ -> DerivClauseTys GhcPs
-> CvtM'
ConversionFailReason
(GenLocated (EpAnn AnnContext) (DerivClauseTys GhcPs))
forall ann e. NoAnn ann => e -> CvtM (LocatedAn ann e)
returnLA (DerivClauseTys GhcPs
-> CvtM'
ConversionFailReason
(GenLocated (EpAnn AnnContext) (DerivClauseTys GhcPs)))
-> DerivClauseTys GhcPs
-> CvtM'
ConversionFailReason
(GenLocated (EpAnn AnnContext) (DerivClauseTys GhcPs))
forall a b. (a -> b) -> a -> b
$ XDctMulti GhcPs -> [LHsSigType GhcPs] -> DerivClauseTys GhcPs
forall pass.
XDctMulti pass -> [LHsSigType pass] -> DerivClauseTys pass
DctMulti XDctMulti GhcPs
NoExtField
noExtField [LHsSigType GhcPs]
[GenLocated SrcSpanAnnA (HsSigType GhcPs)]
tys' }
cvtDerivClause :: TH.DerivClause
-> CvtM (LHsDerivingClause GhcPs)
cvtDerivClause :: DerivClause -> CvtM (LHsDerivingClause GhcPs)
cvtDerivClause (TH.DerivClause Maybe DerivStrategy
ds [Type]
tys)
= do { tys' <- [Type] -> CvtM (LDerivClauseTys GhcPs)
cvtDerivClauseTys [Type]
tys
; ds' <- traverse cvtDerivStrategy ds
; returnLA $ HsDerivingClause noAnn ds' tys' }
cvtDerivStrategy :: TH.DerivStrategy -> CvtM (Hs.LDerivStrategy GhcPs)
cvtDerivStrategy :: DerivStrategy -> CvtM (LDerivStrategy GhcPs)
cvtDerivStrategy DerivStrategy
TH.StockStrategy = DerivStrategy GhcPs
-> CvtM'
ConversionFailReason (GenLocated EpAnnCO (DerivStrategy GhcPs))
forall ann e. NoAnn ann => e -> CvtM (LocatedAn ann e)
returnLA (XStockStrategy GhcPs -> DerivStrategy GhcPs
forall pass. XStockStrategy pass -> DerivStrategy pass
Hs.StockStrategy XStockStrategy GhcPs
EpToken "stock"
forall a. NoAnn a => a
noAnn)
cvtDerivStrategy DerivStrategy
TH.AnyclassStrategy = DerivStrategy GhcPs
-> CvtM'
ConversionFailReason (GenLocated EpAnnCO (DerivStrategy GhcPs))
forall ann e. NoAnn ann => e -> CvtM (LocatedAn ann e)
returnLA (XAnyClassStrategy GhcPs -> DerivStrategy GhcPs
forall pass. XAnyClassStrategy pass -> DerivStrategy pass
Hs.AnyclassStrategy XAnyClassStrategy GhcPs
EpToken "anyclass"
forall a. NoAnn a => a
noAnn)
cvtDerivStrategy DerivStrategy
TH.NewtypeStrategy = DerivStrategy GhcPs
-> CvtM'
ConversionFailReason (GenLocated EpAnnCO (DerivStrategy GhcPs))
forall ann e. NoAnn ann => e -> CvtM (LocatedAn ann e)
returnLA (XNewtypeStrategy GhcPs -> DerivStrategy GhcPs
forall pass. XNewtypeStrategy pass -> DerivStrategy pass
Hs.NewtypeStrategy XNewtypeStrategy GhcPs
EpToken "newtype"
forall a. NoAnn a => a
noAnn)
cvtDerivStrategy (TH.ViaStrategy Type
ty) = do
ty' <- Type -> CvtM (LHsSigType GhcPs)
cvtSigType Type
ty
returnLA $ Hs.ViaStrategy (XViaStrategyPs noAnn ty')
cvtType :: TH.Type -> CvtM (LHsType GhcPs)
cvtType :: Type -> CvtM' ConversionFailReason (LHsType GhcPs)
cvtType = TypeOrKind -> Type -> CvtM' ConversionFailReason (LHsType GhcPs)
cvtTypeKind TypeOrKind
TypeLevel
cvtSigType :: TH.Type -> CvtM (LHsSigType GhcPs)
cvtSigType :: Type -> CvtM (LHsSigType GhcPs)
cvtSigType = TypeOrKind -> Type -> CvtM (LHsSigType GhcPs)
cvtSigTypeKind TypeOrKind
TypeLevel
cvtSigTypeKind :: TypeOrKind -> TH.Type -> CvtM (LHsSigType GhcPs)
cvtSigTypeKind :: TypeOrKind -> Type -> CvtM (LHsSigType GhcPs)
cvtSigTypeKind TypeOrKind
typeOrKind Type
ty = do
ty' <- TypeOrKind -> Type -> CvtM' ConversionFailReason (LHsType GhcPs)
cvtTypeKind TypeOrKind
typeOrKind Type
ty
pure $ hsTypeToHsSigType $ parenthesizeHsType sigPrec ty'
cvtTypeKind :: TypeOrKind -> TH.Type -> CvtM (LHsType GhcPs)
cvtTypeKind :: TypeOrKind -> Type -> CvtM' ConversionFailReason (LHsType GhcPs)
cvtTypeKind TypeOrKind
typeOrKind Type
ty
= do { (head_ty, tys') <- Type -> CvtM (Type, HsFamEqnPats GhcPs)
split_ty_app Type
ty
; let m_normals = (HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))
-> Maybe (GenLocated SrcSpanAnnA (HsType GhcPs)))
-> [HsArg
GhcPs
(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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))
-> Maybe (GenLocated SrcSpanAnnA (HsType GhcPs))
forall {p} {a} {ty}. HsArg p a ty -> Maybe a
extract_normal [HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
tys'
where extract_normal :: HsArg p a ty -> Maybe a
extract_normal (HsValArg XValArg p
_ a
ty) = a -> Maybe a
forall a. a -> Maybe a
Just a
ty
extract_normal HsArg p a ty
_ = Maybe a
forall a. Maybe a
Nothing
; case head_ty of
TupleT SumAlt
n
| Just [GenLocated SrcSpanAnnA (HsType GhcPs)]
normals <- Maybe [GenLocated SrcSpanAnnA (HsType GhcPs)]
m_normals
, [GenLocated SrcSpanAnnA (HsType GhcPs)]
normals [GenLocated SrcSpanAnnA (HsType GhcPs)] -> SumAlt -> Bool
forall a. [a] -> SumAlt -> Bool
`lengthIs` SumAlt
n
-> HsType GhcPs
-> CvtM'
ConversionFailReason (GenLocated SrcSpanAnnA (HsType GhcPs))
forall ann e. NoAnn ann => e -> CvtM (LocatedAn ann e)
returnLA (XTupleTy GhcPs -> HsTupleSort -> [LHsType GhcPs] -> HsType GhcPs
forall pass.
XTupleTy pass -> HsTupleSort -> [LHsType pass] -> HsType pass
HsTupleTy XTupleTy GhcPs
AnnParen
forall a. NoAnn a => a
noAnn HsTupleSort
HsBoxedOrConstraintTuple [LHsType GhcPs]
[GenLocated SrcSpanAnnA (HsType GhcPs)]
normals)
| Bool
otherwise
-> do { tuple_tc <- RdrName -> CvtM (LocatedN RdrName)
forall ann e. NoAnn ann => e -> CvtM (LocatedAn ann e)
returnLA (RdrName -> CvtM (LocatedN RdrName))
-> RdrName -> CvtM (LocatedN RdrName)
forall a b. (a -> b) -> a -> b
$ TyCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName (TyCon -> RdrName) -> TyCon -> RdrName
forall a b. (a -> b) -> a -> b
$ Boxity -> SumAlt -> TyCon
tupleTyCon Boxity
Boxed SumAlt
n
; mk_apps (HsTyVar noAnn NotPromoted tuple_tc) tys' }
UnboxedTupleT SumAlt
n
| Just [GenLocated SrcSpanAnnA (HsType GhcPs)]
normals <- Maybe [GenLocated SrcSpanAnnA (HsType GhcPs)]
m_normals
, [GenLocated SrcSpanAnnA (HsType GhcPs)]
normals [GenLocated SrcSpanAnnA (HsType GhcPs)] -> SumAlt -> Bool
forall a. [a] -> SumAlt -> Bool
`lengthIs` SumAlt
n
-> HsType GhcPs
-> CvtM'
ConversionFailReason (GenLocated SrcSpanAnnA (HsType GhcPs))
forall ann e. NoAnn ann => e -> CvtM (LocatedAn ann e)
returnLA (XTupleTy GhcPs -> HsTupleSort -> [LHsType GhcPs] -> HsType GhcPs
forall pass.
XTupleTy pass -> HsTupleSort -> [LHsType pass] -> HsType pass
HsTupleTy XTupleTy GhcPs
AnnParen
forall a. NoAnn a => a
noAnn HsTupleSort
HsUnboxedTuple [LHsType GhcPs]
[GenLocated SrcSpanAnnA (HsType GhcPs)]
normals)
| Bool
otherwise
-> do { tuple_tc <- RdrName -> CvtM (LocatedN RdrName)
forall ann e. NoAnn ann => e -> CvtM (LocatedAn ann e)
returnLA (RdrName -> CvtM (LocatedN RdrName))
-> RdrName -> CvtM (LocatedN RdrName)
forall a b. (a -> b) -> a -> b
$ TyCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName (TyCon -> RdrName) -> TyCon -> RdrName
forall a b. (a -> b) -> a -> b
$ Boxity -> SumAlt -> TyCon
tupleTyCon Boxity
Unboxed SumAlt
n
; mk_apps (HsTyVar noAnn NotPromoted tuple_tc) tys' }
UnboxedSumT SumAlt
n
| SumAlt
n SumAlt -> SumAlt -> Bool
forall a. Ord a => a -> a -> Bool
< SumAlt
2
-> ConversionFailReason
-> CvtM'
ConversionFailReason (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a. ConversionFailReason -> CvtM a
failWith (ConversionFailReason
-> CvtM'
ConversionFailReason (GenLocated SrcSpanAnnA (HsType GhcPs)))
-> ConversionFailReason
-> CvtM'
ConversionFailReason (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a b. (a -> b) -> a -> b
$ SumAlt -> ConversionFailReason
IllegalSumArity SumAlt
n
| Just [GenLocated SrcSpanAnnA (HsType GhcPs)]
normals <- Maybe [GenLocated SrcSpanAnnA (HsType GhcPs)]
m_normals
, [GenLocated SrcSpanAnnA (HsType GhcPs)]
normals [GenLocated SrcSpanAnnA (HsType GhcPs)] -> SumAlt -> Bool
forall a. [a] -> SumAlt -> Bool
`lengthIs` SumAlt
n
-> HsType GhcPs
-> CvtM'
ConversionFailReason (GenLocated SrcSpanAnnA (HsType GhcPs))
forall ann e. NoAnn ann => e -> CvtM (LocatedAn ann e)
returnLA (XSumTy GhcPs -> [LHsType GhcPs] -> HsType GhcPs
forall pass. XSumTy pass -> [LHsType pass] -> HsType pass
HsSumTy XSumTy GhcPs
AnnParen
forall a. NoAnn a => a
noAnn [LHsType GhcPs]
[GenLocated SrcSpanAnnA (HsType GhcPs)]
normals)
| Bool
otherwise
-> do { sum_tc <- RdrName -> CvtM (LocatedN RdrName)
forall ann e. NoAnn ann => e -> CvtM (LocatedAn ann e)
returnLA (RdrName -> CvtM (LocatedN RdrName))
-> RdrName -> CvtM (LocatedN RdrName)
forall a b. (a -> b) -> a -> b
$ TyCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName (TyCon -> RdrName) -> TyCon -> RdrName
forall a b. (a -> b) -> a -> b
$ SumAlt -> TyCon
sumTyCon SumAlt
n
; mk_apps (HsTyVar noAnn NotPromoted sum_tc) 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
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'
ConversionFailReason (GenLocated SrcSpanAnnA (HsType GhcPs))
forall ann e. NoAnn ann => e -> CvtM (LocatedAn ann e)
returnLA (XParTy GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy XParTy GhcPs
forall a. NoAnn a => a
noAnn LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
x')
HsForAllTy{} -> HsType GhcPs
-> CvtM'
ConversionFailReason (GenLocated SrcSpanAnnA (HsType GhcPs))
forall ann e. NoAnn ann => e -> CvtM (LocatedAn ann e)
returnLA (XParTy GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy (EpToken "(", EpToken ")")
XParTy GhcPs
forall a. NoAnn a => a
noAnn LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
x')
HsQualTy{} -> HsType GhcPs
-> CvtM'
ConversionFailReason (GenLocated SrcSpanAnnA (HsType GhcPs))
forall ann e. NoAnn ann => e -> CvtM (LocatedAn ann e)
returnLA (XParTy GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy (EpToken "(", EpToken ")")
XParTy GhcPs
forall a. NoAnn a => a
noAnn LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
x')
HsType GhcPs
_ -> GenLocated SrcSpanAnnA (HsType GhcPs)
-> CvtM'
ConversionFailReason (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a. a -> CvtM' ConversionFailReason a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsType GhcPs)
-> CvtM'
ConversionFailReason (GenLocated SrcSpanAnnA (HsType GhcPs)))
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> CvtM'
ConversionFailReason (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 LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
x'
let y'' = PprPrec -> LHsType GhcPs -> LHsType GhcPs
forall (p :: Pass).
PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)
parenthesizeHsType PprPrec
sigPrec LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
y'
returnLA (HsFunTy noExtField (HsUnrestrictedArrow noAnn) x'' y'')
| Bool
otherwise
-> do { fun_tc <- RdrName -> CvtM (LocatedN RdrName)
forall ann e. NoAnn ann => e -> CvtM (LocatedAn ann e)
returnLA (RdrName -> CvtM (LocatedN RdrName))
-> RdrName -> CvtM (LocatedN RdrName)
forall a b. (a -> b) -> a -> b
$ TyCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName TyCon
unrestrictedFunTyCon
; mk_apps (HsTyVar noAnn NotPromoted fun_tc) 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
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'
ConversionFailReason (GenLocated SrcSpanAnnA (HsType GhcPs))
forall ann e. NoAnn ann => e -> CvtM (LocatedAn ann e)
returnLA (XParTy GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy XParTy GhcPs
forall a. NoAnn a => a
noAnn LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
x')
HsForAllTy{} -> HsType GhcPs
-> CvtM'
ConversionFailReason (GenLocated SrcSpanAnnA (HsType GhcPs))
forall ann e. NoAnn ann => e -> CvtM (LocatedAn ann e)
returnLA (XParTy GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy (EpToken "(", EpToken ")")
XParTy GhcPs
forall a. NoAnn a => a
noAnn LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
x')
HsQualTy{} -> HsType GhcPs
-> CvtM'
ConversionFailReason (GenLocated SrcSpanAnnA (HsType GhcPs))
forall ann e. NoAnn ann => e -> CvtM (LocatedAn ann e)
returnLA (XParTy GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy (EpToken "(", EpToken ")")
XParTy GhcPs
forall a. NoAnn a => a
noAnn LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
x')
HsType GhcPs
_ -> GenLocated SrcSpanAnnA (HsType GhcPs)
-> CvtM'
ConversionFailReason (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a. a -> CvtM' ConversionFailReason a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsType GhcPs)
-> CvtM'
ConversionFailReason (GenLocated SrcSpanAnnA (HsType GhcPs)))
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> CvtM'
ConversionFailReason (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 LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
x'
let y'' = PprPrec -> LHsType GhcPs -> LHsType GhcPs
forall (p :: Pass).
PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)
parenthesizeHsType PprPrec
sigPrec LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
y'
w'' = LHsType GhcPs -> HsArrow GhcPs
hsTypeToArrow LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
w'
returnLA (HsFunTy noExtField w'' x'' y'')
| Bool
otherwise
-> do { fun_tc <- RdrName -> CvtM (LocatedN RdrName)
forall ann e. NoAnn ann => e -> CvtM (LocatedAn ann e)
returnLA (RdrName -> CvtM (LocatedN RdrName))
-> RdrName -> CvtM (LocatedN RdrName)
forall a b. (a -> b) -> a -> b
$ TyCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName TyCon
fUNTyCon
; mk_apps (HsTyVar noAnn NotPromoted fun_tc) 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'
ConversionFailReason (GenLocated SrcSpanAnnA (HsType GhcPs))
forall ann e. NoAnn ann => e -> CvtM (LocatedAn ann e)
returnLA (XListTy GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass. XListTy pass -> LHsType pass -> HsType pass
HsListTy XListTy GhcPs
AnnParen
forall a. NoAnn a => a
noAnn LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
x')
| Bool
otherwise
-> do { list_tc <- RdrName -> CvtM (LocatedN RdrName)
forall ann e. NoAnn ann => e -> CvtM (LocatedAn ann e)
returnLA (RdrName -> CvtM (LocatedN RdrName))
-> RdrName -> CvtM (LocatedN RdrName)
forall a b. (a -> b) -> a -> b
$ TyCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName TyCon
listTyCon
; mk_apps (HsTyVar noAnn NotPromoted list_tc) tys' }
VarT Name
nm -> do { nm' <- Name -> CvtM (LocatedN RdrName)
tNameN Name
nm
; mk_apps (HsTyVar noAnn NotPromoted nm') tys' }
ConT Name
nm -> do { nm' <- Name -> CvtM RdrName
tconName Name
nm
; let prom = RdrName -> PromotionFlag
name_promotedness RdrName
nm'
; lnm' <- returnLA nm'
; mk_apps (HsTyVar noAnn prom lnm') tys'}
ForallT [TyVarBndr Specificity]
tvs [Type]
cxt Type
ty
| [HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
-> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
tys'
-> do { tvs' <- [TyVarBndr Specificity] -> CvtM [LHsTyVarBndr Specificity GhcPs]
forall flag flag'.
CvtFlag flag flag' =>
[TyVarBndr flag] -> CvtM [LHsTyVarBndr flag' GhcPs]
cvtTvs [TyVarBndr Specificity]
tvs
; cxt' <- cvtContext funPrec cxt
; ty' <- cvtType ty
; loc <- getL
; let loc' = SrcSpan -> SrcSpanAnnA
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
loc
; let tele = EpAnnForallInvis
-> [LHsTyVarBndr Specificity GhcPs] -> HsForAllTelescope GhcPs
forall (p :: Pass).
EpAnnForallInvis
-> [LHsTyVarBndr Specificity (GhcPass p)]
-> HsForAllTelescope (GhcPass p)
mkHsForAllInvisTele EpAnnForallInvis
forall a. NoAnn a => a
noAnn [LHsTyVarBndr Specificity GhcPs]
[GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)]
tvs'
hs_ty = SrcSpanAnnA
-> HsForAllTelescope GhcPs -> LHsType GhcPs -> LHsType GhcPs
mkHsForAllTy SrcSpanAnnA
loc' HsForAllTelescope GhcPs
tele LHsType GhcPs
rho_ty
rho_ty = [Type]
-> SrcSpanAnnA
-> LHsContext GhcPs
-> LHsType GhcPs
-> LHsType GhcPs
mkHsQualTy [Type]
cxt SrcSpanAnnA
loc' LHsContext GhcPs
GenLocated
(EpAnn AnnContext) [GenLocated SrcSpanAnnA (HsType GhcPs)]
cxt' LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
ty'
; return hs_ty }
ForallVisT [TyVarBndr ()]
tvs Type
ty
| [HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
-> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
tys'
-> do { tvs' <- [TyVarBndr ()] -> CvtM [LHsTyVarBndr () GhcPs]
forall flag flag'.
CvtFlag flag flag' =>
[TyVarBndr flag] -> CvtM [LHsTyVarBndr flag' GhcPs]
cvtTvs [TyVarBndr ()]
tvs
; ty' <- cvtType ty
; loc <- getL
; let loc' = SrcSpan -> SrcSpanAnnA
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
loc
; let tele = EpAnnForallVis
-> [LHsTyVarBndr () GhcPs] -> HsForAllTelescope GhcPs
forall (p :: Pass).
EpAnnForallVis
-> [LHsTyVarBndr () (GhcPass p)] -> HsForAllTelescope (GhcPass p)
mkHsForAllVisTele EpAnnForallVis
forall a. NoAnn a => a
noAnn [LHsTyVarBndr () GhcPs]
[GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)]
tvs'
; pure $ mkHsForAllTy loc' tele ty' }
SigT Type
ty Type
ki
-> do { ty' <- Type -> CvtM' ConversionFailReason (LHsType GhcPs)
cvtType Type
ty
; ki' <- cvtKind ki
; mk_apps (HsKindSig noAnn ty' ki') tys'
}
LitT TyLit
lit
-> HsType GhcPs
-> HsFamEqnPats GhcPs -> CvtM' ConversionFailReason (LHsType GhcPs)
mk_apps (XTyLit GhcPs -> HsTyLit GhcPs -> HsType GhcPs
forall pass. XTyLit pass -> HsTyLit pass -> HsType pass
HsTyLit XTyLit GhcPs
NoExtField
noExtField (TyLit -> HsTyLit GhcPs
forall (p :: Pass). TyLit -> HsTyLit (GhcPass p)
cvtTyLit TyLit
lit)) HsFamEqnPats GhcPs
[HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
tys'
Type
WildCardT
-> HsType GhcPs
-> HsFamEqnPats GhcPs -> CvtM' ConversionFailReason (LHsType GhcPs)
mk_apps (EpToken "_" -> HsType GhcPs
mkAnonWildCardTy EpToken "_"
forall a. NoAnn a => a
noAnn) HsFamEqnPats GhcPs
[HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
tys'
InfixT Type
t1 Name
s Type
t2
-> do { s' <- Name -> CvtM RdrName
tconName Name
s
; t1' <- cvtType t1
; t2' <- cvtType t2
; let prom = RdrName -> PromotionFlag
name_promotedness RdrName
s'
; ls' <- returnLA s'
; mk_apps
(HsTyVar noAnn prom ls')
([HsValArg noExtField t1', HsValArg noExtField t2'] ++ tys')
}
UInfixT Type
t1 Name
s Type
t2
-> do { s' <- Name -> CvtM (LocatedN RdrName)
tconNameN Name
s
; t2' <- cvtType t2
; t <- cvtOpAppT NotPromoted t1 s' t2'
; mk_apps (unLoc t) tys'
}
PromotedInfixT Type
t1 Name
s Type
t2
-> do { s' <- Name -> CvtM (LocatedN RdrName)
cNameN Name
s
; t1' <- cvtType t1
; t2' <- cvtType t2
; mk_apps
(HsTyVar noAnn IsPromoted s')
([HsValArg noExtField t1', HsValArg noExtField t2'] ++ tys')
}
PromotedUInfixT Type
t1 Name
s Type
t2
-> do { s' <- Name -> CvtM (LocatedN RdrName)
cNameN Name
s
; t2' <- cvtType t2
; t <- cvtOpAppT IsPromoted t1 s' t2'
; mk_apps (unLoc t) tys'
}
ParensT Type
t
-> do { t' <- Type -> CvtM' ConversionFailReason (LHsType GhcPs)
cvtType Type
t
; mk_apps (HsParTy noAnn t') tys'
}
PromotedT Name
nm -> do { nm' <- Name -> CvtM (LocatedN RdrName)
cNameN Name
nm
; mk_apps (HsTyVar noAnn IsPromoted nm')
tys' }
PromotedTupleT SumAlt
n
| Just [GenLocated SrcSpanAnnA (HsType GhcPs)]
normals <- Maybe [GenLocated SrcSpanAnnA (HsType GhcPs)]
m_normals
, [GenLocated SrcSpanAnnA (HsType GhcPs)]
normals [GenLocated SrcSpanAnnA (HsType GhcPs)] -> SumAlt -> Bool
forall a. [a] -> SumAlt -> Bool
`lengthIs` SumAlt
n
-> HsType GhcPs
-> CvtM'
ConversionFailReason (GenLocated SrcSpanAnnA (HsType GhcPs))
forall ann e. NoAnn ann => e -> CvtM (LocatedAn ann e)
returnLA (XExplicitTupleTy GhcPs
-> PromotionFlag -> [LHsType GhcPs] -> HsType GhcPs
forall pass.
XExplicitTupleTy pass
-> PromotionFlag -> [LHsType pass] -> HsType pass
HsExplicitTupleTy (EpToken "'", EpToken "(", EpToken ")")
XExplicitTupleTy GhcPs
forall a. NoAnn a => a
noAnn PromotionFlag
IsPromoted [LHsType GhcPs]
[GenLocated SrcSpanAnnA (HsType GhcPs)]
normals)
| Bool
otherwise
-> do { tuple_tc <- RdrName -> CvtM (LocatedN RdrName)
forall ann e. NoAnn ann => e -> CvtM (LocatedAn ann e)
returnLA (RdrName -> CvtM (LocatedN RdrName))
-> RdrName -> CvtM (LocatedN RdrName)
forall a b. (a -> b) -> a -> b
$ DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName (DataCon -> RdrName) -> DataCon -> RdrName
forall a b. (a -> b) -> a -> b
$ Boxity -> SumAlt -> DataCon
tupleDataCon Boxity
Boxed SumAlt
n
; mk_apps (HsTyVar noAnn IsPromoted tuple_tc) tys' }
Type
PromotedNilT
-> HsType GhcPs
-> HsFamEqnPats GhcPs -> CvtM' ConversionFailReason (LHsType GhcPs)
mk_apps (XExplicitListTy GhcPs
-> PromotionFlag -> [LHsType GhcPs] -> HsType GhcPs
forall pass.
XExplicitListTy pass
-> PromotionFlag -> [LHsType pass] -> HsType pass
HsExplicitListTy (EpToken "'", EpToken "[", EpToken "]")
XExplicitListTy GhcPs
forall a. NoAnn a => a
noAnn PromotionFlag
IsPromoted []) HsFamEqnPats GhcPs
[HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
tys'
Type
PromotedConsT
| 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'
ConversionFailReason (GenLocated SrcSpanAnnA (HsType GhcPs))
forall ann e. NoAnn ann => e -> CvtM (LocatedAn ann e)
returnLA (XExplicitListTy GhcPs
-> PromotionFlag -> [LHsType GhcPs] -> HsType GhcPs
forall pass.
XExplicitListTy pass
-> PromotionFlag -> [LHsType pass] -> HsType pass
HsExplicitListTy (EpToken "'", EpToken "[", EpToken "]")
XExplicitListTy GhcPs
forall a. NoAnn a => 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]
:[LHsType GhcPs]
[GenLocated SrcSpanAnnA (HsType GhcPs)]
tys2))
| Bool
otherwise
-> do { cons_tc <- RdrName -> CvtM (LocatedN RdrName)
forall ann e. NoAnn ann => e -> CvtM (LocatedAn ann e)
returnLA (RdrName -> CvtM (LocatedN RdrName))
-> RdrName -> CvtM (LocatedN RdrName)
forall a b. (a -> b) -> a -> b
$ DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
consDataCon
; mk_apps (HsTyVar noAnn IsPromoted cons_tc) tys' }
Type
StarT
-> do { type_tc <- RdrName -> CvtM (LocatedN RdrName)
forall ann e. NoAnn ann => e -> CvtM (LocatedAn ann e)
returnLA (RdrName -> CvtM (LocatedN RdrName))
-> RdrName -> CvtM (LocatedN RdrName)
forall a b. (a -> b) -> a -> b
$ TyCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName TyCon
liftedTypeKindTyCon
; mk_apps (HsTyVar noAnn NotPromoted type_tc) tys' }
Type
ConstraintT
-> do { constraint_tc <- RdrName -> CvtM (LocatedN RdrName)
forall ann e. NoAnn ann => e -> CvtM (LocatedAn ann e)
returnLA (RdrName -> CvtM (LocatedN RdrName))
-> RdrName -> CvtM (LocatedN RdrName)
forall a b. (a -> b) -> a -> b
$ TyCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName TyCon
constraintKindTyCon
; mk_apps (HsTyVar noAnn NotPromoted constraint_tc) 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 LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
x'
py :: LHsType GhcPs
py = PprPrec -> LHsType GhcPs -> LHsType GhcPs
forall (p :: Pass).
PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)
parenthesizeHsType PprPrec
opPrec LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
y'
in do { eq_tc <- RdrName -> CvtM (LocatedN RdrName)
forall ann e. NoAnn ann => e -> CvtM (LocatedAn ann e)
returnLA RdrName
eqTyCon_RDR
; returnLA (HsOpTy noExtField NotPromoted px eq_tc py) }
| Bool
otherwise ->
do { eq_tc <- RdrName -> CvtM (LocatedN RdrName)
forall ann e. NoAnn ann => e -> CvtM (LocatedAn ann e)
returnLA RdrName
eqTyCon_RDR
; mk_apps (HsTyVar noAnn NotPromoted eq_tc) tys' }
ImplicitParamT String
n Type
t
-> do { n' <- CvtM HsIPName -> CvtM (GenLocated SrcSpan HsIPName)
forall a. CvtM a -> CvtM (Located a)
wrapL (CvtM HsIPName -> CvtM (GenLocated SrcSpan HsIPName))
-> CvtM HsIPName -> CvtM (GenLocated SrcSpan HsIPName)
forall a b. (a -> b) -> a -> b
$ String -> CvtM HsIPName
ipName String
n
; t' <- cvtType t
; returnLA (HsIParamTy noAnn (reLoc n') t')
}
Type
_ -> ConversionFailReason
-> CvtM'
ConversionFailReason (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a. ConversionFailReason -> CvtM a
failWith (TypeOrKind -> Type -> ConversionFailReason
MalformedType TypeOrKind
typeOrKind 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 LHsType GhcPs
GenLocated SrcSpanAnnA (HsType 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 -> XLinearArrow (GenLocated SrcSpanAnnA (HsType GhcPs)) GhcPs
-> HsArrowOf (GenLocated SrcSpanAnnA (HsType GhcPs)) GhcPs
forall mult pass. XLinearArrow mult pass -> HsArrowOf mult pass
HsLinearArrow XLinearArrow (GenLocated SrcSpanAnnA (HsType GhcPs)) GhcPs
EpLinearArrow
forall a. NoAnn a => a
noAnn
| Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
manyDataConName -> XUnrestrictedArrow (GenLocated SrcSpanAnnA (HsType GhcPs)) GhcPs
-> HsArrowOf (GenLocated SrcSpanAnnA (HsType GhcPs)) GhcPs
forall mult pass.
XUnrestrictedArrow mult pass -> HsArrowOf mult pass
HsUnrestrictedArrow TokRarrow
XUnrestrictedArrow (GenLocated SrcSpanAnnA (HsType GhcPs)) GhcPs
forall a. NoAnn a => a
noAnn
HsType GhcPs
_ -> XExplicitMult (GenLocated SrcSpanAnnA (HsType GhcPs)) GhcPs
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> HsArrowOf (GenLocated SrcSpanAnnA (HsType GhcPs)) GhcPs
forall mult pass.
XExplicitMult mult pass -> mult -> HsArrowOf mult pass
HsExplicitMult (EpToken "%", TokRarrow)
XExplicitMult (GenLocated SrcSpanAnnA (HsType GhcPs)) GhcPs
forall a. NoAnn a => a
noAnn LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
w
name_promotedness :: RdrName -> Hs.PromotionFlag
name_promotedness :: RdrName -> PromotionFlag
name_promotedness RdrName
nm
| RdrName -> Bool
isRdrDataCon RdrName
nm = PromotionFlag
IsPromoted
| Bool
otherwise = PromotionFlag
NotPromoted
mk_apps :: HsType GhcPs -> [LHsTypeArg GhcPs] -> CvtM (LHsType GhcPs)
mk_apps :: HsType GhcPs
-> HsFamEqnPats GhcPs -> CvtM' ConversionFailReason (LHsType GhcPs)
mk_apps HsType GhcPs
head_ty HsFamEqnPats GhcPs
type_args = do
head_ty' <- HsType GhcPs
-> CvtM'
ConversionFailReason (GenLocated SrcSpanAnnA (HsType GhcPs))
forall ann e. NoAnn ann => e -> CvtM (LocatedAn ann e)
returnLA HsType GhcPs
head_ty
let phead_ty :: LHsType GhcPs
phead_ty = PprPrec -> LHsType GhcPs -> LHsType GhcPs
forall (p :: Pass).
PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)
parenthesizeHsType PprPrec
sigPrec LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
head_ty'
go :: [LHsTypeArg GhcPs] -> CvtM (LHsType GhcPs)
go [] = GenLocated SrcSpanAnnA (HsType GhcPs)
-> CvtM'
ConversionFailReason (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a. a -> CvtM' ConversionFailReason a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenLocated SrcSpanAnnA (HsType GhcPs)
head_ty'
go (LHsTypeArg GhcPs
arg:HsFamEqnPats GhcPs
args) =
case LHsTypeArg GhcPs
arg of
HsValArg XValArg GhcPs
_ LHsType GhcPs
ty ->
do p_ty <- GenLocated SrcSpanAnnA (HsType GhcPs)
-> CvtM'
ConversionFailReason (GenLocated SrcSpanAnnA (HsType GhcPs))
forall {p :: Pass}.
GenLocated SrcSpanAnnA (HsType (GhcPass p))
-> CvtM (GenLocated SrcSpanAnnA (HsType (GhcPass p)))
add_parens LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
ty
mk_apps (HsAppTy noExtField phead_ty p_ty) args
HsTypeArg XTypeArg GhcPs
at LHsType GhcPs
ki ->
do p_ki <- GenLocated SrcSpanAnnA (HsType GhcPs)
-> CvtM'
ConversionFailReason (GenLocated SrcSpanAnnA (HsType GhcPs))
forall {p :: Pass}.
GenLocated SrcSpanAnnA (HsType (GhcPass p))
-> CvtM (GenLocated SrcSpanAnnA (HsType (GhcPass p)))
add_parens LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
ki
mk_apps (HsAppKindTy at phead_ty p_ki) args
HsArgPar XArgPar GhcPs
_ -> HsType GhcPs
-> HsFamEqnPats GhcPs -> CvtM' ConversionFailReason (LHsType GhcPs)
mk_apps (XParTy GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy (EpToken "(", EpToken ")")
XParTy GhcPs
forall a. NoAnn a => a
noAnn LHsType GhcPs
phead_ty) HsFamEqnPats GhcPs
args
go type_args
where
add_parens :: GenLocated SrcSpanAnnA (HsType (GhcPass p))
-> CvtM (GenLocated SrcSpanAnnA (HsType (GhcPass p)))
add_parens lt :: GenLocated SrcSpanAnnA (HsType (GhcPass p))
lt@(L SrcSpanAnnA
_ HsType (GhcPass p)
t)
| 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 ann e. NoAnn ann => e -> CvtM (LocatedAn ann e)
returnLA (XParTy (GhcPass p) -> LHsType (GhcPass p) -> HsType (GhcPass p)
forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy (EpToken "(", EpToken ")")
XParTy (GhcPass p)
forall a. NoAnn a => a
noAnn LHsType (GhcPass p)
GenLocated SrcSpanAnnA (HsType (GhcPass p))
lt)
| Bool
otherwise = GenLocated SrcSpanAnnA (HsType (GhcPass p))
-> CvtM (GenLocated SrcSpanAnnA (HsType (GhcPass p)))
forall a. a -> CvtM' ConversionFailReason a
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 XValArg GhcPs
x LHsType GhcPs
ty) = XValArg GhcPs -> LHsType GhcPs -> LHsTypeArg GhcPs
forall p tm ty. XValArg p -> tm -> HsArg p tm ty
HsValArg XValArg GhcPs
x (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 XTypeArg GhcPs
l LHsType GhcPs
ki) = XTypeArg GhcPs -> LHsType GhcPs -> LHsTypeArg GhcPs
forall p tm ty. XTypeArg p -> ty -> HsArg p tm ty
HsTypeArg XTypeArg GhcPs
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
split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsTypeArg GhcPs])
split_ty_app :: Type -> CvtM (Type, HsFamEqnPats GhcPs)
split_ty_app Type
ty = Type
-> [HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
-> CvtM'
ConversionFailReason
(Type,
[HsArg
GhcPs
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))])
forall {p}.
(XValArg p ~ NoExtField, XArgPar p ~ SrcSpan,
NoAnn (XTypeArg p)) =>
Type
-> [HsArg
p
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
-> CvtM'
ConversionFailReason
(Type,
[HsArg
p
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))])
go Type
ty []
where
go :: Type
-> [HsArg
p
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
-> CvtM'
ConversionFailReason
(Type,
[HsArg
p
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))])
go (AppT Type
f Type
a) [HsArg
p
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
as' = do { a' <- Type -> CvtM' ConversionFailReason (LHsType GhcPs)
cvtType Type
a; go f (HsValArg noExtField a':as') }
go (AppKindT Type
ty Type
ki) [HsArg
p
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
as' = do { ki' <- Type -> CvtM' ConversionFailReason (LHsType GhcPs)
cvtKind Type
ki
; go ty (HsTypeArg noAnn ki' : as') }
go (ParensT Type
t) [HsArg
p
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
as' = do { loc <- CvtM SrcSpan
getL; go t (HsArgPar loc: as') }
go Type
f [HsArg
p
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
as = (Type,
[HsArg
p
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))])
-> CvtM'
ConversionFailReason
(Type,
[HsArg
p
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))])
forall a. a -> CvtM' ConversionFailReason a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
f,[HsArg
p
(GenLocated SrcSpanAnnA (HsType GhcPs))
(GenLocated SrcSpanAnnA (HsType GhcPs))]
as)
cvtTyLit :: TH.TyLit -> HsTyLit (GhcPass p)
cvtTyLit :: forall (p :: Pass). TyLit -> HsTyLit (GhcPass p)
cvtTyLit (TH.NumTyLit Integer
i) = XNumTy (GhcPass p) -> Integer -> HsTyLit (GhcPass p)
forall pass. XNumTy pass -> Integer -> HsTyLit pass
HsNumTy XNumTy (GhcPass p)
SourceText
NoSourceText Integer
i
cvtTyLit (TH.StrTyLit String
s) = XStrTy (GhcPass p) -> FastString -> HsTyLit (GhcPass p)
forall pass. XStrTy pass -> FastString -> HsTyLit pass
HsStrTy XStrTy (GhcPass p)
SourceText
NoSourceText (String -> FastString
fsLit String
s)
cvtTyLit (TH.CharTyLit Char
c) = XCharTy (GhcPass p) -> Char -> HsTyLit (GhcPass p)
forall pass. XCharTy pass -> Char -> HsTyLit pass
HsCharTy XCharTy (GhcPass p)
SourceText
NoSourceText Char
c
cvtOpAppT :: PromotionFlag -> TH.Type -> LocatedN RdrName -> LHsType GhcPs -> CvtM (LHsType GhcPs)
cvtOpAppT :: PromotionFlag
-> Type
-> LocatedN RdrName
-> LHsType GhcPs
-> CvtM' ConversionFailReason (LHsType GhcPs)
cvtOpAppT PromotionFlag
prom (UInfixT Type
x Name
op2 Type
y) LocatedN RdrName
op1 LHsType GhcPs
z
= do { op2' <- Name -> CvtM (LocatedN RdrName)
tconNameN Name
op2
; l <- cvtOpAppT prom y op1 z
; cvtOpAppT NotPromoted x op2' l }
cvtOpAppT PromotionFlag
prom (PromotedUInfixT Type
x Name
op2 Type
y) LocatedN RdrName
op1 LHsType GhcPs
z
= do { op2' <- Name -> CvtM (LocatedN RdrName)
cNameN Name
op2
; l <- cvtOpAppT prom y op1 z
; cvtOpAppT IsPromoted x op2' l }
cvtOpAppT PromotionFlag
prom Type
x LocatedN RdrName
op LHsType GhcPs
y
= do { x' <- Type -> CvtM' ConversionFailReason (LHsType GhcPs)
cvtType Type
x
; returnLA (mkHsOpTy prom x' op y) }
cvtKind :: TH.Kind -> CvtM (LHsKind GhcPs)
cvtKind :: Type -> CvtM' ConversionFailReason (LHsType GhcPs)
cvtKind = TypeOrKind -> Type -> CvtM' ConversionFailReason (LHsType GhcPs)
cvtTypeKind TypeOrKind
KindLevel
cvtSigKind :: TH.Kind -> CvtM (LHsSigType GhcPs)
cvtSigKind :: Type -> CvtM (LHsSigType GhcPs)
cvtSigKind = TypeOrKind -> Type -> CvtM (LHsSigType GhcPs)
cvtSigTypeKind TypeOrKind
KindLevel
cvtMaybeKindToFamilyResultSig :: Maybe TH.Kind
-> CvtM (LFamilyResultSig GhcPs)
cvtMaybeKindToFamilyResultSig :: Maybe Type -> CvtM (LFamilyResultSig GhcPs)
cvtMaybeKindToFamilyResultSig Maybe Type
Nothing = FamilyResultSig GhcPs
-> CvtM'
ConversionFailReason (GenLocated EpAnnCO (FamilyResultSig GhcPs))
forall ann e. NoAnn ann => e -> CvtM (LocatedAn ann e)
returnLA (XNoSig GhcPs -> FamilyResultSig GhcPs
forall pass. XNoSig pass -> FamilyResultSig pass
Hs.NoSig XNoSig GhcPs
NoExtField
noExtField)
cvtMaybeKindToFamilyResultSig (Just Type
ki) = do { ki' <- Type -> CvtM' ConversionFailReason (LHsType GhcPs)
cvtKind Type
ki
; returnLA (Hs.KindSig noExtField ki') }
cvtFamilyResultSig :: TH.FamilyResultSig -> CvtM (Hs.LFamilyResultSig GhcPs)
cvtFamilyResultSig :: FamilyResultSig -> CvtM (LFamilyResultSig GhcPs)
cvtFamilyResultSig FamilyResultSig
TH.NoSig = FamilyResultSig GhcPs
-> CvtM'
ConversionFailReason (GenLocated EpAnnCO (FamilyResultSig GhcPs))
forall ann e. NoAnn ann => e -> CvtM (LocatedAn ann e)
returnLA (XNoSig GhcPs -> FamilyResultSig GhcPs
forall pass. XNoSig pass -> FamilyResultSig pass
Hs.NoSig XNoSig GhcPs
NoExtField
noExtField)
cvtFamilyResultSig (TH.KindSig Type
ki) = do { ki' <- Type -> CvtM' ConversionFailReason (LHsType GhcPs)
cvtKind Type
ki
; returnLA (Hs.KindSig noExtField ki') }
cvtFamilyResultSig (TH.TyVarSig TyVarBndr ()
bndr) = do { tv <- TyVarBndr () -> CvtM (LHsTyVarBndr () GhcPs)
forall flag flag'.
CvtFlag flag flag' =>
TyVarBndr flag -> CvtM (LHsTyVarBndr flag' GhcPs)
cvt_tv TyVarBndr ()
bndr
; returnLA (Hs.TyVarSig noExtField tv) }
cvtInjectivityAnnotation :: TH.InjectivityAnn
-> CvtM (Hs.LInjectivityAnn GhcPs)
cvtInjectivityAnnotation :: InjectivityAnn -> CvtM (LInjectivityAnn GhcPs)
cvtInjectivityAnnotation (TH.InjectivityAnn Name
annLHS [Name]
annRHS)
= do { annLHS' <- Name -> CvtM (LocatedN RdrName)
tNameN Name
annLHS
; annRHS' <- mapM tNameN annRHS
; returnLA (Hs.InjectivityAnn noAnn annLHS' annRHS') }
cvtPatSynSigTy :: TH.Type -> CvtM (LHsSigType GhcPs)
cvtPatSynSigTy :: Type -> CvtM (LHsSigType GhcPs)
cvtPatSynSigTy (ForallT [TyVarBndr Specificity]
univs [Type]
reqs (ForallT [TyVarBndr Specificity]
exis [Type]
provs Type
ty))
| [TyVarBndr Specificity] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVarBndr Specificity]
exis, [Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
provs = Type -> CvtM (LHsSigType GhcPs)
cvtSigType ([TyVarBndr Specificity] -> [Type] -> Type -> Type
ForallT [TyVarBndr Specificity]
univs [Type]
reqs Type
ty)
| [TyVarBndr Specificity] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVarBndr Specificity]
univs, [Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
reqs = do { ty' <- Type -> CvtM' ConversionFailReason (LHsType GhcPs)
cvtType ([TyVarBndr Specificity] -> [Type] -> Type -> Type
ForallT [TyVarBndr Specificity]
exis [Type]
provs Type
ty)
; ctxt' <- returnLA []
; cxtTy <- wrapParLA mkHsImplicitSigType $
HsQualTy { hst_ctxt = ctxt'
, hst_xqual = noExtField
, hst_body = ty' }
; returnLA cxtTy }
| [Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
reqs = do { univs' <- [TyVarBndr Specificity] -> CvtM [LHsTyVarBndr Specificity GhcPs]
forall flag flag'.
CvtFlag flag flag' =>
[TyVarBndr flag] -> CvtM [LHsTyVarBndr flag' GhcPs]
cvtTvs [TyVarBndr Specificity]
univs
; ty' <- cvtType (ForallT exis provs ty)
; ctxt' <- returnLA []
; let cxtTy = HsQualTy { hst_ctxt :: LHsContext GhcPs
hst_ctxt = LHsContext GhcPs
LocatedAn AnnContext [LHsType GhcPs]
ctxt'
, hst_xqual :: XQualTy GhcPs
hst_xqual = XQualTy GhcPs
NoExtField
noExtField
, hst_body :: LHsType GhcPs
hst_body = LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
ty' }
; forTy <- wrapParLA (mkHsExplicitSigType noAnn univs') cxtTy
; returnLA forTy }
| Bool
otherwise = Type -> CvtM (LHsSigType GhcPs)
cvtSigType ([TyVarBndr Specificity] -> [Type] -> Type -> Type
ForallT [TyVarBndr Specificity]
univs [Type]
reqs ([TyVarBndr Specificity] -> [Type] -> Type -> Type
ForallT [TyVarBndr Specificity]
exis [Type]
provs Type
ty))
cvtPatSynSigTy Type
ty = Type -> CvtM (LHsSigType GhcPs)
cvtSigType Type
ty
cvtFixity :: TH.Fixity -> Hs.Fixity
cvtFixity :: Fixity -> Fixity
cvtFixity (TH.Fixity SumAlt
prec FixityDirection
dir) = SumAlt -> FixityDirection -> Fixity
Hs.Fixity SumAlt
prec (FixityDirection -> FixityDirection
cvt_dir FixityDirection
dir)
where
cvt_dir :: FixityDirection -> FixityDirection
cvt_dir FixityDirection
TH.InfixL = FixityDirection
Hs.InfixL
cvt_dir FixityDirection
TH.InfixR = FixityDirection
Hs.InfixR
cvt_dir FixityDirection
TH.InfixN = FixityDirection
Hs.InfixN
overloadedLit :: Lit -> Bool
overloadedLit :: Lit -> Bool
overloadedLit (IntegerL Integer
_) = Bool
True
overloadedLit (RationalL Rational
_) = Bool
True
overloadedLit Lit
_ = Bool
False
unboxedSumChecks :: TH.SumAlt -> TH.SumArity -> CvtM ()
unboxedSumChecks :: SumAlt -> SumAlt -> CvtM ()
unboxedSumChecks SumAlt
alt SumAlt
arity
| SumAlt
alt SumAlt -> SumAlt -> Bool
forall a. Ord a => a -> a -> Bool
> SumAlt
arity
= ConversionFailReason -> CvtM ()
forall a. ConversionFailReason -> CvtM a
failWith (ConversionFailReason -> CvtM ())
-> ConversionFailReason -> CvtM ()
forall a b. (a -> b) -> a -> b
$ SumAlt -> SumAlt -> ConversionFailReason
SumAltArityExceeded SumAlt
alt SumAlt
arity
| SumAlt
alt SumAlt -> SumAlt -> Bool
forall a. Ord a => a -> a -> Bool
<= SumAlt
0
= ConversionFailReason -> CvtM ()
forall a. ConversionFailReason -> CvtM a
failWith (ConversionFailReason -> CvtM ())
-> ConversionFailReason -> CvtM ()
forall a b. (a -> b) -> a -> b
$ SumAlt -> ConversionFailReason
IllegalSumAlt SumAlt
alt
| SumAlt
arity SumAlt -> SumAlt -> Bool
forall a. Ord a => a -> a -> Bool
< SumAlt
2
= ConversionFailReason -> CvtM ()
forall a. ConversionFailReason -> CvtM a
failWith (ConversionFailReason -> CvtM ())
-> ConversionFailReason -> CvtM ()
forall a b. (a -> b) -> a -> b
$ SumAlt -> ConversionFailReason
IllegalSumArity SumAlt
arity
| Bool
otherwise
= () -> CvtM ()
forall a. a -> CvtM' ConversionFailReason a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
mkHsForAllTy :: SrcSpanAnnA
-> HsForAllTelescope GhcPs
-> LHsType GhcPs
-> LHsType GhcPs
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 = XForAllTy GhcPs
NoExtField
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 a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LHsTyVarBndr () GhcPs]
[GenLocated SrcSpanAnnA (HsTyVarBndr () 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 a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LHsTyVarBndr Specificity GhcPs]
[GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)]
bndrs
mkHsQualTy :: TH.Cxt
-> SrcSpanAnnA
-> LHsContext GhcPs
-> LHsType GhcPs
-> LHsType GhcPs
mkHsQualTy :: [Type]
-> SrcSpanAnnA
-> LHsContext GhcPs
-> LHsType GhcPs
-> LHsType GhcPs
mkHsQualTy [Type]
ctxt SrcSpanAnnA
loc LHsContext GhcPs
ctxt' LHsType GhcPs
ty
| [Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
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 = XQualTy GhcPs
NoExtField
noExtField
, hst_ctxt :: LHsContext GhcPs
hst_ctxt = LHsContext GhcPs
ctxt'
, hst_body :: LHsType GhcPs
hst_body = LHsType GhcPs
ty }
mkHsContextMaybe :: LHsContext GhcPs -> Maybe (LHsContext GhcPs)
mkHsContextMaybe :: LHsContext GhcPs -> Maybe (LHsContext GhcPs)
mkHsContextMaybe lctxt :: LHsContext GhcPs
lctxt@(L EpAnn AnnContext
_ [GenLocated SrcSpanAnnA (HsType GhcPs)]
ctxt)
| [GenLocated SrcSpanAnnA (HsType GhcPs)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated SrcSpanAnnA (HsType GhcPs)]
ctxt = Maybe (LHsContext GhcPs)
Maybe
(GenLocated
(EpAnn AnnContext) [GenLocated SrcSpanAnnA (HsType GhcPs)])
forall a. Maybe a
Nothing
| Bool
otherwise = GenLocated
(EpAnn AnnContext) [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> Maybe
(GenLocated
(EpAnn AnnContext) [GenLocated SrcSpanAnnA (HsType GhcPs)])
forall a. a -> Maybe a
Just LHsContext GhcPs
GenLocated
(EpAnn AnnContext) [GenLocated SrcSpanAnnA (HsType GhcPs)]
lctxt
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 (EpAnnForallInvis
-> [LHsTyVarBndr () GhcPs] -> HsOuterFamEqnTyVarBndrs GhcPs
forall flag.
EpAnnForallInvis
-> [LHsTyVarBndr flag GhcPs] -> HsOuterTyVarBndrs flag GhcPs
mkHsOuterExplicit EpAnnForallInvis
forall a. NoAnn a => a
noAnn)
vNameN, cNameN, vcNameN, tNameN, tconNameN, dNameN :: TH.Name -> CvtM (LocatedN RdrName)
vNameL :: TH.Name -> CvtM (LocatedA RdrName)
vName, cName, vcName, tName, tconName, dName :: TH.Name -> CvtM RdrName
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
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
dNameN :: Name -> CvtM (LocatedN RdrName)
dNameN Name
n = CvtM RdrName -> CvtM (LocatedN RdrName)
forall a. CvtM a -> CvtM (LocatedN a)
wrapLN (Name -> CvtM RdrName
dName Name
n)
dName :: Name -> CvtM RdrName
dName Name
n = Name -> CvtM RdrName
cName Name
n CvtM RdrName -> CvtM RdrName -> CvtM RdrName
forall err a. CvtM' err a -> CvtM' err a -> CvtM' err a
`orOnFail` Name -> CvtM RdrName
tconName Name
n
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
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
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
fldName :: String -> TH.Name -> CvtM RdrName
fldName :: String -> Name -> CvtM RdrName
fldName String
con Name
n = NameSpace -> Name -> CvtM RdrName
cvtName (FastString -> NameSpace
OccName.fieldName (FastString -> NameSpace) -> FastString -> NameSpace
forall a b. (a -> b) -> a -> b
$ String -> FastString
fsLit String
con) Name
n
fldNameN :: String -> TH.Name -> CvtM (LocatedN RdrName)
fldNameN :: String -> Name -> CvtM (LocatedN RdrName)
fldNameN String
con Name
n = CvtM RdrName -> CvtM (LocatedN RdrName)
forall a. CvtM a -> CvtM (LocatedN a)
wrapLN (String -> Name -> CvtM RdrName
fldName String
con 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) (ConversionFailReason -> CvtM ()
forall a. ConversionFailReason -> CvtM a
failWith (NameSpace -> String -> ConversionFailReason
IllegalOccName NameSpace
OccName.varName String
n))
; HsIPName -> CvtM HsIPName
forall a. a -> CvtM' ConversionFailReason a
forall (m :: * -> *) a. Monad m => a -> m a
return (FastString -> HsIPName
HsIPName (String -> FastString
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) = ConversionFailReason -> CvtM RdrName
forall a. ConversionFailReason -> CvtM a
failWith (NameSpace -> String -> ConversionFailReason
IllegalOccName NameSpace
ctxt_ns String
occ_str)
| Bool
otherwise
= do { loc <- CvtM SrcSpan
getL
; let rdr_name = SrcSpan -> NameSpace -> String -> NameFlavour -> RdrName
thRdrName SrcSpan
loc NameSpace
ctxt_ns String
occ_str NameFlavour
flavour
; force rdr_name
; return rdr_name }
where
occ_str :: String
occ_str = OccName -> String
TH.occString OccName
occ
okOcc :: OccName.NameSpace -> String -> Bool
okOcc :: NameSpace -> String -> Bool
okOcc NameSpace
ns String
str
| NameSpace -> Bool
OccName.isVarNameSpace NameSpace
ns = String -> Bool
okVarOcc String
str
| NameSpace -> Bool
OccName.isDataConNameSpace NameSpace
ns = String -> Bool
okConOcc String
str
| Bool
otherwise = String -> Bool
okTcOcc String
str
isVarName :: TH.Name -> Bool
isVarName :: Name -> Bool
isVarName (TH.Name OccName
occ NameFlavour
_)
= case OccName -> String
TH.occString OccName
occ of
String
"" -> Bool
False
(Char
c:String
_) -> Char -> Bool
startsVarId Char
c Bool -> Bool -> Bool
|| Char -> Bool
startsVarSym Char
c
thRdrName :: SrcSpan -> OccName.NameSpace -> String -> TH.NameFlavour -> RdrName
thRdrName :: SrcSpan -> NameSpace -> String -> NameFlavour -> RdrName
thRdrName SrcSpan
loc NameSpace
ctxt_ns String
th_occ NameFlavour
th_name
= case NameFlavour
th_name of
TH.NameG NameSpace
th_ns PkgName
pkg ModName
mod -> String -> NameSpace -> PkgName -> ModName -> RdrName
thOrigRdrName String
th_occ NameSpace
th_ns PkgName
pkg ModName
mod
TH.NameQ ModName
mod -> (ModuleName -> OccName -> RdrName
mkRdrQual (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
$! Word64 -> Unique
mk_uniq (Integer -> Word64
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
$! Word64 -> Unique
mk_uniq (Integer -> Word64
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
where
occ :: OccName.OccName
occ :: OccName
occ = NameSpace -> String -> OccName
mk_occ NameSpace
ctxt_ns String
th_occ
thOrigRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName
thOrigRdrName :: String -> NameSpace -> PkgName -> ModName -> RdrName
thOrigRdrName String
occ NameSpace
th_ns PkgName
pkg ModName
mod =
let occ' :: OccName
occ' = NameSpace -> String -> OccName
mk_occ (NameSpace -> NameSpace
mk_ghc_ns NameSpace
th_ns) String
occ
mod' :: GenModule Unit
mod' = Unit -> ModuleName -> GenModule Unit
forall u. u -> ModuleName -> GenModule u
mkModule (PkgName -> Unit
mk_pkg PkgName
pkg) (ModName -> ModuleName
mk_mod ModName
mod)
in case OccName -> Maybe Name
isBuiltInOcc_maybe OccName
occ' Maybe Name -> Maybe Name -> Maybe Name
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> GenModule Unit -> OccName -> Maybe Name
isPunOcc_maybe GenModule Unit
mod' OccName
occ' of
Just Name
name -> Name -> RdrName
nameRdrName Name
name
Maybe Name
Nothing -> (GenModule Unit -> OccName -> RdrName
mkOrig (GenModule Unit -> OccName -> RdrName)
-> GenModule Unit -> OccName -> RdrName
forall a b. (a -> b) -> a -> b
$! GenModule Unit
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)
| TH.NameG NameSpace
th_ns PkgName
pkg ModName
mod <- NameFlavour
flavour = [ String -> NameSpace -> PkgName -> ModName -> RdrName
thOrigRdrName String
occ_str NameSpace
th_ns PkgName
pkg ModName
mod]
| Bool
otherwise = [ SrcSpan -> NameSpace -> String -> NameFlavour -> RdrName
thRdrName SrcSpan
noSrcSpan NameSpace
gns String
occ_str NameFlavour
flavour
| NameSpace
gns <- [NameSpace]
guessed_nss]
where
guessed_nss :: [NameSpace]
guessed_nss
| FastString -> Bool
isLexCon FastString
occ_txt = [NameSpace
OccName.tcName, NameSpace
OccName.dataName]
| FastString -> Bool
isLexVarSym FastString
occ_txt = [NameSpace
OccName.tcName, NameSpace
OccName.varName]
| Bool
otherwise = [NameSpace
OccName.varName, NameSpace
OccName.tvName]
occ_str :: String
occ_str = OccName -> String
TH.occString OccName
occ
occ_txt :: FastString
occ_txt = String -> FastString
mkFastString String
occ_str
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_ghc_ns (TH.FldName String
con) = FastString -> NameSpace
OccName.fieldName (String -> FastString
fsLit String
con)
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 :: Word64 -> Unique
mk_uniq :: Word64 -> Unique
mk_uniq Word64
u = Word64 -> Unique
mkUniqueGrimily Word64
u