{-# LANGUAGE DeriveAnyClass            #-}
{-# LANGUAGE DeriveGeneric             #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE InstanceSigs              #-}
{-# LANGUAGE NamedFieldPuns            #-}
{-# LANGUAGE OverloadedStrings         #-}
{-# LANGUAGE ScopedTypeVariables       #-}
{-# LANGUAGE TemplateHaskell           #-}
{-# LANGUAGE TypeFamilies              #-}

module Ide.Plugin.CodeRange.Rules
    ( CodeRange (..)
    , codeRange_range
    , codeRange_children
    , codeRange_kind
    , CodeRangeKind(..)
    , GetCodeRange(..)
    , codeRangeRule
    , Log(..)

    -- * Internal
    , removeInterleaving
    , simplify
    ) where

import           Control.DeepSeq                    (NFData)
import qualified Control.Lens                       as Lens
import           Control.Monad                      (foldM)
import           Control.Monad.Except               (ExceptT (..), runExceptT)
import           Control.Monad.Reader               (runReader)
import           Control.Monad.Trans.Class          (lift)
import           Control.Monad.Trans.Maybe          (MaybeT (MaybeT),
                                                     maybeToExceptT)
import           Control.Monad.Trans.Writer.CPS
import           Data.Coerce                        (coerce)
import           Data.Data                          (Typeable)
import           Data.Foldable                      (traverse_)
import           Data.Function                      (on, (&))
import           Data.Hashable
import           Data.List                          (sort)
import qualified Data.Map.Strict                    as Map
import           Data.Vector                        (Vector)
import qualified Data.Vector                        as V
import           Development.IDE
import           Development.IDE.Core.Rules         (toIdeResult)
import qualified Development.IDE.Core.Shake         as Shake
import           Development.IDE.GHC.Compat         (HieAST (..),
                                                     HieASTs (getAsts),
                                                     RefMap)
import           Development.IDE.GHC.Compat.Util
import           GHC.Generics                       (Generic)
import           Ide.Plugin.CodeRange.ASTPreProcess (CustomNodeType (..),
                                                     PreProcessEnv (..),
                                                     isCustomNode,
                                                     preProcessAST)
import           Language.LSP.Types.Lens            (HasEnd (end),
                                                     HasStart (start))
import           Prelude                            hiding (log)

data Log = LogShake Shake.Log
    | LogNoAST
    | LogFoundInterleaving CodeRange CodeRange
      deriving Int -> Log -> ShowS
[Log] -> ShowS
Log -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Log] -> ShowS
$cshowList :: [Log] -> ShowS
show :: Log -> String
$cshow :: Log -> String
showsPrec :: Int -> Log -> ShowS
$cshowsPrec :: Int -> Log -> ShowS
Show

instance Pretty Log where
    pretty :: forall ann. Log -> Doc ann
pretty Log
log = case Log
log of
        LogShake Log
shakeLog -> forall a ann. Pretty a => a -> Doc ann
pretty Log
shakeLog
        Log
LogNoAST          -> Doc ann
"no HieAst exist for file"
        LogFoundInterleaving CodeRange
r1 CodeRange
r2 ->
            let prettyRange :: CodeRange -> Doc ann
prettyRange = forall a ann. Pretty a => a -> Doc ann
pretty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. CodeRange -> Range
_codeRange_range
             in Doc ann
"CodeRange interleave: " forall a. Semigroup a => a -> a -> a
<> forall {ann}. CodeRange -> Doc ann
prettyRange CodeRange
r1 forall a. Semigroup a => a -> a -> a
<> Doc ann
" & " forall a. Semigroup a => a -> a -> a
<> forall {ann}. CodeRange -> Doc ann
prettyRange CodeRange
r2

-- | A tree representing code ranges in a file. This can be useful for features like selection range and folding range
data CodeRange = CodeRange {
    -- | Range for current level
        CodeRange -> Range
_codeRange_range    :: !Range,
    -- | A vector of children, sorted by their ranges in ascending order.
    -- Children are guaranteed not to interleave, but some gaps may exist among them.
        CodeRange -> Vector CodeRange
_codeRange_children :: !(Vector CodeRange),
    -- The kind of current code range
        CodeRange -> CodeRangeKind
_codeRange_kind     :: !CodeRangeKind
    }
    deriving (Int -> CodeRange -> ShowS
[CodeRange] -> ShowS
CodeRange -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CodeRange] -> ShowS
$cshowList :: [CodeRange] -> ShowS
show :: CodeRange -> String
$cshow :: CodeRange -> String
showsPrec :: Int -> CodeRange -> ShowS
$cshowsPrec :: Int -> CodeRange -> ShowS
Show, forall x. Rep CodeRange x -> CodeRange
forall x. CodeRange -> Rep CodeRange x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep CodeRange x -> CodeRange
$cfrom :: forall x. CodeRange -> Rep CodeRange x
Generic, CodeRange -> ()
forall a. (a -> ()) -> NFData a
rnf :: CodeRange -> ()
$crnf :: CodeRange -> ()
NFData)

-- | 'CodeKind' represents the kind of a code range
data CodeRangeKind =
    -- | ordinary code
    CodeKindRegion
    -- | the group of imports
  | CodeKindImports
  -- | a comment
  | CodeKindComment
    deriving (Int -> CodeRangeKind -> ShowS
[CodeRangeKind] -> ShowS
CodeRangeKind -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CodeRangeKind] -> ShowS
$cshowList :: [CodeRangeKind] -> ShowS
show :: CodeRangeKind -> String
$cshow :: CodeRangeKind -> String
showsPrec :: Int -> CodeRangeKind -> ShowS
$cshowsPrec :: Int -> CodeRangeKind -> ShowS
Show, forall x. Rep CodeRangeKind x -> CodeRangeKind
forall x. CodeRangeKind -> Rep CodeRangeKind x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep CodeRangeKind x -> CodeRangeKind
$cfrom :: forall x. CodeRangeKind -> Rep CodeRangeKind x
Generic, CodeRangeKind -> ()
forall a. (a -> ()) -> NFData a
rnf :: CodeRangeKind -> ()
$crnf :: CodeRangeKind -> ()
NFData)

Lens.makeLenses ''CodeRange

instance Eq CodeRange where
    == :: CodeRange -> CodeRange -> Bool
(==) = forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` CodeRange -> Range
_codeRange_range

instance Ord CodeRange where
    compare :: CodeRange -> CodeRange -> Ordering
    compare :: CodeRange -> CodeRange -> Ordering
compare = forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` CodeRange -> Range
_codeRange_range

-- | Construct a 'CodeRange'. A valid CodeRange will be returned in any case. If anything go wrong,
-- a list of warnings will be returned as 'Log'
buildCodeRange :: HieAST a -> RefMap a -> Writer [Log] CodeRange
buildCodeRange :: forall a. HieAST a -> RefMap a -> Writer [Log] CodeRange
buildCodeRange HieAST a
ast RefMap a
refMap = do
    -- We work on 'HieAST', then convert it to 'CodeRange', so that applications such as selection range and folding
    -- range don't need to care about 'HieAST'
    -- TODO @sloorush actually use 'Annotated ParsedSource' to handle structures not in 'HieAST' properly (for example comments)
    let ast' :: HieAST a
ast' = forall r a. Reader r a -> r -> a
runReader (forall a. HieAST a -> Reader (PreProcessEnv a) (HieAST a)
preProcessAST HieAST a
ast) (forall a. RefMap a -> PreProcessEnv a
PreProcessEnv RefMap a
refMap)
    CodeRange
codeRange <- forall a. HieAST a -> Writer [Log] CodeRange
astToCodeRange HieAST a
ast'
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ CodeRange -> CodeRange
simplify CodeRange
codeRange

astToCodeRange :: HieAST a -> Writer [Log] CodeRange
astToCodeRange :: forall a. HieAST a -> Writer [Log] CodeRange
astToCodeRange (Node SourcedNodeInfo a
_ Span
sp []) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Range -> Vector CodeRange -> CodeRangeKind -> CodeRange
CodeRange (Span -> Range
realSrcSpanToRange Span
sp) forall a. Monoid a => a
mempty CodeRangeKind
CodeKindRegion
astToCodeRange node :: HieAST a
node@(Node SourcedNodeInfo a
_ Span
sp [HieAST a]
children) = do
    [CodeRange]
children' <- [CodeRange] -> WriterT [Log] Identity [CodeRange]
removeInterleaving forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> [a]
sort forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a. HieAST a -> Writer [Log] CodeRange
astToCodeRange [HieAST a]
children
    let codeKind :: CodeRangeKind
codeKind = if forall a. a -> Maybe a
Just CustomNodeType
CustomNodeImportsGroup forall a. Eq a => a -> a -> Bool
== forall a. HieAST a -> Maybe CustomNodeType
isCustomNode HieAST a
node then CodeRangeKind
CodeKindImports else CodeRangeKind
CodeKindRegion
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Range -> Vector CodeRange -> CodeRangeKind -> CodeRange
CodeRange (Span -> Range
realSrcSpanToRange Span
sp) (forall a. [a] -> Vector a
V.fromList [CodeRange]
children') CodeRangeKind
codeKind

-- | Remove interleaving of the list of 'CodeRange's.
removeInterleaving :: [CodeRange] -> Writer [Log] [CodeRange]
removeInterleaving :: [CodeRange] -> WriterT [Log] Identity [CodeRange]
removeInterleaving = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM [CodeRange] -> CodeRange -> WriterT [Log] Identity [CodeRange]
go []
  where
    -- we want to traverse from left to right (to make the logs easier to read)
    go :: [CodeRange] -> CodeRange -> Writer [Log] [CodeRange]
    go :: [CodeRange] -> CodeRange -> WriterT [Log] Identity [CodeRange]
go [] CodeRange
x = forall (f :: * -> *) a. Applicative f => a -> f a
pure [CodeRange
x]
    go (CodeRange
x1:[CodeRange]
acc) CodeRange
x2 = do
        -- Given that the CodeRange is already sorted on it's Range, and the Ord instance of Range
        -- compares it's start position first, the start position must be already in an ascending order.
        -- Then, if the end position of a node is larger than it's next neighbour's start position, an interleaving
        -- must exist.
        -- (Note: LSP Range's end position is exclusive)
        CodeRange
x1' <- if CodeRange
x1 forall s a. s -> Getting a s a -> a
Lens.^. Lens' CodeRange Range
codeRange_range forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasEnd s a => Lens' s a
end forall a. Ord a => a -> a -> Bool
> CodeRange
x2 forall s a. s -> Getting a s a -> a
Lens.^. Lens' CodeRange Range
codeRange_range forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasStart s a => Lens' s a
start
            then do
                -- set x1.end to x2.start
                let CodeRange
x1' :: CodeRange = CodeRange
x1 forall a b. a -> (a -> b) -> b
& Lens' CodeRange Range
codeRange_range forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasEnd s a => Lens' s a
end forall s t a b. ASetter s t a b -> b -> s -> t
Lens..~ (CodeRange
x2 forall s a. s -> Getting a s a -> a
Lens.^. Lens' CodeRange Range
codeRange_range forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasStart s a => Lens' s a
start)
                forall w (m :: * -> *). (Monoid w, Monad m) => w -> WriterT w m ()
tell [CodeRange -> CodeRange -> Log
LogFoundInterleaving CodeRange
x1 CodeRange
x2]
                forall (f :: * -> *) a. Applicative f => a -> f a
pure CodeRange
x1'
            else forall (f :: * -> *) a. Applicative f => a -> f a
pure CodeRange
x1
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ CodeRange
x2forall a. a -> [a] -> [a]
:CodeRange
x1'forall a. a -> [a] -> [a]
:[CodeRange]
acc

-- | Remove redundant nodes in 'CodeRange' tree
simplify :: CodeRange -> CodeRange
simplify :: CodeRange -> CodeRange
simplify CodeRange
r =
    case Maybe CodeRange
onlyChild of
        -- If a node has the exact same range as it's parent, and it has no sibling, then it can be removed.
        Just CodeRange
onlyChild' ->
            if CodeRange -> Range
_codeRange_range CodeRange
onlyChild' forall a. Eq a => a -> a -> Bool
== Range
curRange
            then CodeRange -> CodeRange
simplify (CodeRange
r { _codeRange_children :: Vector CodeRange
_codeRange_children = CodeRange -> Vector CodeRange
_codeRange_children CodeRange
onlyChild' })
            else CodeRange
withChildrenSimplified
        Maybe CodeRange
Nothing -> CodeRange
withChildrenSimplified
  where
    curRange :: Range
curRange = CodeRange -> Range
_codeRange_range CodeRange
r

    Maybe CodeRange
onlyChild :: Maybe CodeRange =
        let children :: Vector CodeRange
children = CodeRange -> Vector CodeRange
_codeRange_children CodeRange
r
         in if forall a. Vector a -> Int
V.length Vector CodeRange
children forall a. Eq a => a -> a -> Bool
== Int
1 then forall (m :: * -> *) a. Monad m => Vector a -> m a
V.headM Vector CodeRange
children else forall a. Maybe a
Nothing

    withChildrenSimplified :: CodeRange
withChildrenSimplified = CodeRange
r { _codeRange_children :: Vector CodeRange
_codeRange_children = CodeRange -> CodeRange
simplify forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CodeRange -> Vector CodeRange
_codeRange_children CodeRange
r }

data GetCodeRange = GetCodeRange
    deriving (GetCodeRange -> GetCodeRange -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GetCodeRange -> GetCodeRange -> Bool
$c/= :: GetCodeRange -> GetCodeRange -> Bool
== :: GetCodeRange -> GetCodeRange -> Bool
$c== :: GetCodeRange -> GetCodeRange -> Bool
Eq, Int -> GetCodeRange -> ShowS
[GetCodeRange] -> ShowS
GetCodeRange -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GetCodeRange] -> ShowS
$cshowList :: [GetCodeRange] -> ShowS
show :: GetCodeRange -> String
$cshow :: GetCodeRange -> String
showsPrec :: Int -> GetCodeRange -> ShowS
$cshowsPrec :: Int -> GetCodeRange -> ShowS
Show, Typeable, forall x. Rep GetCodeRange x -> GetCodeRange
forall x. GetCodeRange -> Rep GetCodeRange x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep GetCodeRange x -> GetCodeRange
$cfrom :: forall x. GetCodeRange -> Rep GetCodeRange x
Generic)

instance Hashable GetCodeRange
instance NFData   GetCodeRange

type instance RuleResult GetCodeRange = CodeRange

codeRangeRule :: Recorder (WithPriority Log) -> Rules ()
codeRangeRule :: Recorder (WithPriority Log) -> Rules ()
codeRangeRule Recorder (WithPriority Log)
recorder =
    forall k v.
IdeRule k v =>
Recorder (WithPriority Log)
-> (k -> NormalizedFilePath -> Action (IdeResult v)) -> Rules ()
define (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogShake Recorder (WithPriority Log)
recorder) forall a b. (a -> b) -> a -> b
$ \GetCodeRange
GetCodeRange NormalizedFilePath
file -> forall msg a.
Recorder (WithPriority msg)
-> ExceptT msg Action a -> Action (IdeResult a)
handleError Recorder (WithPriority Log)
recorder forall a b. (a -> b) -> a -> b
$ do
        -- We need both 'HieAST' (for basic AST) and api annotations (for comments and some keywords).
        -- See https://gitlab.haskell.org/ghc/ghc/-/wikis/api-annotations
        HAR{HieASTs a
hieAst :: ()
hieAst :: HieASTs a
hieAst, RefMap a
refMap :: ()
refMap :: RefMap a
refMap} <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ GetHieAst
GetHieAst NormalizedFilePath
file
        HieAST a
ast <- forall (m :: * -> *) e a.
Functor m =>
e -> MaybeT m a -> ExceptT e m a
maybeToExceptT Log
LogNoAST forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
            forall a. HieASTs a -> Map HiePath (HieAST a)
getAsts HieASTs a
hieAst forall k a. Ord k => Map k a -> k -> Maybe a
Map.!? (coerce :: forall a b. Coercible a b => a -> b
coerce forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> FastString
mkFastString forall b c a. (b -> c) -> (a -> b) -> a -> c
. NormalizedFilePath -> String
fromNormalizedFilePath) NormalizedFilePath
file
        let (CodeRange
codeRange, [Log]
warnings) = forall w a. Monoid w => Writer w a -> (a, w)
runWriter (forall a. HieAST a -> RefMap a -> Writer [Log] CodeRange
buildCodeRange HieAST a
ast RefMap a
refMap)
        forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Warning) [Log]
warnings

        forall (f :: * -> *) a. Applicative f => a -> f a
pure CodeRange
codeRange

-- | Handle error in 'Action'. Returns an 'IdeResult' with no value and no diagnostics on error. (but writes log)
handleError :: Recorder (WithPriority msg) -> ExceptT msg Action a -> Action (IdeResult a)
handleError :: forall msg a.
Recorder (WithPriority msg)
-> ExceptT msg Action a -> Action (IdeResult a)
handleError Recorder (WithPriority msg)
recorder ExceptT msg Action a
action' = do
    Either msg a
valueEither <- forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT msg Action a
action'
    case Either msg a
valueEither of
        Left msg
msg -> do
            forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority msg)
recorder Priority
Error msg
msg
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall v. Either [FileDiagnostic] v -> IdeResult v
toIdeResult (forall a b. a -> Either a b
Left [])
        Right a
value -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall v. Either [FileDiagnostic] v -> IdeResult v
toIdeResult (forall a b. b -> Either a b
Right a
value)