{-# LANGUAGE CPP             #-}
{-# LANGUAGE RecordWildCards #-}
module Overloaded.Plugin.HasConstructor where

import Control.Monad (forM)
import Data.List     (find)
import Data.Maybe    (mapMaybe)

import qualified GHC.Compat.All  as GHC

#if MIN_VERSION_ghc(9,0,0)
import qualified GHC.Tc.Plugin as Plugins
#else
import qualified TcPluginM as Plugins
#endif

import Overloaded.Plugin.Diagnostics
import Overloaded.Plugin.TcPlugin.Ctx
import Overloaded.Plugin.TcPlugin.Utils
import Overloaded.Plugin.V

ifDebug :: Monad m => m () -> m ()
ifDebug :: m () -> m ()
ifDebug m ()
_ = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

solveHasConstructor
    :: PluginCtx
    -> GHC.DynFlags
    -> (GHC.FamInstEnv, GHC.FamInstEnv)
    -> GHC.GlobalRdrEnv
    -> [GHC.Ct]
    -> Plugins.TcPluginM [(Maybe (GHC.EvTerm, [GHC.Ct]), GHC.Ct)]
solveHasConstructor :: PluginCtx
-> DynFlags
-> (FamInstEnv, FamInstEnv)
-> GlobalRdrEnv
-> [Ct]
-> TcPluginM [(Maybe (EvTerm, [Ct]), Ct)]
solveHasConstructor PluginCtx {Class
hasPolyConCls :: PluginCtx -> Class
hasPolyFieldCls :: PluginCtx -> Class
hasPolyConCls :: Class
hasPolyFieldCls :: Class
..} DynFlags
dflags (FamInstEnv, FamInstEnv)
famInstEnvs GlobalRdrEnv
rdrEnv [Ct]
wanteds =
    [(Ct, V4 Type)]
-> ((Ct, V4 Type) -> TcPluginM (Maybe (EvTerm, [Ct]), Ct))
-> TcPluginM [(Maybe (EvTerm, [Ct]), Ct)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Ct, V4 Type)]
wantedsHasPolyCon (((Ct, V4 Type) -> TcPluginM (Maybe (EvTerm, [Ct]), Ct))
 -> TcPluginM [(Maybe (EvTerm, [Ct]), Ct)])
-> ((Ct, V4 Type) -> TcPluginM (Maybe (EvTerm, [Ct]), Ct))
-> TcPluginM [(Maybe (EvTerm, [Ct]), Ct)]
forall a b. (a -> b) -> a -> b
$ \(Ct
ct, tys :: V4 Type
tys@(V4 Type
_k Type
_name Type
_s Type
a)) -> do
        -- Plugins.tcPluginIO $ warn dflags noSrcSpan $
        --     GHC.text "HasConstructor wanted" GHC.<+> GHC.ppr ct

        Maybe (TyCon, DataCon, [Type], [Type])
m <- TcM (Maybe (TyCon, DataCon, [Type], [Type]))
-> TcPluginM (Maybe (TyCon, DataCon, [Type], [Type]))
forall a. TcM a -> TcPluginM a
GHC.unsafeTcPluginTcM (TcM (Maybe (TyCon, DataCon, [Type], [Type]))
 -> TcPluginM (Maybe (TyCon, DataCon, [Type], [Type])))
-> TcM (Maybe (TyCon, DataCon, [Type], [Type]))
-> TcPluginM (Maybe (TyCon, DataCon, [Type], [Type]))
forall a b. (a -> b) -> a -> b
$ DynFlags
-> (FamInstEnv, FamInstEnv)
-> GlobalRdrEnv
-> V4 Type
-> TcM (Maybe (TyCon, DataCon, [Type], [Type]))
matchHasConstructor DynFlags
dflags (FamInstEnv, FamInstEnv)
famInstEnvs GlobalRdrEnv
rdrEnv V4 Type
tys
        (Maybe (EvTerm, [Ct]) -> (Maybe (EvTerm, [Ct]), Ct))
-> TcPluginM (Maybe (EvTerm, [Ct]))
-> TcPluginM (Maybe (EvTerm, [Ct]), Ct)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Maybe (EvTerm, [Ct])
evTerm -> (Maybe (EvTerm, [Ct])
evTerm, Ct
ct)) (TcPluginM (Maybe (EvTerm, [Ct]))
 -> TcPluginM (Maybe (EvTerm, [Ct]), Ct))
