{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE TypeFamilies      #-}

{-# 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.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, realSrcSpanToRange)
import           Development.IDE.Core.RuleTypes
import           Development.IDE.Core.Shake (IdeState (..))
import           Development.IDE.Core.UseStale
import           Development.IDE.GHC.Compat hiding (empty)
import           Development.IDE.GHC.ExactPrint
import           Development.IDE.Spans.LocalBindings (getLocalScope)
import           Ide.Types
import           Language.LSP.Server
import           Language.LSP.Types
import           Prelude hiding (span)
import           Wingman.AbstractLSP.Types
import           Wingman.CodeGen (destructionFor)
import           Wingman.GHC
import           Wingman.Judgements
import           Wingman.LanguageServer
import           Wingman.Types


data EmptyCaseT = EmptyCaseT

instance IsContinuationSort EmptyCaseT where
  toCommandId :: EmptyCaseT -> CommandId
toCommandId EmptyCaseT
_ = Text -> CommandId
CommandId Text
"wingman.emptyCase"

instance IsTarget EmptyCaseT where
  type TargetArgs EmptyCaseT = ()
  fetchTargetArgs :: LspEnv -> MaybeT (LspM Config) (TargetArgs EmptyCaseT)
fetchTargetArgs LspEnv
_ = () -> MaybeT (LspM Config) ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

emptyCaseInteraction :: Interaction
emptyCaseInteraction :: Interaction
emptyCaseInteraction = Continuation EmptyCaseT EmptyCaseT WorkspaceEdit -> Interaction
forall target sort b.
(IsTarget target, IsContinuationSort sort, ToJSON b, FromJSON b) =>
Continuation sort target b -> Interaction
Interaction (Continuation EmptyCaseT EmptyCaseT WorkspaceEdit -> Interaction)
-> Continuation EmptyCaseT EmptyCaseT WorkspaceEdit -> Interaction
forall a b. (a -> b) -> a -> b
$
  EmptyCaseT
-> SynthesizeCommand EmptyCaseT WorkspaceEdit
-> (LspEnv
    -> TargetArgs EmptyCaseT
    -> FileContext
    -> WorkspaceEdit
    -> MaybeT (LspM Config) [ContinuationResult])
-> Continuation EmptyCaseT EmptyCaseT WorkspaceEdit
forall sort target payload.
sort
-> SynthesizeCommand target payload
-> (LspEnv
    -> TargetArgs target
    -> FileContext
    -> payload
    -> MaybeT (LspM Config) [ContinuationResult])
-> Continuation sort target payload
Continuation @EmptyCaseT @EmptyCaseT @WorkspaceEdit EmptyCaseT
EmptyCaseT
    ((LspEnv
 -> TargetArgs EmptyCaseT
 -> MaybeT (LspM Config) [(Range, Metadata, WorkspaceEdit)])
-> SynthesizeCommand EmptyCaseT WorkspaceEdit
forall a b.
(LspEnv
 -> TargetArgs a -> MaybeT (LspM Config) [(Range, Metadata, b)])
-> SynthesizeCommand a b
SynthesizeCodeLens ((LspEnv
  -> TargetArgs EmptyCaseT
  -> MaybeT (LspM Config) [(Range, Metadata, WorkspaceEdit)])
 -> SynthesizeCommand EmptyCaseT WorkspaceEdit)
-> (LspEnv
    -> TargetArgs EmptyCaseT
    -> MaybeT (LspM Config) [(Range, Metadata, WorkspaceEdit)])
-> SynthesizeCommand EmptyCaseT WorkspaceEdit
forall a b. (a -> b) -> a -> b
$ \LspEnv{DynFlags
IdeState
PluginId
Config
FileContext
le_fileContext :: LspEnv -> FileContext
le_config :: LspEnv -> Config
le_dflags :: LspEnv -> DynFlags
le_pluginId :: LspEnv -> PluginId
le_ideState :: LspEnv -> IdeState
le_fileContext :: FileContext
le_config :: Config
le_dflags :: DynFlags
le_pluginId :: PluginId
le_ideState :: IdeState
..} TargetArgs EmptyCaseT
_ -> do
      let FileContext{Maybe (Tracked 'Current Range)
Uri
fc_range :: FileContext -> Maybe (Tracked 'Current Range)
fc_uri :: FileContext -> Uri
fc_range :: Maybe (Tracked 'Current Range)
fc_uri :: Uri
..} = FileContext
le_fileContext
      NormalizedFilePath
nfp <- Uri -> MaybeT (LspM Config) NormalizedFilePath
forall (m :: * -> *).
Applicative m =>
Uri -> MaybeT m NormalizedFilePath
getNfp Uri
fc_uri

      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, Show a, Typeable a, NFData a,
 Show r, Typeable r, NFData r) =>
String
-> IdeState
-> NormalizedFilePath
-> a
-> MaybeT IO (TrackedStale r)
runStaleIde String
"codeLensProvider" IdeState
le_ideState NormalizedFilePath
nfp a
a

      ClientCapabilities
ccs <- LspM Config ClientCapabilities
-> MaybeT (LspM Config) ClientCapabilities
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift LspM Config ClientCapabilities
forall config (m :: * -> *).
MonadLsp config m =>
m ClientCapabilities
getClientCapabilities
      TrackedStale Tracked ('Stale s) (Annotated ParsedSource)
pm PositionMap ('Stale s) 'Current
_ <- (IO (Maybe (TrackedStale (Annotated ParsedSource)))
 -> LspM Config (Maybe (TrackedStale (Annotated ParsedSource))))
-> MaybeT IO (TrackedStale (Annotated ParsedSource))
-> MaybeT (LspM Config) (TrackedStale (Annotated ParsedSource))
forall (m :: * -> *) a (n :: * -> *) b.
(m (Maybe a) -> n (Maybe b)) -> MaybeT m a -> MaybeT n b
mapMaybeT IO (Maybe (TrackedStale (Annotated ParsedSource)))
-> LspM Config (Maybe (TrackedStale (Annotated ParsedSource)))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (MaybeT IO (TrackedStale (Annotated ParsedSource))
 -> MaybeT (LspM Config) (TrackedStale (Annotated ParsedSource)))
-> MaybeT IO (TrackedStale (Annotated ParsedSource))
-> MaybeT (LspM Config) (TrackedStale (Annotated ParsedSource))
forall a b. (a -> b) -> a -> b
$ GetAnnotatedParsedSource
-> MaybeT IO (TrackedStale (RuleResult GetAnnotatedParsedSource))
forall a.
(Hashable 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 <- (IO (Maybe (TrackedStale Bindings))
 -> LspM Config (Maybe (TrackedStale Bindings)))
-> MaybeT IO (TrackedStale Bindings)
-> MaybeT (LspM Config) (TrackedStale Bindings)
forall (m :: * -> *) a (n :: * -> *) b.
(m (Maybe a) -> n (Maybe b)) -> MaybeT m a -> MaybeT n b
mapMaybeT IO (Maybe (TrackedStale Bindings))
-> LspM Config (Maybe (TrackedStale Bindings))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (MaybeT IO (TrackedStale Bindings)
 -> MaybeT (LspM Config) (TrackedStale Bindings))
-> MaybeT IO (TrackedStale Bindings)
-> MaybeT (LspM Config) (TrackedStale Bindings)
forall a b. (a -> b) -> a -> b
$ GetBindings -> MaybeT IO (TrackedStale (RuleResult GetBindings))
forall a.
(Hashable 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 <- (IO (Maybe [(Tracked 'Current RealSrcSpan, Type)])
 -> LspM Config (Maybe [(Tracked 'Current RealSrcSpan, Type)]))
-> MaybeT IO [(Tracked 'Current RealSrcSpan, Type)]
-> MaybeT (LspM Config) [(Tracked 'Current RealSrcSpan, Type)]
forall (m :: * -> *) a (n :: * -> *) b.
(m (Maybe a) -> n (Maybe b)) -> MaybeT m a -> MaybeT n b
mapMaybeT IO (Maybe [(Tracked 'Current RealSrcSpan, Type)])
-> LspM Config (Maybe [(Tracked 'Current RealSrcSpan, Type)])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (MaybeT IO [(Tracked 'Current RealSrcSpan, Type)]
 -> MaybeT (LspM Config) [(Tracked 'Current RealSrcSpan, Type)])
-> MaybeT IO [(Tracked 'Current RealSrcSpan, Type)]
-> MaybeT (LspM Config) [(Tracked 'Current RealSrcSpan, Type)]
forall a b. (a -> b) -> a -> b
$ IdeState
-> NormalizedFilePath
-> MaybeT IO [(Tracked 'Current RealSrcSpan, Type)]
emptyCaseScrutinees IdeState
le_ideState NormalizedFilePath
nfp

      [(Tracked 'Current RealSrcSpan, Type)]
-> ((Tracked 'Current RealSrcSpan, Type)
    -> MaybeT (LspM Config) (Range, Metadata, WorkspaceEdit))
-> MaybeT (LspM Config) [(Range, Metadata, WorkspaceEdit)]
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 (LspM Config) (Range, Metadata, WorkspaceEdit))
 -> MaybeT (LspM Config) [(Range, Metadata, WorkspaceEdit)])
-> ((Tracked 'Current RealSrcSpan, Type)
    -> MaybeT (LspM Config) (Range, Metadata, WorkspaceEdit))
-> MaybeT (LspM Config) [(Range, Metadata, WorkspaceEdit)]
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 (LspM Config) (Tracked ('Stale s) RealSrcSpan)
forall (m :: * -> *) a. Monad m => Maybe a -> MaybeT m a
liftMaybe (Maybe (Tracked ('Stale s) RealSrcSpan)
 -> MaybeT (LspM Config) (Tracked ('Stale s) RealSrcSpan))
-> Maybe (Tracked ('Stale s) RealSrcSpan)
-> MaybeT (LspM Config) (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 (LspM Config) [LMatch GhcPs (LHsExpr GhcPs)]
forall (m :: * -> *) a. Monad m => Maybe a -> MaybeT m a
liftMaybe (Maybe [LMatch GhcPs (LHsExpr GhcPs)]
 -> MaybeT (LspM Config) [LMatch GhcPs (LHsExpr GhcPs)])
-> Maybe [LMatch GhcPs (LHsExpr GhcPs)]
-> MaybeT (LspM Config) [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 (LspM Config) WorkspaceEdit
forall (m :: * -> *) a. Monad m => Maybe a -> MaybeT m a
liftMaybe (Maybe WorkspaceEdit -> MaybeT (LspM Config) WorkspaceEdit)
-> Maybe WorkspaceEdit -> MaybeT (LspM Config) 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
le_dflags ClientCapabilities
ccs Uri
fc_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 -> Maybe () -> SrcSpan
RealSrcSpan (Tracked 'Current RealSrcSpan -> RealSrcSpan
forall (age :: Age) a. Tracked age a -> a
unTrack Tracked 'Current RealSrcSpan
ss) Maybe ()
forall a. Maybe a
Nothing) (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
        (Range, Metadata, WorkspaceEdit)
-> MaybeT (LspM Config) (Range, Metadata, WorkspaceEdit)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          ( Range
range
          , Text -> CodeActionKind -> Bool -> Metadata
Metadata
              (Type -> Text
mkEmptyCaseLensDesc Type
ty)
              (Text -> CodeActionKind
CodeActionUnknown Text
"refactor.wingman.completeEmptyCase")
              Bool
False
          , WorkspaceEdit
edits
          )
    )
    (\ LspEnv
_ TargetArgs EmptyCaseT
_ FileContext
_ WorkspaceEdit
we -> [ContinuationResult] -> MaybeT (LspM Config) [ContinuationResult]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ContinuationResult] -> MaybeT (LspM Config) [ContinuationResult])
-> [ContinuationResult]
-> MaybeT (LspM Config) [ContinuationResult]
forall a b. (a -> b) -> a -> b
$ ContinuationResult -> [ContinuationResult]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ContinuationResult -> [ContinuationResult])
-> ContinuationResult -> [ContinuationResult]
forall a b. (a -> b) -> a -> b
$ WorkspaceEdit -> ContinuationResult
RawEdit WorkspaceEdit
we)


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 -> Maybe Type) -> ThetaType -> Maybe Type
forall a b. (a -> b) -> a -> b
$ (Type -> Type) -> ThetaType -> ThetaType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> Type
forall a. Scaled a -> Scaled a
scaledThing 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 MatchGroup GhcPs (LHsExpr GhcPs)
mg) -> 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 MatchGroup GhcPs (LHsExpr GhcPs)
mg) -> 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, 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.
(Hashable 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.
(Hashable 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 Maybe ()
_ -> 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