{-# LANGUAGE OverloadedStrings #-}

{-# LANGUAGE NoMonoLocalBinds  #-}

module Wingman.EmptyCase where

import           Control.Applicative (empty)
import           Control.Monad
import           Control.Monad.Except (runExcept)
import           Control.Monad.Trans
import           Control.Monad.Trans.Maybe
import           Data.Aeson
import           Data.Generics.Aliases (mkQ, GenericQ)
import           Data.Generics.Schemes (everything)
import           Data.Maybe
import           Data.Monoid
import qualified Data.Text as T
import           Data.Traversable
import           Development.IDE (hscEnv)
import           Development.IDE (realSrcSpanToRange)
import           Development.IDE.Core.RuleTypes
import           Development.IDE.Core.Shake (IdeState (..))
import           Development.IDE.Core.UseStale
import           Development.IDE.GHC.Compat
import           Development.IDE.GHC.ExactPrint
import           Development.IDE.Spans.LocalBindings (getLocalScope)
import           Ide.Types
import           Language.LSP.Server
import           Language.LSP.Types
import           OccName
import           Prelude hiding (span)
import           Prelude hiding (span)
import           TcRnTypes (tcg_binds)
import           Wingman.CodeGen (destructionFor)
import           Wingman.GHC
import           Wingman.Judgements
import           Wingman.LanguageServer
import           Wingman.Types


------------------------------------------------------------------------------
-- | The 'CommandId' for the empty case completion.
emptyCaseLensCommandId :: CommandId
emptyCaseLensCommandId :: CommandId
emptyCaseLensCommandId = Text -> CommandId
CommandId Text
"wingman.emptyCase"


------------------------------------------------------------------------------
-- | A command function that just applies a 'WorkspaceEdit'.
workspaceEditHandler :: CommandFunction IdeState WorkspaceEdit
workspaceEditHandler :: CommandFunction IdeState WorkspaceEdit
workspaceEditHandler IdeState
_ideState WorkspaceEdit
wedit = do
  LspId 'WorkspaceApplyEdit
_ <- SServerMethod 'WorkspaceApplyEdit
-> MessageParams 'WorkspaceApplyEdit
-> (Either ResponseError (ResponseResult 'WorkspaceApplyEdit)
    -> LspT Config IO ())
-> LspT Config IO (LspId 'WorkspaceApplyEdit)
forall (m :: Method 'FromServer 'Request) (f :: * -> *) config.
MonadLsp config f =>
SServerMethod m
-> MessageParams m
-> (Either ResponseError (ResponseResult m) -> f ())
-> f (LspId m)
sendRequest SServerMethod 'WorkspaceApplyEdit
SWorkspaceApplyEdit (Maybe Text -> WorkspaceEdit -> ApplyWorkspaceEditParams
ApplyWorkspaceEditParams Maybe Text
forall a. Maybe a
Nothing WorkspaceEdit
wedit) (\Either ResponseError (ResponseResult 'WorkspaceApplyEdit)
_ -> () -> LspT Config IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
  Either ResponseError Value
-> LspM Config (Either ResponseError Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ResponseError Value
 -> LspM Config (Either ResponseError Value))
-> Either ResponseError Value
-> LspM Config (Either ResponseError Value)
forall a b. (a -> b) -> a -> b
$ Value -> Either ResponseError Value
forall a b. b -> Either a b
Right Value
Null


------------------------------------------------------------------------------
-- | Provide the "empty case completion" code lens
codeLensProvider :: PluginMethodHandler IdeState TextDocumentCodeLens
codeLensProvider :: PluginMethodHandler IdeState 'TextDocumentCodeLens
codeLensProvider IdeState
state PluginId
plId (CodeLensParams _ _ (TextDocumentIdentifier uri))
  | Just NormalizedFilePath
nfp <- NormalizedUri -> Maybe NormalizedFilePath
uriToNormalizedFilePath (NormalizedUri -> Maybe NormalizedFilePath)
-> NormalizedUri -> Maybe NormalizedFilePath
forall a b. (a -> b) -> a -> b
$ Uri -> NormalizedUri
toNormalizedUri Uri
uri = do
      let stale :: a -> MaybeT IO (TrackedStale (RuleResult a))
stale a
a = String
-> IdeState
-> NormalizedFilePath
-> a
-> MaybeT IO (TrackedStale (RuleResult a))
forall a r.
(r ~ RuleResult a, Eq a, Hashable a, Binary a, Show a, Typeable a,
 NFData a, Show r, Typeable r, NFData r) =>
String
-> IdeState
-> NormalizedFilePath
-> a
-> MaybeT IO (TrackedStale r)
runStaleIde String
"codeLensProvider" IdeState
state NormalizedFilePath
nfp a
a

      ClientCapabilities
ccs <- LspT Config IO ClientCapabilities
forall config (m :: * -> *).
MonadLsp config m =>
m ClientCapabilities
getClientCapabilities
      IO (Either ResponseError (List CodeLens))
-> LspT Config IO (Either ResponseError (List CodeLens))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ResponseError (List CodeLens))
 -> LspT Config IO (Either ResponseError (List CodeLens)))
-> IO (Either ResponseError (List CodeLens))
-> LspT Config IO (Either ResponseError (List CodeLens))
forall a b. (a -> b) -> a -> b
$ Either ResponseError (List CodeLens)
-> MaybeT IO (Either ResponseError (List CodeLens))
-> IO (Either ResponseError (List CodeLens))
forall (m :: * -> *) a. Functor m => a -> MaybeT m a -> m a
fromMaybeT (List CodeLens -> Either ResponseError (List CodeLens)
forall a b. b -> Either a b
Right (List CodeLens -> Either ResponseError (List CodeLens))
-> List CodeLens -> Either ResponseError (List CodeLens)
forall a b. (a -> b) -> a -> b
$ [CodeLens] -> List CodeLens
forall a. [a] -> List a
List []) (MaybeT IO (Either ResponseError (List CodeLens))
 -> IO (Either ResponseError (List CodeLens)))
-> MaybeT IO (Either ResponseError (List CodeLens))
-> IO (Either ResponseError (List CodeLens))
forall a b. (a -> b) -> a -> b
$ do
        DynFlags
dflags <- IdeState -> NormalizedFilePath -> MaybeT IO DynFlags
getIdeDynflags IdeState
state NormalizedFilePath
nfp
        TrackedStale Tracked ('Stale s) (Annotated ParsedSource)
pm PositionMap ('Stale s) 'Current
_ <- GetAnnotatedParsedSource
-> MaybeT IO (TrackedStale (RuleResult GetAnnotatedParsedSource))
forall a.
(Eq a, Hashable a, Binary a, Show a, Show (RuleResult a),
 Typeable a, Typeable (RuleResult a), NFData a,
 NFData (RuleResult a)) =>
a -> MaybeT IO (TrackedStale (RuleResult a))
stale GetAnnotatedParsedSource
GetAnnotatedParsedSource
        TrackedStale Tracked ('Stale s) Bindings
binds PositionMap ('Stale s) 'Current
bind_map <- GetBindings -> MaybeT IO (TrackedStale (RuleResult GetBindings))
forall a.
(Eq a, Hashable a, Binary a, Show a, Show (RuleResult a),
 Typeable a, Typeable (RuleResult a), NFData a,
 NFData (RuleResult a)) =>
a -> MaybeT IO (TrackedStale (RuleResult a))
stale GetBindings
GetBindings
        [(Tracked 'Current RealSrcSpan, Type)]
holes <- IdeState
-> NormalizedFilePath
-> MaybeT IO [(Tracked 'Current RealSrcSpan, Type)]
emptyCaseScrutinees IdeState
state NormalizedFilePath
nfp

        ([CodeLens] -> Either ResponseError (List CodeLens))
-> MaybeT IO [CodeLens]
-> MaybeT IO (Either ResponseError (List CodeLens))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (List CodeLens -> Either ResponseError (List CodeLens)
forall a b. b -> Either a b
Right (List CodeLens -> Either ResponseError (List CodeLens))
-> ([CodeLens] -> List CodeLens)
-> [CodeLens]
-> Either ResponseError (List CodeLens)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CodeLens] -> List CodeLens
forall a. [a] -> List a
List) (MaybeT IO [CodeLens]
 -> MaybeT IO (Either ResponseError (List CodeLens)))
-> MaybeT IO [CodeLens]
-> MaybeT IO (Either ResponseError (List CodeLens))
forall a b. (a -> b) -> a -> b
$ [(Tracked 'Current RealSrcSpan, Type)]
-> ((Tracked 'Current RealSrcSpan, Type) -> MaybeT IO CodeLens)
-> MaybeT IO [CodeLens]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [(Tracked 'Current RealSrcSpan, Type)]
holes (((Tracked 'Current RealSrcSpan, Type) -> MaybeT IO CodeLens)
 -> MaybeT IO [CodeLens])
-> ((Tracked 'Current RealSrcSpan, Type) -> MaybeT IO CodeLens)
-> MaybeT IO [CodeLens]
forall a b. (a -> b) -> a -> b
$ \(Tracked 'Current RealSrcSpan
ss, Type
ty) -> do
          Tracked ('Stale s) RealSrcSpan
binds_ss <- Maybe (Tracked ('Stale s) RealSrcSpan)
-> MaybeT IO (Tracked ('Stale s) RealSrcSpan)
forall (m :: * -> *) a. Monad m => Maybe a -> MaybeT m a
liftMaybe (Maybe (Tracked ('Stale s) RealSrcSpan)
 -> MaybeT IO (Tracked ('Stale s) RealSrcSpan))
-> Maybe (Tracked ('Stale s) RealSrcSpan)
-> MaybeT IO (Tracked ('Stale s) RealSrcSpan)
forall a b. (a -> b) -> a -> b
$ PositionMap ('Stale s) 'Current
-> Tracked 'Current RealSrcSpan
-> Maybe (Tracked ('Stale s) RealSrcSpan)
forall a (from :: Age) (to :: Age).
MapAge a =>
PositionMap from to -> Tracked to a -> Maybe (Tracked from a)
mapAgeFrom PositionMap ('Stale s) 'Current
bind_map Tracked 'Current RealSrcSpan
ss
          let bindings :: [(Name, Maybe Type)]
bindings = Bindings -> RealSrcSpan -> [(Name, Maybe Type)]
getLocalScope (Tracked ('Stale s) Bindings -> Bindings
forall (age :: Age) a. Tracked age a -> a
unTrack Tracked ('Stale s) Bindings
binds) (RealSrcSpan -> [(Name, Maybe Type)])
-> RealSrcSpan -> [(Name, Maybe Type)]
forall a b. (a -> b) -> a -> b
$ Tracked ('Stale s) RealSrcSpan -> RealSrcSpan
forall (age :: Age) a. Tracked age a -> a
unTrack Tracked ('Stale s) RealSrcSpan
binds_ss
              range :: Range
range = RealSrcSpan -> Range
realSrcSpanToRange (RealSrcSpan -> Range) -> RealSrcSpan -> Range
forall a b. (a -> b) -> a -> b
$ Tracked 'Current RealSrcSpan -> RealSrcSpan
forall (age :: Age) a. Tracked age a -> a
unTrack Tracked 'Current RealSrcSpan
ss
          [LMatch GhcPs (LHsExpr GhcPs)]
matches <-
            Maybe [LMatch GhcPs (LHsExpr GhcPs)]
-> MaybeT IO [LMatch GhcPs (LHsExpr GhcPs)]
forall (m :: * -> *) a. Monad m => Maybe a -> MaybeT m a
liftMaybe (Maybe [LMatch GhcPs (LHsExpr GhcPs)]
 -> MaybeT IO [LMatch GhcPs (LHsExpr GhcPs)])
-> Maybe [LMatch GhcPs (LHsExpr GhcPs)]
-> MaybeT IO [LMatch GhcPs (LHsExpr GhcPs)]
forall a b. (a -> b) -> a -> b
$
              Hypothesis () -> Type -> Maybe [LMatch GhcPs (LHsExpr GhcPs)]
forall a.
Hypothesis a -> Type -> Maybe [LMatch GhcPs (LHsExpr GhcPs)]
destructionFor
                (((Name, Maybe Type) -> Hypothesis ())
-> [(Name, Maybe Type)] -> Hypothesis ()
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (OccName -> Hypothesis ()
hySingleton (OccName -> Hypothesis ())
-> ((Name, Maybe Type) -> OccName)
-> (Name, Maybe Type)
-> Hypothesis ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> OccName
forall name. HasOccName name => name -> OccName
occName (Name -> OccName)
-> ((Name, Maybe Type) -> Name) -> (Name, Maybe Type) -> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, Maybe Type) -> Name
forall a b. (a, b) -> a
fst) [(Name, Maybe Type)]
bindings)
                Type
ty
          WorkspaceEdit
edits <- Maybe WorkspaceEdit -> MaybeT IO WorkspaceEdit
forall (m :: * -> *) a. Monad m => Maybe a -> MaybeT m a
liftMaybe (Maybe WorkspaceEdit -> MaybeT IO WorkspaceEdit)
-> Maybe WorkspaceEdit -> MaybeT IO WorkspaceEdit
forall a b. (a -> b) -> a -> b
$ Either UserFacingMessage WorkspaceEdit -> Maybe WorkspaceEdit
forall e a. Either e a -> Maybe a
hush (Either UserFacingMessage WorkspaceEdit -> Maybe WorkspaceEdit)
-> Either UserFacingMessage WorkspaceEdit -> Maybe WorkspaceEdit
forall a b. (a -> b) -> a -> b
$
                DynFlags
-> ClientCapabilities
-> Uri
-> Annotated ParsedSource
-> Graft (Either String) ParsedSource
-> Either UserFacingMessage WorkspaceEdit
mkWorkspaceEdits DynFlags
dflags ClientCapabilities
ccs Uri
uri (Tracked ('Stale s) (Annotated ParsedSource)
-> Annotated ParsedSource
forall (age :: Age) a. Tracked age a -> a
unTrack Tracked ('Stale s) (Annotated ParsedSource)
pm) (Graft (Either String) ParsedSource
 -> Either UserFacingMessage WorkspaceEdit)
-> Graft (Either String) ParsedSource
-> Either UserFacingMessage WorkspaceEdit
forall a b. (a -> b) -> a -> b
$
                  SrcSpan
-> Located [LMatch GhcPs (LHsExpr GhcPs)]
-> Graft (Either String) ParsedSource
graftMatchGroup (RealSrcSpan -> SrcSpan
RealSrcSpan (RealSrcSpan -> SrcSpan) -> RealSrcSpan -> SrcSpan
forall a b. (a -> b) -> a -> b
$ Tracked 'Current RealSrcSpan -> RealSrcSpan
forall (age :: Age) a. Tracked age a -> a
unTrack Tracked 'Current RealSrcSpan
ss) (Located [LMatch GhcPs (LHsExpr GhcPs)]
 -> Graft (Either String) ParsedSource)
-> Located [LMatch GhcPs (LHsExpr GhcPs)]
-> Graft (Either String) ParsedSource
forall a b. (a -> b) -> a -> b
$
                    SrcSpanLess (Located [LMatch GhcPs (LHsExpr GhcPs)])
-> Located [LMatch GhcPs (LHsExpr GhcPs)]
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc [LMatch GhcPs (LHsExpr GhcPs)]
SrcSpanLess (Located [LMatch GhcPs (LHsExpr GhcPs)])
matches

          CodeLens -> MaybeT IO CodeLens
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CodeLens -> MaybeT IO CodeLens) -> CodeLens -> MaybeT IO CodeLens
forall a b. (a -> b) -> a -> b
$
            Range -> Maybe Command -> Maybe Value -> CodeLens
CodeLens Range
range
              (Command -> Maybe Command
forall a. a -> Maybe a
Just
                (Command -> Maybe Command) -> Command -> Maybe Command
forall a b. (a -> b) -> a -> b
$ PluginId -> CommandId -> Text -> Maybe [Value] -> Command
mkLspCommand
                    PluginId
plId
                    CommandId
emptyCaseLensCommandId
                    (Type -> Text
mkEmptyCaseLensDesc Type
ty)
                (Maybe [Value] -> Command) -> Maybe [Value] -> Command
forall a b. (a -> b) -> a -> b
$ [Value] -> Maybe [Value]
forall a. a -> Maybe a
Just ([Value] -> Maybe [Value]) -> [Value] -> Maybe [Value]
forall a b. (a -> b) -> a -> b
$ Value -> [Value]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> [Value]) -> Value -> [Value]
forall a b. (a -> b) -> a -> b
$ WorkspaceEdit -> Value
forall a. ToJSON a => a -> Value
toJSON (WorkspaceEdit -> Value) -> WorkspaceEdit -> Value
forall a b. (a -> b) -> a -> b
$ WorkspaceEdit
edits
              )
              Maybe Value
forall a. Maybe a
Nothing
codeLensProvider IdeState
_ PluginId
_ MessageParams 'TextDocumentCodeLens
_ = Either ResponseError (List CodeLens)
-> LspT Config IO (Either ResponseError (List CodeLens))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ResponseError (List CodeLens)
 -> LspT Config IO (Either ResponseError (List CodeLens)))
-> Either ResponseError (List CodeLens)
-> LspT Config IO (Either ResponseError (List CodeLens))
forall a b. (a -> b) -> a -> b
$ List CodeLens -> Either ResponseError (List CodeLens)
forall a b. b -> Either a b
Right (List CodeLens -> Either ResponseError (List CodeLens))
-> List CodeLens -> Either ResponseError (List CodeLens)
forall a b. (a -> b) -> a -> b
$ [CodeLens] -> List CodeLens
forall a. [a] -> List a
List []


scrutinzedType :: EmptyCaseSort Type -> Maybe Type
scrutinzedType :: EmptyCaseSort Type -> Maybe Type
scrutinzedType (EmptyCase Type
ty) = Type -> Maybe Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure  Type
ty
scrutinzedType (EmptyLamCase Type
ty) =
  case Type -> ([TyVar], ThetaType, ThetaType, Type)
tacticsSplitFunTy Type
ty of
    ([TyVar]
_, ThetaType
_, ThetaType
tys, Type
_) -> ThetaType -> Maybe Type
forall a. [a] -> Maybe a
listToMaybe  ThetaType
tys


------------------------------------------------------------------------------
-- | The description for the empty case lens.
mkEmptyCaseLensDesc :: Type -> T.Text
mkEmptyCaseLensDesc :: Type -> Text
mkEmptyCaseLensDesc Type
ty =
  Text
"Wingman: Complete case constructors (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Type -> String
forall a. Outputable a => a -> String
unsafeRender Type
ty) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"


------------------------------------------------------------------------------
-- | Silence an error.
hush :: Either e a -> Maybe a
hush :: Either e a -> Maybe a
hush (Left e
_) = Maybe a
forall a. Maybe a
Nothing
hush (Right a
a) = a -> Maybe a
forall a. a -> Maybe a
Just a
a


------------------------------------------------------------------------------
-- | Graft a 'RunTacticResults' into the correct place in an AST. Correctly
-- deals with top-level holes, in which we might need to fiddle with the
-- 'Match's that bind variables.
graftMatchGroup
    :: SrcSpan
    -> Located [LMatch GhcPs (LHsExpr GhcPs)]
    -> Graft (Either String) ParsedSource
graftMatchGroup :: SrcSpan
-> Located [LMatch GhcPs (LHsExpr GhcPs)]
-> Graft (Either String) ParsedSource
graftMatchGroup SrcSpan
ss Located [LMatch GhcPs (LHsExpr GhcPs)]
l =
  (forall x. ExceptStringT Identity x -> Either String x)
-> Graft (ExceptStringT Identity) ParsedSource
-> Graft (Either String) ParsedSource
forall (m :: * -> *) (n :: * -> *) a.
(forall x. m x -> n x) -> Graft m a -> Graft n a
hoistGraft (Except String x -> Either String x
forall e a. Except e a -> Either e a
runExcept (Except String x -> Either String x)
-> (ExceptStringT Identity x -> Except String x)
-> ExceptStringT Identity x
-> Either String x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptStringT Identity x -> Except String x
forall (m :: * -> *) a. ExceptStringT m a -> ExceptT String m a
runExceptString) (Graft (ExceptStringT Identity) ParsedSource
 -> Graft (Either String) ParsedSource)
-> Graft (ExceptStringT Identity) ParsedSource
-> Graft (Either String) ParsedSource
forall a b. (a -> b) -> a -> b
$ SrcSpan
-> (LHsExpr GhcPs
    -> TransformT (ExceptStringT Identity) (Maybe (LHsExpr GhcPs)))
-> Graft (ExceptStringT Identity) ParsedSource
forall (m :: * -> *) a.
(MonadFail m, Data a) =>
SrcSpan
-> (LHsExpr GhcPs -> TransformT m (Maybe (LHsExpr GhcPs)))
-> Graft m a
graftExprWithM SrcSpan
ss ((LHsExpr GhcPs
  -> TransformT (ExceptStringT Identity) (Maybe (LHsExpr GhcPs)))
 -> Graft (ExceptStringT Identity) ParsedSource)
-> (LHsExpr GhcPs
    -> TransformT (ExceptStringT Identity) (Maybe (LHsExpr GhcPs)))
-> Graft (ExceptStringT Identity) ParsedSource
forall a b. (a -> b) -> a -> b
$ \case
    L SrcSpan
span (HsCase XCase GhcPs
ext LHsExpr GhcPs
scrut mg :: MatchGroup GhcPs (LHsExpr GhcPs)
mg@MatchGroup GhcPs (LHsExpr GhcPs)
_) -> do
      Maybe (LHsExpr GhcPs)
-> TransformT (ExceptStringT Identity) (Maybe (LHsExpr GhcPs))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (LHsExpr GhcPs)
 -> TransformT (ExceptStringT Identity) (Maybe (LHsExpr GhcPs)))
-> Maybe (LHsExpr GhcPs)
-> TransformT (ExceptStringT Identity) (Maybe (LHsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> Maybe (LHsExpr GhcPs)
forall a. a -> Maybe a
Just (LHsExpr GhcPs -> Maybe (LHsExpr GhcPs))
-> LHsExpr GhcPs -> Maybe (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> HsExpr GhcPs -> LHsExpr GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
span (HsExpr GhcPs -> LHsExpr GhcPs) -> HsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ XCase GhcPs
-> LHsExpr GhcPs
-> MatchGroup GhcPs (LHsExpr GhcPs)
-> HsExpr GhcPs
forall p.
XCase p -> LHsExpr p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsCase XCase GhcPs
ext LHsExpr GhcPs
scrut (MatchGroup GhcPs (LHsExpr GhcPs) -> HsExpr GhcPs)
-> MatchGroup GhcPs (LHsExpr GhcPs) -> HsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ MatchGroup GhcPs (LHsExpr GhcPs)
mg { mg_alts :: Located [LMatch GhcPs (LHsExpr GhcPs)]
mg_alts = Located [LMatch GhcPs (LHsExpr GhcPs)]
l }
    L SrcSpan
span (HsLamCase XLamCase GhcPs
ext mg :: MatchGroup GhcPs (LHsExpr GhcPs)
mg@MatchGroup GhcPs (LHsExpr GhcPs)
_) -> do
      Maybe (LHsExpr GhcPs)
-> TransformT (ExceptStringT Identity) (Maybe (LHsExpr GhcPs))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (LHsExpr GhcPs)
 -> TransformT (ExceptStringT Identity) (Maybe (LHsExpr GhcPs)))
-> Maybe (LHsExpr GhcPs)
-> TransformT (ExceptStringT Identity) (Maybe (LHsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> Maybe (LHsExpr GhcPs)
forall a. a -> Maybe a
Just (LHsExpr GhcPs -> Maybe (LHsExpr GhcPs))
-> LHsExpr GhcPs -> Maybe (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> HsExpr GhcPs -> LHsExpr GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
span (HsExpr GhcPs -> LHsExpr GhcPs) -> HsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ XLamCase GhcPs -> MatchGroup GhcPs (LHsExpr GhcPs) -> HsExpr GhcPs
forall p. XLamCase p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLamCase XLamCase GhcPs
ext (MatchGroup GhcPs (LHsExpr GhcPs) -> HsExpr GhcPs)
-> MatchGroup GhcPs (LHsExpr GhcPs) -> HsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ MatchGroup GhcPs (LHsExpr GhcPs)
mg { mg_alts :: Located [LMatch GhcPs (LHsExpr GhcPs)]
mg_alts = Located [LMatch GhcPs (LHsExpr GhcPs)]
l }
    (LHsExpr GhcPs
_ :: LHsExpr GhcPs) -> Maybe (LHsExpr GhcPs)
-> TransformT (ExceptStringT Identity) (Maybe (LHsExpr GhcPs))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (LHsExpr GhcPs)
forall a. Maybe a
Nothing


fromMaybeT :: Functor m => a -> MaybeT m a -> m a
fromMaybeT :: a -> MaybeT m a -> m a
fromMaybeT a
def = (Maybe a -> a) -> m (Maybe a) -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe a
def) (m (Maybe a) -> m a)
-> (MaybeT m a -> m (Maybe a)) -> MaybeT m a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MaybeT m a -> m (Maybe a)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT


------------------------------------------------------------------------------
-- | Find the last typechecked module, and find the most specific span, as well
-- as the judgement at the given range.
emptyCaseScrutinees
    :: IdeState
    -> NormalizedFilePath
    -> MaybeT IO [(Tracked 'Current RealSrcSpan, Type)]
emptyCaseScrutinees :: IdeState
-> NormalizedFilePath
-> MaybeT IO [(Tracked 'Current RealSrcSpan, Type)]
emptyCaseScrutinees IdeState
state NormalizedFilePath
nfp = do
    let stale :: a -> MaybeT IO (TrackedStale (RuleResult a))
stale a
a = String
-> IdeState
-> NormalizedFilePath
-> a
-> MaybeT IO (TrackedStale (RuleResult a))
forall a r.
(r ~ RuleResult a, Eq a, Hashable a, Binary a, Show a, Typeable a,
 NFData a, Show r, Typeable r, NFData r) =>
String
-> IdeState
-> NormalizedFilePath
-> a
-> MaybeT IO (TrackedStale r)
runStaleIde String
"emptyCaseScrutinees" IdeState
state NormalizedFilePath
nfp a
a

    TrackedStale Tracked ('Stale s) TcGblEnv
tcg PositionMap ('Stale s) 'Current
tcg_map <- (TrackedStale TcModuleResult -> TrackedStale TcGblEnv)
-> MaybeT IO (TrackedStale TcModuleResult)
-> MaybeT IO (TrackedStale TcGblEnv)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((TcModuleResult -> TcGblEnv)
-> TrackedStale TcModuleResult -> TrackedStale TcGblEnv
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TcModuleResult -> TcGblEnv
tmrTypechecked) (MaybeT IO (TrackedStale TcModuleResult)
 -> MaybeT IO (TrackedStale TcGblEnv))
-> MaybeT IO (TrackedStale TcModuleResult)
-> MaybeT IO (TrackedStale TcGblEnv)
forall a b. (a -> b) -> a -> b
$ TypeCheck -> MaybeT IO (TrackedStale (RuleResult TypeCheck))
forall a.
(Eq a, Hashable a, Binary a, Show a, Show (RuleResult a),
 Typeable a, Typeable (RuleResult a), NFData a,
 NFData (RuleResult a)) =>
a -> MaybeT IO (TrackedStale (RuleResult a))
stale TypeCheck
TypeCheck
    let tcg' :: TcGblEnv
tcg' = Tracked ('Stale s) TcGblEnv -> TcGblEnv
forall (age :: Age) a. Tracked age a -> a
unTrack Tracked ('Stale s) TcGblEnv
tcg
    TrackedStale HscEnvEq
hscenv <- GhcSessionDeps
-> MaybeT IO (TrackedStale (RuleResult GhcSessionDeps))
forall a.
(Eq a, Hashable a, Binary a, Show a, Show (RuleResult a),
 Typeable a, Typeable (RuleResult a), NFData a,
 NFData (RuleResult a)) =>
a -> MaybeT IO (TrackedStale (RuleResult a))
stale GhcSessionDeps
GhcSessionDeps

    let scrutinees :: [Tracked ('Stale s) (SrcSpan, EmptyCaseSort (HsExpr GhcTc))]
scrutinees = (TcGblEnv -> [(SrcSpan, EmptyCaseSort (HsExpr GhcTc))])
-> Tracked ('Stale s) TcGblEnv
-> [Tracked ('Stale s) (SrcSpan, EmptyCaseSort (HsExpr GhcTc))]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (LHsBinds GhcTc -> [(SrcSpan, EmptyCaseSort (HsExpr GhcTc))]
GenericQ [(SrcSpan, EmptyCaseSort (HsExpr GhcTc))]
emptyCaseQ (LHsBinds GhcTc -> [(SrcSpan, EmptyCaseSort (HsExpr GhcTc))])
-> (TcGblEnv -> LHsBinds GhcTc)
-> TcGblEnv
-> [(SrcSpan, EmptyCaseSort (HsExpr GhcTc))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcGblEnv -> LHsBinds GhcTc
tcg_binds) Tracked ('Stale s) TcGblEnv
tcg
    ([Maybe (Tracked 'Current RealSrcSpan, Type)]
 -> [(Tracked 'Current RealSrcSpan, Type)])
-> MaybeT IO [Maybe (Tracked 'Current RealSrcSpan, Type)]
-> MaybeT IO [(Tracked 'Current RealSrcSpan, Type)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe (Tracked 'Current RealSrcSpan, Type)]
-> [(Tracked 'Current RealSrcSpan, Type)]
forall a. [Maybe a] -> [a]
catMaybes (MaybeT IO [Maybe (Tracked 'Current RealSrcSpan, Type)]
 -> MaybeT IO [(Tracked 'Current RealSrcSpan, Type)])
-> MaybeT IO [Maybe (Tracked 'Current RealSrcSpan, Type)]
-> MaybeT IO [(Tracked 'Current RealSrcSpan, Type)]
forall a b. (a -> b) -> a -> b
$ [Tracked ('Stale s) (SrcSpan, EmptyCaseSort (HsExpr GhcTc))]
-> (Tracked ('Stale s) (SrcSpan, EmptyCaseSort (HsExpr GhcTc))
    -> MaybeT IO (Maybe (Tracked 'Current RealSrcSpan, Type)))
-> MaybeT IO [Maybe (Tracked 'Current RealSrcSpan, Type)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Tracked ('Stale s) (SrcSpan, EmptyCaseSort (HsExpr GhcTc))]
scrutinees ((Tracked ('Stale s) (SrcSpan, EmptyCaseSort (HsExpr GhcTc))
  -> MaybeT IO (Maybe (Tracked 'Current RealSrcSpan, Type)))
 -> MaybeT IO [Maybe (Tracked 'Current RealSrcSpan, Type)])
-> (Tracked ('Stale s) (SrcSpan, EmptyCaseSort (HsExpr GhcTc))
    -> MaybeT IO (Maybe (Tracked 'Current RealSrcSpan, Type)))
-> MaybeT IO [Maybe (Tracked 'Current RealSrcSpan, Type)]
forall a b. (a -> b) -> a -> b
$ \aged :: Tracked ('Stale s) (SrcSpan, EmptyCaseSort (HsExpr GhcTc))
aged@(Tracked ('Stale s) (SrcSpan, EmptyCaseSort (HsExpr GhcTc))
-> (SrcSpan, EmptyCaseSort (HsExpr GhcTc))
forall (age :: Age) a. Tracked age a -> a
unTrack -> (SrcSpan
ss, EmptyCaseSort (HsExpr GhcTc)
scrutinee)) -> do
      Type
ty <- IO (Maybe Type) -> MaybeT IO Type
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT
          (IO (Maybe Type) -> MaybeT IO Type)
-> (EmptyCaseSort (HsExpr GhcTc) -> IO (Maybe Type))
-> EmptyCaseSort (HsExpr GhcTc)
-> MaybeT IO Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EmptyCaseSort (Maybe Type) -> Maybe Type)
-> IO (EmptyCaseSort (Maybe Type)) -> IO (Maybe Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (EmptyCaseSort Type -> Maybe Type
scrutinzedType (EmptyCaseSort Type -> Maybe Type)
-> (EmptyCaseSort (Maybe Type) -> Maybe (EmptyCaseSort Type))
-> EmptyCaseSort (Maybe Type)
-> Maybe Type
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< EmptyCaseSort (Maybe Type) -> Maybe (EmptyCaseSort Type)
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence)
          (IO (EmptyCaseSort (Maybe Type)) -> IO (Maybe Type))
-> (EmptyCaseSort (HsExpr GhcTc)
    -> IO (EmptyCaseSort (Maybe Type)))
-> EmptyCaseSort (HsExpr GhcTc)
-> IO (Maybe Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HsExpr GhcTc -> IO (Maybe Type))
-> EmptyCaseSort (HsExpr GhcTc) -> IO (EmptyCaseSort (Maybe Type))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (HscEnv -> TcGblEnv -> HsExpr GhcTc -> IO (Maybe Type)
typeCheck (HscEnvEq -> HscEnv
hscEnv (HscEnvEq -> HscEnv) -> HscEnvEq -> HscEnv
forall a b. (a -> b) -> a -> b
$ TrackedStale HscEnvEq -> HscEnvEq
forall a. TrackedStale a -> a
untrackedStaleValue TrackedStale HscEnvEq
hscenv) TcGblEnv
tcg')
          (EmptyCaseSort (HsExpr GhcTc) -> MaybeT IO Type)
-> EmptyCaseSort (HsExpr GhcTc) -> MaybeT IO Type
forall a b. (a -> b) -> a -> b
$ EmptyCaseSort (HsExpr GhcTc)
scrutinee
      case Maybe ([DataCon], ThetaType) -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Maybe ([DataCon], ThetaType) -> Bool)
-> Maybe ([DataCon], ThetaType) -> Bool
forall a b. (a -> b) -> a -> b
$ Type -> Maybe ([DataCon], ThetaType)
tacticsGetDataCons Type
ty of
        Bool
True -> Maybe (Tracked 'Current RealSrcSpan, Type)
-> MaybeT IO (Maybe (Tracked 'Current RealSrcSpan, Type))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Tracked 'Current RealSrcSpan, Type)
forall (f :: * -> *) a. Alternative f => f a
empty
        Bool
False ->
          case SrcSpan
ss of
            RealSrcSpan RealSrcSpan
r   -> do
              Tracked 'Current RealSrcSpan
rss' <- Maybe (Tracked 'Current RealSrcSpan)
-> MaybeT IO (Tracked 'Current RealSrcSpan)
forall (m :: * -> *) a. Monad m => Maybe a -> MaybeT m a
liftMaybe (Maybe (Tracked 'Current RealSrcSpan)
 -> MaybeT IO (Tracked 'Current RealSrcSpan))
-> Maybe (Tracked 'Current RealSrcSpan)
-> MaybeT IO (Tracked 'Current RealSrcSpan)
forall a b. (a -> b) -> a -> b
$ PositionMap ('Stale s) 'Current
-> Tracked ('Stale s) RealSrcSpan
-> Maybe (Tracked 'Current RealSrcSpan)
forall a (from :: Age) (to :: Age).
MapAge a =>
PositionMap from to -> Tracked from a -> Maybe (Tracked to a)
mapAgeTo PositionMap ('Stale s) 'Current
tcg_map (Tracked ('Stale s) RealSrcSpan
 -> Maybe (Tracked 'Current RealSrcSpan))
-> Tracked ('Stale s) RealSrcSpan
-> Maybe (Tracked 'Current RealSrcSpan)
forall a b. (a -> b) -> a -> b
$ Tracked ('Stale s) (SrcSpan, EmptyCaseSort (HsExpr GhcTc))
-> RealSrcSpan -> Tracked ('Stale s) RealSrcSpan
forall (age :: Age) a b. Tracked age a -> b -> Tracked age b
unsafeCopyAge Tracked ('Stale s) (SrcSpan, EmptyCaseSort (HsExpr GhcTc))
aged RealSrcSpan
r
              Maybe (Tracked 'Current RealSrcSpan, Type)
-> MaybeT IO (Maybe (Tracked 'Current RealSrcSpan, Type))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Tracked 'Current RealSrcSpan, Type)
 -> MaybeT IO (Maybe (Tracked 'Current RealSrcSpan, Type)))
-> Maybe (Tracked 'Current RealSrcSpan, Type)
-> MaybeT IO (Maybe (Tracked 'Current RealSrcSpan, Type))
forall a b. (a -> b) -> a -> b
$ (Tracked 'Current RealSrcSpan, Type)
-> Maybe (Tracked 'Current RealSrcSpan, Type)
forall a. a -> Maybe a
Just (Tracked 'Current RealSrcSpan
rss', Type
ty)
            UnhelpfulSpan FastString
_ -> MaybeT IO (Maybe (Tracked 'Current RealSrcSpan, Type))
forall (f :: * -> *) a. Alternative f => f a
empty

data EmptyCaseSort a
  = EmptyCase a
  | EmptyLamCase a
  deriving (EmptyCaseSort a -> EmptyCaseSort a -> Bool
(EmptyCaseSort a -> EmptyCaseSort a -> Bool)
-> (EmptyCaseSort a -> EmptyCaseSort a -> Bool)
-> Eq (EmptyCaseSort a)
forall a. Eq a => EmptyCaseSort a -> EmptyCaseSort a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EmptyCaseSort a -> EmptyCaseSort a -> Bool
$c/= :: forall a. Eq a => EmptyCaseSort a -> EmptyCaseSort a -> Bool
== :: EmptyCaseSort a -> EmptyCaseSort a -> Bool
$c== :: forall a. Eq a => EmptyCaseSort a -> EmptyCaseSort a -> Bool
Eq, Eq (EmptyCaseSort a)
Eq (EmptyCaseSort a)
-> (EmptyCaseSort a -> EmptyCaseSort a -> Ordering)
-> (EmptyCaseSort a -> EmptyCaseSort a -> Bool)
-> (EmptyCaseSort a -> EmptyCaseSort a -> Bool)
-> (EmptyCaseSort a -> EmptyCaseSort a -> Bool)
-> (EmptyCaseSort a -> EmptyCaseSort a -> Bool)
-> (EmptyCaseSort a -> EmptyCaseSort a -> EmptyCaseSort a)
-> (EmptyCaseSort a -> EmptyCaseSort a -> EmptyCaseSort a)
-> Ord (EmptyCaseSort a)
EmptyCaseSort a -> EmptyCaseSort a -> Bool
EmptyCaseSort a -> EmptyCaseSort a -> Ordering
EmptyCaseSort a -> EmptyCaseSort a -> EmptyCaseSort a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (EmptyCaseSort a)
forall a. Ord a => EmptyCaseSort a -> EmptyCaseSort a -> Bool
forall a. Ord a => EmptyCaseSort a -> EmptyCaseSort a -> Ordering
forall a.
Ord a =>
EmptyCaseSort a -> EmptyCaseSort a -> EmptyCaseSort a
min :: EmptyCaseSort a -> EmptyCaseSort a -> EmptyCaseSort a
$cmin :: forall a.
Ord a =>
EmptyCaseSort a -> EmptyCaseSort a -> EmptyCaseSort a
max :: EmptyCaseSort a -> EmptyCaseSort a -> EmptyCaseSort a
$cmax :: forall a.
Ord a =>
EmptyCaseSort a -> EmptyCaseSort a -> EmptyCaseSort a
>= :: EmptyCaseSort a -> EmptyCaseSort a -> Bool
$c>= :: forall a. Ord a => EmptyCaseSort a -> EmptyCaseSort a -> Bool
> :: EmptyCaseSort a -> EmptyCaseSort a -> Bool
$c> :: forall a. Ord a => EmptyCaseSort a -> EmptyCaseSort a -> Bool
<= :: EmptyCaseSort a -> EmptyCaseSort a -> Bool
$c<= :: forall a. Ord a => EmptyCaseSort a -> EmptyCaseSort a -> Bool
< :: EmptyCaseSort a -> EmptyCaseSort a -> Bool
$c< :: forall a. Ord a => EmptyCaseSort a -> EmptyCaseSort a -> Bool
compare :: EmptyCaseSort a -> EmptyCaseSort a -> Ordering
$ccompare :: forall a. Ord a => EmptyCaseSort a -> EmptyCaseSort a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (EmptyCaseSort a)
Ord, Int -> EmptyCaseSort a -> ShowS
[EmptyCaseSort a] -> ShowS
EmptyCaseSort a -> String
(Int -> EmptyCaseSort a -> ShowS)
-> (EmptyCaseSort a -> String)
-> ([EmptyCaseSort a] -> ShowS)
-> Show (EmptyCaseSort a)
forall a. Show a => Int -> EmptyCaseSort a -> ShowS
forall a. Show a => [EmptyCaseSort a] -> ShowS
forall a. Show a => EmptyCaseSort a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EmptyCaseSort a] -> ShowS
$cshowList :: forall a. Show a => [EmptyCaseSort a] -> ShowS
show :: EmptyCaseSort a -> String
$cshow :: forall a. Show a => EmptyCaseSort a -> String
showsPrec :: Int -> EmptyCaseSort a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> EmptyCaseSort a -> ShowS
Show, a -> EmptyCaseSort b -> EmptyCaseSort a
(a -> b) -> EmptyCaseSort a -> EmptyCaseSort b
(forall a b. (a -> b) -> EmptyCaseSort a -> EmptyCaseSort b)
-> (forall a b. a -> EmptyCaseSort b -> EmptyCaseSort a)
-> Functor EmptyCaseSort
forall a b. a -> EmptyCaseSort b -> EmptyCaseSort a
forall a b. (a -> b) -> EmptyCaseSort a -> EmptyCaseSort b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> EmptyCaseSort b -> EmptyCaseSort a
$c<$ :: forall a b. a -> EmptyCaseSort b -> EmptyCaseSort a
fmap :: (a -> b) -> EmptyCaseSort a -> EmptyCaseSort b
$cfmap :: forall a b. (a -> b) -> EmptyCaseSort a -> EmptyCaseSort b
Functor, EmptyCaseSort a -> Bool
(a -> m) -> EmptyCaseSort a -> m
(a -> b -> b) -> b -> EmptyCaseSort a -> b
(forall m. Monoid m => EmptyCaseSort m -> m)
-> (forall m a. Monoid m => (a -> m) -> EmptyCaseSort a -> m)
-> (forall m a. Monoid m => (a -> m) -> EmptyCaseSort a -> m)
-> (forall a b. (a -> b -> b) -> b -> EmptyCaseSort a -> b)
-> (forall a b. (a -> b -> b) -> b -> EmptyCaseSort a -> b)
-> (forall b a. (b -> a -> b) -> b -> EmptyCaseSort a -> b)
-> (forall b a. (b -> a -> b) -> b -> EmptyCaseSort a -> b)
-> (forall a. (a -> a -> a) -> EmptyCaseSort a -> a)
-> (forall a. (a -> a -> a) -> EmptyCaseSort a -> a)
-> (forall a. EmptyCaseSort a -> [a])
-> (forall a. EmptyCaseSort a -> Bool)
-> (forall a. EmptyCaseSort a -> Int)
-> (forall a. Eq a => a -> EmptyCaseSort a -> Bool)
-> (forall a. Ord a => EmptyCaseSort a -> a)
-> (forall a. Ord a => EmptyCaseSort a -> a)
-> (forall a. Num a => EmptyCaseSort a -> a)
-> (forall a. Num a => EmptyCaseSort a -> a)
-> Foldable EmptyCaseSort
forall a. Eq a => a -> EmptyCaseSort a -> Bool
forall a. Num a => EmptyCaseSort a -> a
forall a. Ord a => EmptyCaseSort a -> a
forall m. Monoid m => EmptyCaseSort m -> m
forall a. EmptyCaseSort a -> Bool
forall a. EmptyCaseSort a -> Int
forall a. EmptyCaseSort a -> [a]
forall a. (a -> a -> a) -> EmptyCaseSort a -> a
forall m a. Monoid m => (a -> m) -> EmptyCaseSort a -> m
forall b a. (b -> a -> b) -> b -> EmptyCaseSort a -> b
forall a b. (a -> b -> b) -> b -> EmptyCaseSort a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: EmptyCaseSort a -> a
$cproduct :: forall a. Num a => EmptyCaseSort a -> a
sum :: EmptyCaseSort a -> a
$csum :: forall a. Num a => EmptyCaseSort a -> a
minimum :: EmptyCaseSort a -> a
$cminimum :: forall a. Ord a => EmptyCaseSort a -> a
maximum :: EmptyCaseSort a -> a
$cmaximum :: forall a. Ord a => EmptyCaseSort a -> a
elem :: a -> EmptyCaseSort a -> Bool
$celem :: forall a. Eq a => a -> EmptyCaseSort a -> Bool
length :: EmptyCaseSort a -> Int
$clength :: forall a. EmptyCaseSort a -> Int
null :: EmptyCaseSort a -> Bool
$cnull :: forall a. EmptyCaseSort a -> Bool
toList :: EmptyCaseSort a -> [a]
$ctoList :: forall a. EmptyCaseSort a -> [a]
foldl1 :: (a -> a -> a) -> EmptyCaseSort a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> EmptyCaseSort a -> a
foldr1 :: (a -> a -> a) -> EmptyCaseSort a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> EmptyCaseSort a -> a
foldl' :: (b -> a -> b) -> b -> EmptyCaseSort a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> EmptyCaseSort a -> b
foldl :: (b -> a -> b) -> b -> EmptyCaseSort a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> EmptyCaseSort a -> b
foldr' :: (a -> b -> b) -> b -> EmptyCaseSort a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> EmptyCaseSort a -> b
foldr :: (a -> b -> b) -> b -> EmptyCaseSort a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> EmptyCaseSort a -> b
foldMap' :: (a -> m) -> EmptyCaseSort a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> EmptyCaseSort a -> m
foldMap :: (a -> m) -> EmptyCaseSort a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> EmptyCaseSort a -> m
fold :: EmptyCaseSort m -> m
$cfold :: forall m. Monoid m => EmptyCaseSort m -> m
Foldable, Functor EmptyCaseSort
Foldable EmptyCaseSort
Functor EmptyCaseSort
-> Foldable EmptyCaseSort
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> EmptyCaseSort a -> f (EmptyCaseSort b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    EmptyCaseSort (f a) -> f (EmptyCaseSort a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> EmptyCaseSort a -> m (EmptyCaseSort b))
-> (forall (m :: * -> *) a.
    Monad m =>
    EmptyCaseSort (m a) -> m (EmptyCaseSort a))
-> Traversable EmptyCaseSort
(a -> f b) -> EmptyCaseSort a -> f (EmptyCaseSort b)
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
EmptyCaseSort (m a) -> m (EmptyCaseSort a)
forall (f :: * -> *) a.
Applicative f =>
EmptyCaseSort (f a) -> f (EmptyCaseSort a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> EmptyCaseSort a -> m (EmptyCaseSort b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> EmptyCaseSort a -> f (EmptyCaseSort b)
sequence :: EmptyCaseSort (m a) -> m (EmptyCaseSort a)
$csequence :: forall (m :: * -> *) a.
Monad m =>
EmptyCaseSort (m a) -> m (EmptyCaseSort a)
mapM :: (a -> m b) -> EmptyCaseSort a -> m (EmptyCaseSort b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> EmptyCaseSort a -> m (EmptyCaseSort b)
sequenceA :: EmptyCaseSort (f a) -> f (EmptyCaseSort a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
EmptyCaseSort (f a) -> f (EmptyCaseSort a)
traverse :: (a -> f b) -> EmptyCaseSort a -> f (EmptyCaseSort b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> EmptyCaseSort a -> f (EmptyCaseSort b)
$cp2Traversable :: Foldable EmptyCaseSort
$cp1Traversable :: Functor EmptyCaseSort
Traversable)

------------------------------------------------------------------------------
-- | Get the 'SrcSpan' and scrutinee of every empty case.
emptyCaseQ :: GenericQ [(SrcSpan, EmptyCaseSort (HsExpr GhcTc))]
emptyCaseQ :: a -> [(SrcSpan, EmptyCaseSort (HsExpr GhcTc))]
emptyCaseQ = ([(SrcSpan, EmptyCaseSort (HsExpr GhcTc))]
 -> [(SrcSpan, EmptyCaseSort (HsExpr GhcTc))]
 -> [(SrcSpan, EmptyCaseSort (HsExpr GhcTc))])
-> GenericQ [(SrcSpan, EmptyCaseSort (HsExpr GhcTc))]
-> GenericQ [(SrcSpan, EmptyCaseSort (HsExpr GhcTc))]
forall r. (r -> r -> r) -> GenericQ r -> GenericQ r
everything [(SrcSpan, EmptyCaseSort (HsExpr GhcTc))]
-> [(SrcSpan, EmptyCaseSort (HsExpr GhcTc))]
-> [(SrcSpan, EmptyCaseSort (HsExpr GhcTc))]
forall a. Semigroup a => a -> a -> a
(<>) (GenericQ [(SrcSpan, EmptyCaseSort (HsExpr GhcTc))]
 -> GenericQ [(SrcSpan, EmptyCaseSort (HsExpr GhcTc))])
-> GenericQ [(SrcSpan, EmptyCaseSort (HsExpr GhcTc))]
-> GenericQ [(SrcSpan, EmptyCaseSort (HsExpr GhcTc))]
forall a b. (a -> b) -> a -> b
$ [(SrcSpan, EmptyCaseSort (HsExpr GhcTc))]
-> (GenLocated SrcSpan (HsExpr GhcTc)
    -> [(SrcSpan, EmptyCaseSort (HsExpr GhcTc))])
-> a
-> [(SrcSpan, EmptyCaseSort (HsExpr GhcTc))]
forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
mkQ [(SrcSpan, EmptyCaseSort (HsExpr GhcTc))]
forall a. Monoid a => a
mempty ((GenLocated SrcSpan (HsExpr GhcTc)
  -> [(SrcSpan, EmptyCaseSort (HsExpr GhcTc))])
 -> a -> [(SrcSpan, EmptyCaseSort (HsExpr GhcTc))])
-> (GenLocated SrcSpan (HsExpr GhcTc)
    -> [(SrcSpan, EmptyCaseSort (HsExpr GhcTc))])
-> a
-> [(SrcSpan, EmptyCaseSort (HsExpr GhcTc))]
forall a b. (a -> b) -> a -> b
$ \case
  L SrcSpan
new_span (Case HsExpr GhcTc
scrutinee []) -> (SrcSpan, EmptyCaseSort (HsExpr GhcTc))
-> [(SrcSpan, EmptyCaseSort (HsExpr GhcTc))]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SrcSpan
new_span, HsExpr GhcTc -> EmptyCaseSort (HsExpr GhcTc)
forall a. a -> EmptyCaseSort a
EmptyCase HsExpr GhcTc
scrutinee)
  L SrcSpan
new_span (expr :: HsExpr GhcTc
expr@(LamCase [])) -> (SrcSpan, EmptyCaseSort (HsExpr GhcTc))
-> [(SrcSpan, EmptyCaseSort (HsExpr GhcTc))]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SrcSpan
new_span, HsExpr GhcTc -> EmptyCaseSort (HsExpr GhcTc)
forall a. a -> EmptyCaseSort a
EmptyLamCase HsExpr GhcTc
expr)
  (GenLocated SrcSpan (HsExpr GhcTc)
_ :: LHsExpr GhcTc) -> [(SrcSpan, EmptyCaseSort (HsExpr GhcTc))]
forall a. Monoid a => a
mempty