{-# 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 "wingman.emptyCase"


------------------------------------------------------------------------------
-- | A command function that just applies a 'WorkspaceEdit'.
workspaceEditHandler :: CommandFunction IdeState WorkspaceEdit
workspaceEditHandler _ideState wedit = do
  _ <- sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ())
  return $ Right Null


------------------------------------------------------------------------------
-- | Provide the "empty case completion" code lens
codeLensProvider :: PluginMethodHandler IdeState TextDocumentCodeLens
codeLensProvider state plId (CodeLensParams _ _ (TextDocumentIdentifier uri))
  | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do
      let stale a = runStaleIde "codeLensProvider" state nfp a

      ccs <- getClientCapabilities
      liftIO $ fromMaybeT (Right $ List []) $ do
        dflags <- getIdeDynflags state nfp
        TrackedStale pm _ <- stale GetAnnotatedParsedSource
        TrackedStale binds bind_map <- stale GetBindings
        holes <- emptyCaseScrutinees state nfp

        fmap (Right . List) $ for holes $ \(ss, ty) -> do
          binds_ss <- liftMaybe $ mapAgeFrom bind_map ss
          let bindings = getLocalScope (unTrack binds) $ unTrack binds_ss
              range = realSrcSpanToRange $ unTrack ss
          matches <-
            liftMaybe $
              destructionFor
                (foldMap (hySingleton . occName . fst) bindings)
                ty
          edits <- liftMaybe $ hush $
                mkWorkspaceEdits dflags ccs uri (unTrack pm) $
                  graftMatchGroup (RealSrcSpan $ unTrack ss) $
                    noLoc matches

          pure $
            CodeLens range
              (Just
                $ mkLspCommand
                    plId
                    emptyCaseLensCommandId
                    (mkEmptyCaseLensDesc ty)
                $ Just $ pure $ toJSON $ edits
              )
              Nothing
codeLensProvider _ _ _ = pure $ Right $ List []


scrutinzedType :: EmptyCaseSort Type -> Maybe Type
scrutinzedType (EmptyCase ty) = pure  ty
scrutinzedType (EmptyLamCase ty) =
  case tacticsSplitFunTy ty of
    (_, _, tys, _) -> listToMaybe  tys


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


------------------------------------------------------------------------------
-- | Silence an error.
hush :: Either e a -> Maybe a
hush (Left _) = Nothing
hush (Right a) = Just 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 ss l =
  hoistGraft (runExcept . runExceptString) $ graftExprWithM ss $ \case
    L span (HsCase ext scrut mg@_) -> do
      pure $ Just $ L span $ HsCase ext scrut $ mg { mg_alts = l }
    L span (HsLamCase ext mg@_) -> do
      pure $ Just $ L span $ HsLamCase ext $ mg { mg_alts = l }
    (_ :: LHsExpr GhcPs) -> pure Nothing


fromMaybeT :: Functor m => a -> MaybeT m a -> m a
fromMaybeT def = fmap (fromMaybe def) . 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 state nfp = do
    let stale a = runStaleIde "emptyCaseScrutinees" state nfp a

    TrackedStale tcg tcg_map <- fmap (fmap tmrTypechecked) $ stale TypeCheck
    let tcg' = unTrack tcg
    hscenv <- stale GhcSessionDeps

    let scrutinees = traverse (emptyCaseQ . tcg_binds) tcg
    fmap catMaybes $ for scrutinees $ \aged@(unTrack -> (ss, scrutinee)) -> do
      ty <- MaybeT
          . fmap (scrutinzedType <=< sequence)
          . traverse (typeCheck (hscEnv $ untrackedStaleValue hscenv) tcg')
          $ scrutinee
      case null $ tacticsGetDataCons ty of
        True -> pure empty
        False ->
          case ss of
            RealSrcSpan r   -> do
              rss' <- liftMaybe $ mapAgeTo tcg_map $ unsafeCopyAge aged r
              pure $ Just (rss', ty)
            UnhelpfulSpan _ -> empty

data EmptyCaseSort a
  = EmptyCase a
  | EmptyLamCase a
  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)

------------------------------------------------------------------------------
-- | Get the 'SrcSpan' and scrutinee of every empty case.
emptyCaseQ :: GenericQ [(SrcSpan, EmptyCaseSort (HsExpr GhcTc))]
emptyCaseQ = everything (<>) $ mkQ mempty $ \case
  L new_span (Case scrutinee []) -> pure (new_span, EmptyCase scrutinee)
  L new_span (expr@(LamCase [])) -> pure (new_span, EmptyLamCase expr)
  (_ :: LHsExpr GhcTc) -> mempty