-> TcPluginM (Maybe (EvTerm, [Ct]))
-> TcPluginM (Maybe (EvTerm, [Ct]), Ct)
forall a b. (a -> b) -> a -> b
$ Maybe (TyCon, DataCon, [Type], [Type])
-> ((TyCon, DataCon, [Type], [Type]) -> TcPluginM (EvTerm, [Ct]))
-> TcPluginM (Maybe (EvTerm, [Ct]))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe (TyCon, DataCon, [Type], [Type])
m (((TyCon, DataCon, [Type], [Type]) -> TcPluginM (EvTerm, [Ct]))
 -> TcPluginM (Maybe (EvTerm, [Ct])))
-> ((TyCon, DataCon, [Type], [Type]) -> TcPluginM (EvTerm, [Ct]))
-> TcPluginM (Maybe (EvTerm, [Ct]))
forall a b. (a -> b) -> a -> b
$ \(TyCon
tc, DataCon
dc, [Type]
args, [Type]
xs) -> do
            -- get location
            let ctloc :: CtLoc
ctloc = Ct -> CtLoc
GHC.ctLoc Ct
ct
            let l :: SrcSpan
l = RealSrcSpan -> SrcSpan
GHC.RealSrcSpan (CtLoc -> RealSrcSpan
GHC.ctLocSpan CtLoc
ctloc)
#if MIN_VERSION_ghc(9,0,0)
                        Nothing
#endif

            TcPluginM () -> TcPluginM ()
