{-# LANGUAGE ViewPatterns #-}

module Ide.Plugin.Class.Utils where

import           Control.Monad.IO.Class           (MonadIO, liftIO)
import           Control.Monad.Trans.Except
import           Data.Char                        (isAlpha)
import           Data.List                        (isPrefixOf)
import           Data.String                      (IsString)
import qualified Data.Text                        as T
import           Development.IDE
import           Development.IDE.Core.PluginUtils
import           Development.IDE.GHC.Compat
import           Development.IDE.GHC.Compat.Util
import           Development.IDE.Spans.Pragmas    (getNextPragmaInfo,
                                                   insertNewPragma)
import           Ide.Plugin.Error
import           Ide.PluginUtils
import           Language.LSP.Protocol.Types

-- | All instance bindings are started with `$c`
bindingPrefix :: IsString s => s
bindingPrefix :: forall s. IsString s => s
bindingPrefix = s
"$c"

isBindingName :: Name -> Bool
isBindingName :: Name -> Bool
isBindingName Name
name = [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf [Char]
forall s. IsString s => s
bindingPrefix ([Char] -> Bool) -> [Char] -> Bool
forall a b. (a -> b) -> a -> b
$ OccName -> [Char]
occNameString (OccName -> [Char]) -> OccName -> [Char]
forall a b. (a -> b) -> a -> b
$ Name -> OccName
nameOccName Name
name

-- | Check if some `HasSrcSpan` value in the given range
inRange :: Range -> SrcSpan -> Bool
inRange :: Range -> SrcSpan -> Bool
inRange Range
range SrcSpan
s = Bool -> (Range -> Bool) -> Maybe Range -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Range -> Range -> Bool
subRange Range
range) (SrcSpan -> Maybe Range
srcSpanToRange SrcSpan
s)

ghostSpan :: RealSrcSpan
ghostSpan :: RealSrcSpan
ghostSpan = RealSrcLoc -> RealSrcSpan
realSrcLocSpan (RealSrcLoc -> RealSrcSpan) -> RealSrcLoc -> RealSrcSpan
forall a b. (a -> b) -> a -> b
$ FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc ([Char] -> FastString
fsLit [Char]
"<haskell-language-sever>") Int
1 Int
1

-- | "$cname" ==> "name"
prettyBindingNameString :: T.Text -> T.Text
prettyBindingNameString :: Text -> Text
prettyBindingNameString Text
name
    | Text -> Text -> Bool
T.isPrefixOf Text
forall s. IsString s => s
bindingPrefix Text
name =
        Text -> Text
toMethodName (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.drop (Text -> Int
T.length Text
forall s. IsString s => s
bindingPrefix) Text
name
    | Bool
otherwise = Text
name

showDoc :: HscEnv -> TcGblEnv -> Type -> String
showDoc :: HscEnv -> TcGblEnv -> Type -> [Char]
showDoc HscEnv
hsc TcGblEnv
gblEnv Type
ty = HscEnv -> PrintUnqualified -> SDoc -> [Char]
showSDocForUser' HscEnv
hsc (HscEnv -> GlobalRdrEnv -> PrintUnqualified
mkPrintUnqualifiedDefault HscEnv
hsc (TcGblEnv -> GlobalRdrEnv
rdrEnv TcGblEnv
gblEnv)) (Type -> SDoc
pprSigmaType Type
ty)
    where rdrEnv :: TcGblEnv -> GlobalRdrEnv
rdrEnv TcGblEnv
gblEnv = TcGblEnv -> GlobalRdrEnv
tcg_rdr_env TcGblEnv
gblEnv

-- | Paren the name for pretty display if necessary
toMethodName :: T.Text -> T.Text
toMethodName :: Text -> Text
toMethodName Text
n
    | Just (Char
h, Text
_) <- Text -> Maybe (Char, Text)
T.uncons Text
n
    , Bool -> Bool
not (Char -> Bool
isAlpha Char
h Bool -> Bool -> Bool
|| Char
h Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_')
    = Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
    | Bool
otherwise
    = Text
n

-- | Here we use `useWithStale` to compute, Using stale results means that we can almost always return a value.
--   In practice this means the lenses don't 'flicker'.
--   This function is also used in code actions, but it doesn't matter because our actions only work
--   if the module parsed success.
insertPragmaIfNotPresent :: (MonadIO m)
    => IdeState
    -> NormalizedFilePath
    -> Extension
    -> ExceptT PluginError m [TextEdit]
insertPragmaIfNotPresent :: forall (m :: * -> *).
MonadIO m =>
IdeState
-> NormalizedFilePath
-> Extension
-> ExceptT PluginError m [TextEdit]
insertPragmaIfNotPresent IdeState
state NormalizedFilePath
nfp Extension
pragma = do
    (HscEnvEq -> HscEnv
hscEnv -> HscEnv -> DynFlags
hsc_dflags -> DynFlags
sessionDynFlags, PositionMapping
_) <- [Char]
-> IdeState
-> ExceptT PluginError Action (HscEnvEq, PositionMapping)
-> ExceptT PluginError m (HscEnvEq, PositionMapping)
forall (m :: * -> *) e a.
MonadIO m =>
[Char] -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE [Char]
"classplugin.insertPragmaIfNotPresent.GhcSession" IdeState
state
        (ExceptT PluginError Action (HscEnvEq, PositionMapping)
 -> ExceptT PluginError m (HscEnvEq, PositionMapping))
-> ExceptT PluginError Action (HscEnvEq, PositionMapping)
-> ExceptT PluginError m (HscEnvEq, PositionMapping)
forall a b. (a -> b) -> a -> b
$ GhcSession
-> NormalizedFilePath
-> ExceptT PluginError Action (HscEnvEq, PositionMapping)
forall k v.
IdeRule k v =>
k
-> NormalizedFilePath
-> ExceptT PluginError Action (v, PositionMapping)
useWithStaleE GhcSession
GhcSession NormalizedFilePath
nfp
    (UTCTime
_, Maybe Text
fileContents) <- IO (UTCTime, Maybe Text)
-> ExceptT PluginError m (UTCTime, Maybe Text)
forall a. IO a -> ExceptT PluginError m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (UTCTime, Maybe Text)
 -> ExceptT PluginError m (UTCTime, Maybe Text))
-> IO (UTCTime, Maybe Text)
-> ExceptT PluginError m (UTCTime, Maybe Text)
forall a b. (a -> b) -> a -> b
$ [Char]
-> IdeState
-> Action (UTCTime, Maybe Text)
-> IO (UTCTime, Maybe Text)
forall a. [Char] -> IdeState -> Action a -> IO a
runAction [Char]
"classplugin.insertPragmaIfNotPresent.GetFileContents" IdeState
state
        (Action (UTCTime, Maybe Text) -> IO (UTCTime, Maybe Text))
-> Action (UTCTime, Maybe Text) -> IO (UTCTime, Maybe Text)
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> Action (UTCTime, Maybe Text)
getFileContents NormalizedFilePath
nfp
    (ParsedModule
pm, PositionMapping
_) <- [Char]
-> IdeState
-> ExceptT PluginError Action (ParsedModule, PositionMapping)
-> ExceptT PluginError m (ParsedModule, PositionMapping)
forall (m :: * -> *) e a.
MonadIO m =>
[Char] -> IdeState -> ExceptT e Action a -> ExceptT e m a
runActionE [Char]
"classplugin.insertPragmaIfNotPresent.GetParsedModuleWithComments" IdeState
state
        (ExceptT PluginError Action (ParsedModule, PositionMapping)
 -> ExceptT PluginError m (ParsedModule, PositionMapping))
-> ExceptT PluginError Action (ParsedModule, PositionMapping)
-> ExceptT PluginError m (ParsedModule, PositionMapping)
forall a b. (a -> b) -> a -> b
$ GetParsedModuleWithComments
-> NormalizedFilePath
-> ExceptT PluginError Action (ParsedModule, PositionMapping)
forall k v.
IdeRule k v =>
k
-> NormalizedFilePath
-> ExceptT PluginError Action (v, PositionMapping)
useWithStaleE GetParsedModuleWithComments
GetParsedModuleWithComments NormalizedFilePath
nfp
    let exts :: [Extension]
exts = ParsedModule -> [Extension]
getExtensions ParsedModule
pm
        info :: NextPragmaInfo
info = DynFlags -> Maybe Text -> NextPragmaInfo
getNextPragmaInfo DynFlags
sessionDynFlags Maybe Text
fileContents
    [TextEdit] -> ExceptT PluginError m [TextEdit]
forall a. a -> ExceptT PluginError m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [NextPragmaInfo -> Extension -> TextEdit
insertNewPragma NextPragmaInfo
info Extension
pragma | Extension
pragma Extension -> [Extension] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Extension]
exts]