forall (m :: * -> *). Monad m => m () -> m ()
ifDebug (TcPluginM () -> TcPluginM ()) -> TcPluginM () -> TcPluginM ()
forall a b. (a -> b) -> a -> b
$ IO () -> TcPluginM ()
forall a. IO a -> TcPluginM a
Plugins.tcPluginIO (IO () -> TcPluginM ()) -> IO () -> TcPluginM ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> SrcSpan -> SDoc -> IO ()
forall (m :: * -> *).
MonadIO m =>
DynFlags -> SrcSpan -> SDoc -> m ()
warn DynFlags
dflags SrcSpan
l (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
                String -> SDoc
GHC.text String
"DEBUG1"
                    SDoc -> SDoc -> SDoc
GHC.$$ TyCon -> SDoc
forall a. Outputable a => a -> SDoc
GHC.ppr TyCon
tc
                    SDoc -> SDoc -> SDoc
GHC.$$ DataCon -> SDoc
forall a. Outputable a => a -> SDoc
GHC.ppr DataCon
dc
                    SDoc -> SDoc -> SDoc
GHC.$$ [Type] -> SDoc
forall a. Outputable a => a -> SDoc
GHC.ppr [Type]
args
                    SDoc -> SDoc -> SDoc
GHC.$$ [Type] -> SDoc
forall a. Outputable a => a -> SDoc
GHC.ppr [Type]
xs

            -- "s"
            let s' :: Type
s' = TyCon -> [Type] -> Type
GHC.mkTyConApp TyCon
tc [Type]
args

            -- type of constructor fields:
            -- - for unary constructors we use the field
            -- - for nullary we use unit
            -- - for others we wrap them in tuple.
            let a' :: GHC.Type
                a' :: Type
a' = case [Type]
xs of
                    [Type
x] -> Type
x
                    [Type]
_   -> [Type] -> Type
GHC.mkBoxedTupleTy [Type]
xs
                    -- TODO: nullary
                    -- TODO: multiple

            -- let b' = a'
            --     t' = s'

            let tupleDataCon :: GHC.DataCon
                tupleDataCon :: DataCon
tupleDataCon = Boxity -> Arity -> DataCon
GHC.tupleDataCon Boxity
GHC.Boxed ([Type] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [Type]
xs)

            TcPluginM () -> TcPluginM ()
forall (m :: * -> *). Monad m => m () -> m ()
ifDebug (TcPluginM () -> TcPluginM ()) -> TcPluginM () -> TcPluginM ()
forall a b. (a -> b) -> a -> b
$ IO () -> TcPluginM ()
forall a. IO a -> TcPluginM a
Plugins.tcPluginIO (IO () -> TcPluginM ()) -> IO () -> TcPluginM ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> SrcSpan -> SDoc -> IO ()
forall (m :: * -> *).
MonadIO m =>
DynFlags -> SrcSpan -> SDoc -> m ()
warn DynFlags
dflags SrcSpan
l (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
                String -> SDoc
GHC.text String
"DEBUG2"
                    SDoc -> SDoc -> SDoc
GHC.$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
GHC.ppr Type
s'
                    SDoc -> SDoc -> SDoc
GHC.$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
GHC.ppr Type
a'

            -- build
            CoreExpr
exprBuild <- case [Type]
xs of
                -- unary: \a -> DC a
                [Type
_] -> do
                    Var
x <- String -> Type -> TcPluginM Var
makeVar String
"x" Type
a'
                    CoreExpr -> TcPluginM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> TcPluginM CoreExpr) -> CoreExpr -> TcPluginM CoreExpr
forall a b. (a -> b) -> a -> b
$ [Var] -> CoreExpr -> CoreExpr
GHC.mkCoreLams [Var
x] (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ DataCon -> [Type] -> [Var] -> CoreExpr
forall b. DataCon -> [Type] -> [Var] -> Expr b
GHC.mkConApp2 DataCon
dc [Type]
args [Var
x]

                -- nullary: \ (_unused :: ()) -> DC
                [] -> do
                    Var
unused <- String -> Type -> TcPluginM Var
makeVar String
"_unused" Type
a'
                    CoreExpr -> TcPluginM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> TcPluginM CoreExpr) -> CoreExpr -> TcPluginM CoreExpr
forall a b. (a -> b) -> a -> b
$ [Var] -> CoreExpr -> CoreExpr
GHC.mkCoreLams [Var
unused] (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ DataCon -> [Type] -> [Var] -> CoreExpr
forall b. DataCon -> [Type] -> [Var] -> Expr b
GHC.mkConApp2 DataCon
dc [Type]
args []

                -- multi: \ (a :: a) -> case a of
                --    (x1, ..., xn) -> DC x1 ... xn
                [Type]
_ -> do
                    Var
aBndr <- String -> Type -> TcPluginM Var
makeVar String
"a" Type
a'
                    [Var]
xs' <- String -> [Type] -> TcPluginM [Var]
makeVars String
"x" [Type]
xs
                    CoreExpr -> TcPluginM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> TcPluginM CoreExpr) -> CoreExpr -> TcPluginM CoreExpr
forall a b. (a -> b) -> a -> b
$ [Var] -> CoreExpr -> CoreExpr
GHC.mkCoreLams [Var
aBndr] (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> Var -> Type -> [Alt Var] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
GHC.Case (Var -> CoreExpr
forall b. Var -> Expr b
GHC.Var Var
aBndr) Var
aBndr Type
s'
                        [( DataCon -> AltCon
GHC.DataAlt DataCon
tupleDataCon  -- (,,,)
                        , [Var]
xs'                        -- x1 ... xn
                        , DataCon -> [Type] -> [Var] -> CoreExpr
forall b. DataCon -> [Type] -> [Var] -> Expr b
GHC.mkConApp2 DataCon
dc [Type]
args [Var]
xs'  -- DC x1 ... xn
                        )]

            TcPluginM () -> TcPluginM ()
forall (m :: * -> *). Monad m => m () -> m ()
ifDebug (TcPluginM () -> TcPluginM ()) -> TcPluginM () -> TcPluginM ()
forall a b. (a -> b) -> a -> b
$ IO () -> TcPluginM ()
forall a. IO a -> TcPluginM a
Plugins.tcPluginIO (IO () -> TcPluginM ()) -> IO () -> TcPluginM ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> SrcSpan -> SDoc -> IO ()
forall (m :: * -> *).
MonadIO m =>
DynFlags -> SrcSpan -> SDoc -> m ()
warn DynFlags
dflags SrcSpan
l (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
                String -> SDoc
GHC.text String
"DEBUG-build"
                    SDoc -> SDoc -> SDoc
GHC.$$ CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
GHC.ppr CoreExpr
exprBuild

            -- match
            CoreExpr
exprMatch <- case [Type]
xs of
                -- unary: \s -> case s of
                --            DC a -> Just a
                --            _    -> Nothing
                [Type
_] -> do
                    Var
sBndr <- String -> Type -> TcPluginM Var
makeVar String
"s" Type
s'
                    Var
aBndr <- String -> Type -> TcPluginM Var
makeVar String
"a" Type
a'
                    CoreExpr -> TcPluginM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> TcPluginM CoreExpr) -> CoreExpr -> TcPluginM CoreExpr
forall a b. (a -> b) -> a -> b
$ [Var] -> CoreExpr -> CoreExpr
GHC.mkCoreLams [Var
sBndr] (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> Var -> Type -> [Alt Var] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
GHC.Case (Var -> CoreExpr
forall b. Var -> Expr b
GHC.Var Var
sBndr) Var
sBndr
                        (TyCon -> [Type] -> Type
GHC.mkTyConApp TyCon
GHC.maybeTyCon [Type
a'])
                        -- default case have to be first.
                        [ (AltCon
GHC.DEFAULT, [], DataCon -> [Type] -> [Var] -> CoreExpr
forall b. DataCon -> [Type] -> [Var] -> Expr b
GHC.mkConApp2 DataCon
GHC.nothingDataCon [Type
a'] [])
                        , (DataCon -> AltCon
GHC.DataAlt DataCon
dc, [Var
aBndr], DataCon -> [Type] -> [Var] -> CoreExpr
forall b. DataCon -> [Type] -> [Var] -> Expr b
GHC.mkConApp2 DataCon
GHC.justDataCon [Type
a'] [Var
aBndr])
                        ]

                -- nullary: \s -> case s of
                --              DC -> Just ()
                --              _  -> Nothing
                [] -> do
                    Var
sBndr <- String -> Type -> TcPluginM Var
makeVar String
"s" Type
s'
                    CoreExpr -> TcPluginM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> TcPluginM CoreExpr) -> CoreExpr -> TcPluginM CoreExpr
forall a b. (a -> b) -> a -> b
$ [Var] -> CoreExpr -> CoreExpr
GHC.mkCoreLams [Var
sBndr] (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> Var -> Type -> [Alt Var] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
GHC.Case (Var -> CoreExpr
forall b. Var -> Expr b
GHC.Var Var
sBndr) Var
sBndr
                        (TyCon -> [Type] -> Type
GHC.mkTyConApp TyCon
GHC.maybeTyCon [Type
a'])
                        [ (AltCon
GHC.DEFAULT, [], DataCon -> [Type] -> [Var] -> CoreExpr
forall b. DataCon -> [Type] -> [Var] -> Expr b
GHC.mkConApp2 DataCon
GHC.nothingDataCon [Type
a'] [])
                        , (DataCon -> AltCon
GHC.DataAlt DataCon
dc, [], DataCon -> [Type] -> [Var] -> CoreExpr
forall b. DataCon -> [Type] -> [Var] -> Expr b
GHC.mkConApp2 DataCon
GHC.justDataCon [Type
a'] [Var
GHC.unitDataConId])
                        ]

                -- multi: \s -> case s of
                --            DC x1 ... xn -> let a = (x1, ... xn) in Just a
                --            _            -> Nothing
                [Type]
_ -> do
                    Var
sBndr <- String -> Type -> TcPluginM Var
makeVar String
"s" Type
s'
                    Var
aBndr <- String -> Type -> TcPluginM Var
makeVar String
"a" Type
a'
                    [Var]
xs' <- String -> [Type] -> TcPluginM [Var]
makeVars String
"x" [Type]
xs

                    CoreExpr -> TcPluginM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> TcPluginM CoreExpr) -> CoreExpr -> TcPluginM CoreExpr
forall a b. (a -> b) -> a -> b
$ [Var] -> CoreExpr -> CoreExpr
GHC.mkCoreLams [Var
sBndr] (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> Var -> Type -> [Alt Var] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
GHC.Case (Var -> CoreExpr
forall b. Var -> Expr b
GHC.Var Var
sBndr) Var
sBndr
                        (TyCon -> [Type] -> Type
GHC.mkTyConApp TyCon
GHC.maybeTyCon [Type
a'])
                        [ (AltCon
GHC.DEFAULT, [], DataCon -> [Type] -> [Var] -> CoreExpr
forall b. DataCon -> [Type] -> [Var] -> Expr b
GHC.mkConApp2 DataCon
GHC.nothingDataCon [Type
a'] [])
                        , (DataCon -> AltCon
GHC.DataAlt DataCon
dc, [Var]
xs',
                          Bind Var -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
GHC.Let (Var -> CoreExpr -> Bind Var
forall b. b -> Expr b -> Bind b
GHC.NonRec Var
aBndr (CoreExpr -> Bind Var) -> CoreExpr -> Bind Var
forall a b. (a -> b) -> a -> b
$ DataCon -> [Type] -> [Var] -> CoreExpr
forall b. DataCon -> [Type] -> [Var] -> Expr b
GHC.mkConApp2 DataCon
tupleDataCon [Type]
xs [Var]
xs') (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
                          DataCon -> [Type] -> [Var] -> CoreExpr
forall b. DataCon -> [Type] -> [Var] -> Expr b
GHC.mkConApp2 DataCon
GHC.justDataCon [Type
a'] [Var
aBndr])
                        ]

            TcPluginM () -> TcPluginM ()
forall (m :: * -> *). Monad m => m () -> m ()
ifDebug (TcPluginM () -> TcPluginM ()) -> TcPluginM () -> TcPluginM ()
forall a b. (a -> b) -> a -> b
$ IO () -> TcPluginM ()
forall a. IO a -> TcPluginM a
Plugins.tcPluginIO (IO () -> TcPluginM ()) -> IO () -> TcPluginM ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> SrcSpan -> SDoc -> IO ()
forall (m :: * -> *).
MonadIO m =>
DynFlags -> SrcSpan -> SDoc -> m ()
warn DynFlags
dflags SrcSpan
l (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
                String -> SDoc
GHC.text String
"DEBUG-match"
                    SDoc -> SDoc -> SDoc
GHC.$$ CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
GHC.ppr CoreExpr
exprMatch

            -- wanteds
            let evterm :: EvTerm
evterm = Class -> CoreExpr -> CoreExpr -> V4 Type -> EvTerm
makeEvidence4_2 Class
hasPolyConCls CoreExpr
exprBuild CoreExpr
exprMatch V4 Type
tys
            CtEvidence
ctEvidence <- CtLoc -> Type -> TcPluginM CtEvidence
Plugins.newWanted CtLoc
ctloc (Type -> TcPluginM CtEvidence) -> Type -> TcPluginM CtEvidence
forall a b. (a -> b) -> a -> b
$ Type -> Type -> Type
GHC.mkPrimEqPred Type
a Type
a'

            (EvTerm, [Ct]) -> TcPluginM (EvTerm, [Ct])
forall (m :: * -> *) a. Monad m => a -> m a
return (EvTerm
evterm, [ CtEvidence -> Ct
GHC.mkNonCanonical CtEvidence
ctEvidence -- a ~ a'
                            ])

  where
    wantedsHasPolyCon :: [(Ct, V4 Type)]
wantedsHasPolyCon = (Ct -> Maybe (Ct, V4 Type)) -> [Ct] -> [(Ct, V4 Type)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Class -> Ct -> Maybe (Ct, V4 Type)
findClassConstraint4 Class
hasPolyConCls) [Ct]
wanteds

matchHasConstructor
    :: GHC.DynFlags
    -> (GHC.FamInstEnv, GHC.FamInstEnv)
    -> GHC.GlobalRdrEnv
    -> V4 GHC.Type
    -> GHC.TcM (Maybe (GHC.TyCon, GHC.DataCon, [GHC.Type], [GHC.Type]))
matchHasConstructor :: DynFlags
-> (FamInstEnv, FamInstEnv)
-> GlobalRdrEnv
-> V4 Type
-> TcM (Maybe (TyCon, DataCon, [Type], [Type]))
matchHasConstructor DynFlags
_dflags (FamInstEnv, FamInstEnv)
famInstEnvs GlobalRdrEnv
_rdrEnv (V4 Type
_k Type
x Type
s Type
_a)
    -- x should be a literal string
    | Just FastString
xStr <- Type -> Maybe FastString
GHC.isStrLitTy Type
x
    -- s should be an applied type constructor
    , Just (TyCon
tc, [Type]
args) <- HasCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
GHC.tcSplitTyConApp_maybe Type
s
    -- use representation tycon (if data family); it has the fields
    , let s_tc :: TyCon
s_tc = (TyCon, [Type], Coercion) -> TyCon
forall a b c. (a, b, c) -> a
fstOf3 ((FamInstEnv, FamInstEnv)
-> TyCon -> [Type] -> (TyCon, [Type], Coercion)
GHC.tcLookupDataFamInst (FamInstEnv, FamInstEnv)
famInstEnvs TyCon
tc [Type]
args)
    -- x should be constructor of r
    , Just [DataCon]
dcs <- TyCon -> Maybe [DataCon]
GHC.tyConDataCons_maybe TyCon
s_tc
    , Just DataCon
dc  <- (DataCon -> Bool) -> [DataCon] -> Maybe DataCon
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\DataCon
dc -> Name -> FastString
forall a. NamedThing a => a -> FastString
GHC.getOccFS (DataCon -> Name
GHC.dataConName DataCon
dc) FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
== FastString
xStr) [DataCon]
dcs
    -- TODO: check that data con is in scope

    -- check that exist and theta are empty, this makes things simpler!
    , ([], [], [Type]
xs) <- DataCon -> [Type] -> ([Var], [Type], [Type])
GHC.dataConInstSig DataCon
dc [Type]
args

    = Maybe (TyCon, DataCon, [Type], [Type])
-> TcM (Maybe (TyCon, DataCon, [Type], [Type]))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (TyCon, DataCon, [Type], [Type])
 -> TcM (Maybe (TyCon, DataCon, [Type], [Type])))
-> Maybe (TyCon, DataCon, [Type], [Type])
-> TcM (Maybe (TyCon, DataCon, [Type], [Type]))
forall a b. (a -> b) -> a -> b
$ (TyCon, DataCon, [Type], [Type])
-> Maybe (TyCon, DataCon, [Type], [Type])
forall a. a -> Maybe a
Just (TyCon
tc, DataCon
dc, [Type]
args, [Type]
xs)

matchHasConstructor DynFlags
_ (FamInstEnv, FamInstEnv)
_ GlobalRdrEnv
_ V4 Type
_ = Maybe (TyCon, DataCon, [Type], [Type])
-> TcM (Maybe (TyCon, DataCon, [Type], [Type]))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (TyCon, DataCon, [Type], [Type])
forall a. Maybe a
Nothing