{-# LANGUAGE DeriveAnyClass    #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell   #-}
{-# LANGUAGE TypeFamilies      #-}

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

    -- * Internal
    , removeInterleaving
    , simplify
    , crkToFrk
    ) 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.Protocol.Types        (FoldingRangeKind (FoldingRangeKind_Comment, FoldingRangeKind_Imports, FoldingRangeKind_Region))

import           Language.LSP.Protocol.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
(Int -> Log -> ShowS)
-> (Log -> String) -> ([Log] -> ShowS) -> Show Log
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Log -> ShowS
showsPrec :: Int -> Log -> ShowS
$cshow :: Log -> String
show :: Log -> String
$cshowList :: [Log] -> ShowS
showList :: [Log] -> ShowS
Show

instance Pretty Log where
    pretty :: forall ann. Log -> Doc ann
pretty Log
log = case Log
log of
        LogShake Log
shakeLog -> Log -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Log -> 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 = String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Doc ann)
-> (CodeRange -> String) -> CodeRange -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Range -> String
forall a. Show a => a -> String
show (Range -> String) -> (CodeRange -> Range) -> CodeRange -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CodeRange -> Range
_codeRange_range
             in Doc ann
"CodeRange interleave: " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> CodeRange -> Doc ann
forall {ann}. CodeRange -> Doc ann
prettyRange CodeRange
r1 Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
" & " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> CodeRange -> Doc ann
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
(Int -> CodeRange -> ShowS)
-> (CodeRange -> String)
-> ([CodeRange] -> ShowS)
-> Show CodeRange
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CodeRange -> ShowS
showsPrec :: Int -> CodeRange -> ShowS
$cshow :: CodeRange -> String
show :: CodeRange -> String
$cshowList :: [CodeRange] -> ShowS
showList :: [CodeRange] -> ShowS
Show, (forall x. CodeRange -> Rep CodeRange x)
-> (forall x. Rep CodeRange x -> CodeRange) -> Generic CodeRange
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
$cfrom :: forall x. CodeRange -> Rep CodeRange x
from :: forall x. CodeRange -> Rep CodeRange x
$cto :: forall x. Rep CodeRange x -> CodeRange
to :: forall x. Rep CodeRange x -> CodeRange
Generic, CodeRange -> ()
(CodeRange -> ()) -> NFData CodeRange
forall a. (a -> ()) -> NFData a
$crnf :: CodeRange -> ()
rnf :: 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
(Int -> CodeRangeKind -> ShowS)
-> (CodeRangeKind -> String)
-> ([CodeRangeKind] -> ShowS)
-> Show CodeRangeKind
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CodeRangeKind -> ShowS
showsPrec :: Int -> CodeRangeKind -> ShowS
$cshow :: CodeRangeKind -> String
show :: CodeRangeKind -> String
$cshowList :: [CodeRangeKind] -> ShowS
showList :: [CodeRangeKind] -> ShowS
Show, CodeRangeKind -> CodeRangeKind -> Bool
(CodeRangeKind -> CodeRangeKind -> Bool)
-> (CodeRangeKind -> CodeRangeKind -> Bool) -> Eq CodeRangeKind
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CodeRangeKind -> CodeRangeKind -> Bool
== :: CodeRangeKind -> CodeRangeKind -> Bool
$c/= :: CodeRangeKind -> CodeRangeKind -> Bool
/= :: CodeRangeKind -> CodeRangeKind -> Bool
Eq, (forall x. CodeRangeKind -> Rep CodeRangeKind x)
-> (forall x. Rep CodeRangeKind x -> CodeRangeKind)
-> Generic CodeRangeKind
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
$cfrom :: forall x. CodeRangeKind -> Rep CodeRangeKind x
from :: forall x. CodeRangeKind -> Rep CodeRangeKind x
$cto :: forall x. Rep CodeRangeKind x -> CodeRangeKind
to :: forall x. Rep CodeRangeKind x -> CodeRangeKind
Generic, CodeRangeKind -> ()
(CodeRangeKind -> ()) -> NFData CodeRangeKind
forall a. (a -> ()) -> NFData a
$crnf :: CodeRangeKind -> ()
rnf :: CodeRangeKind -> ()
NFData)

Lens.makeLenses ''CodeRange

instance Eq CodeRange where
    == :: CodeRange -> CodeRange -> Bool
(==) = Range -> Range -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Range -> Range -> Bool)
-> (CodeRange -> Range) -> CodeRange -> CodeRange -> 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 = Range -> Range -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Range -> Range -> Ordering)
-> (CodeRange -> Range) -> CodeRange -> CodeRange -> Ordering
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' = Reader (PreProcessEnv a) (HieAST a) -> PreProcessEnv a -> HieAST a
forall r a. Reader r a -> r -> a
runReader (HieAST a -> Reader (PreProcessEnv a) (HieAST a)
forall a. HieAST a -> Reader (PreProcessEnv a) (HieAST a)
preProcessAST HieAST a
ast) (RefMap a -> PreProcessEnv a
forall a. RefMap a -> PreProcessEnv a
PreProcessEnv RefMap a
refMap)
    CodeRange
codeRange <- HieAST a -> Writer [Log] CodeRange
forall a. HieAST a -> Writer [Log] CodeRange
astToCodeRange HieAST a
ast'
    CodeRange -> Writer [Log] CodeRange
forall a. a -> WriterT [Log] Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CodeRange -> Writer [Log] CodeRange)
-> CodeRange -> Writer [Log] CodeRange
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 []) = CodeRange -> Writer [Log] CodeRange
forall a. a -> WriterT [Log] Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CodeRange -> Writer [Log] CodeRange)
-> CodeRange -> Writer [Log] CodeRange
forall a b. (a -> b) -> a -> b
$ Range -> Vector CodeRange -> CodeRangeKind -> CodeRange
CodeRange (Span -> Range
realSrcSpanToRange Span
sp) Vector CodeRange
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] -> Writer [Log] [CodeRange]
removeInterleaving ([CodeRange] -> Writer [Log] [CodeRange])
-> ([CodeRange] -> [CodeRange])
-> [CodeRange]
-> Writer [Log] [CodeRange]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CodeRange] -> [CodeRange]
forall a. Ord a => [a] -> [a]
sort ([CodeRange] -> Writer [Log] [CodeRange])
-> Writer [Log] [CodeRange] -> Writer [Log] [CodeRange]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (HieAST a -> Writer [Log] CodeRange)
-> [HieAST a] -> Writer [Log] [CodeRange]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse HieAST a -> Writer [Log] CodeRange
forall a. HieAST a -> Writer [Log] CodeRange
astToCodeRange [HieAST a]
children
    let codeKind :: CodeRangeKind
codeKind = if CustomNodeType -> Maybe CustomNodeType
forall a. a -> Maybe a
Just CustomNodeType
CustomNodeImportsGroup Maybe CustomNodeType -> Maybe CustomNodeType -> Bool
forall a. Eq a => a -> a -> Bool
== HieAST a -> Maybe CustomNodeType
forall a. HieAST a -> Maybe CustomNodeType
isCustomNode HieAST a
node then CodeRangeKind
CodeKindImports else CodeRangeKind
CodeKindRegion
    CodeRange -> Writer [Log] CodeRange
forall a. a -> WriterT [Log] Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CodeRange -> Writer [Log] CodeRange)
-> CodeRange -> Writer [Log] CodeRange
forall a b. (a -> b) -> a -> b
$ Range -> Vector CodeRange -> CodeRangeKind -> CodeRange
CodeRange (Span -> Range
realSrcSpanToRange Span
sp) ([CodeRange] -> Vector CodeRange
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] -> Writer [Log] [CodeRange]
removeInterleaving = ([CodeRange] -> [CodeRange])
-> Writer [Log] [CodeRange] -> Writer [Log] [CodeRange]
forall a b.
(a -> b) -> WriterT [Log] Identity a -> WriterT [Log] Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [CodeRange] -> [CodeRange]
forall a. [a] -> [a]
reverse (Writer [Log] [CodeRange] -> Writer [Log] [CodeRange])
-> ([CodeRange] -> Writer [Log] [CodeRange])
-> [CodeRange]
-> Writer [Log] [CodeRange]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([CodeRange] -> CodeRange -> Writer [Log] [CodeRange])
-> [CodeRange] -> [CodeRange] -> Writer [Log] [CodeRange]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM [CodeRange] -> CodeRange -> Writer [Log] [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 -> Writer [Log] [CodeRange]
go [] CodeRange
x = [CodeRange] -> Writer [Log] [CodeRange]
forall a. a -> WriterT [Log] Identity a
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 CodeRange -> Getting Position CodeRange Position -> Position
forall s a. s -> Getting a s a -> a
Lens.^. (Range -> Const Position Range)
-> CodeRange -> Const Position CodeRange
Lens' CodeRange Range
codeRange_range ((Range -> Const Position Range)
 -> CodeRange -> Const Position CodeRange)
-> ((Position -> Const Position Position)
    -> Range -> Const Position Range)
-> Getting Position CodeRange Position
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position -> Const Position Position)
-> Range -> Const Position Range
forall s a. HasEnd s a => Lens' s a
Lens' Range Position
end Position -> Position -> Bool
forall a. Ord a => a -> a -> Bool
> CodeRange
x2 CodeRange -> Getting Position CodeRange Position -> Position
forall s a. s -> Getting a s a -> a
Lens.^. (Range -> Const Position Range)
-> CodeRange -> Const Position CodeRange
Lens' CodeRange Range
codeRange_range ((Range -> Const Position Range)
 -> CodeRange -> Const Position CodeRange)
-> ((Position -> Const Position Position)
    -> Range -> Const Position Range)
-> Getting Position CodeRange Position
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position -> Const Position Position)
-> Range -> Const Position Range
forall s a. HasStart s a => Lens' s a
Lens' Range Position
start
            then do
                -- set x1.end to x2.start
                let CodeRange
x1' :: CodeRange = CodeRange
x1 CodeRange -> (CodeRange -> CodeRange) -> CodeRange
forall a b. a -> (a -> b) -> b
& (Range -> Identity Range) -> CodeRange -> Identity CodeRange
Lens' CodeRange Range
codeRange_range ((Range -> Identity Range) -> CodeRange -> Identity CodeRange)
-> ((Position -> Identity Position) -> Range -> Identity Range)
-> (Position -> Identity Position)
-> CodeRange
-> Identity CodeRange
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position -> Identity Position) -> Range -> Identity Range
forall s a. HasEnd s a => Lens' s a
Lens' Range Position
end ((Position -> Identity Position)
 -> CodeRange -> Identity CodeRange)
-> Position -> CodeRange -> CodeRange
forall s t a b. ASetter s t a b -> b -> s -> t
Lens..~ (CodeRange
x2 CodeRange -> Getting Position CodeRange Position -> Position
forall s a. s -> Getting a s a -> a
Lens.^. (Range -> Const Position Range)
-> CodeRange -> Const Position CodeRange
Lens' CodeRange Range
codeRange_range ((Range -> Const Position Range)
 -> CodeRange -> Const Position CodeRange)
-> ((Position -> Const Position Position)
    -> Range -> Const Position Range)
-> Getting Position CodeRange Position
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position -> Const Position Position)
-> Range -> Const Position Range
forall s a. HasStart s a => Lens' s a
Lens' Range Position
start)
                [Log] -> WriterT [Log] Identity ()
forall w (m :: * -> *). (Monoid w, Monad m) => w -> WriterT w m ()
tell [CodeRange -> CodeRange -> Log
LogFoundInterleaving CodeRange
x1 CodeRange
x2]
                CodeRange -> Writer [Log] CodeRange
forall a. a -> WriterT [Log] Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CodeRange
x1'
            else CodeRange -> Writer [Log] CodeRange
forall a. a -> WriterT [Log] Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CodeRange
x1
        [CodeRange] -> Writer [Log] [CodeRange]
forall a. a -> WriterT [Log] Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([CodeRange] -> Writer [Log] [CodeRange])
-> [CodeRange] -> Writer [Log] [CodeRange]
forall a b. (a -> b) -> a -> b
$ CodeRange
x2CodeRange -> [CodeRange] -> [CodeRange]
forall a. a -> [a] -> [a]
:CodeRange
x1'CodeRange -> [CodeRange] -> [CodeRange]
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' Range -> Range -> Bool
forall a. Eq a => a -> a -> Bool
== Range
curRange
            then CodeRange -> CodeRange
simplify (CodeRange
r { _codeRange_children = _codeRange_children 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 Vector CodeRange -> Int
forall a. Vector a -> Int
V.length Vector CodeRange
children Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then Vector CodeRange -> Maybe CodeRange
forall (m :: * -> *) a. Monad m => Vector a -> m a
V.headM Vector CodeRange
children else Maybe CodeRange
forall a. Maybe a
Nothing

    withChildrenSimplified :: CodeRange
withChildrenSimplified = CodeRange
r { _codeRange_children = simplify <$> _codeRange_children r }

data GetCodeRange = GetCodeRange
    deriving (GetCodeRange -> GetCodeRange -> Bool
(GetCodeRange -> GetCodeRange -> Bool)
-> (GetCodeRange -> GetCodeRange -> Bool) -> Eq GetCodeRange
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GetCodeRange -> GetCodeRange -> Bool
== :: GetCodeRange -> GetCodeRange -> Bool
$c/= :: GetCodeRange -> GetCodeRange -> Bool
/= :: GetCodeRange -> GetCodeRange -> Bool
Eq, Int -> GetCodeRange -> ShowS
[GetCodeRange] -> ShowS
GetCodeRange -> String
(Int -> GetCodeRange -> ShowS)
-> (GetCodeRange -> String)
-> ([GetCodeRange] -> ShowS)
-> Show GetCodeRange
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GetCodeRange -> ShowS
showsPrec :: Int -> GetCodeRange -> ShowS
$cshow :: GetCodeRange -> String
show :: GetCodeRange -> String
$cshowList :: [GetCodeRange] -> ShowS
showList :: [GetCodeRange] -> ShowS
Show, Typeable, (forall x. GetCodeRange -> Rep GetCodeRange x)
-> (forall x. Rep GetCodeRange x -> GetCodeRange)
-> Generic GetCodeRange
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
$cfrom :: forall x. GetCodeRange -> Rep GetCodeRange x
from :: forall x. GetCodeRange -> Rep GetCodeRange x
$cto :: forall x. Rep GetCodeRange x -> GetCodeRange
to :: forall x. Rep GetCodeRange x -> GetCodeRange
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 =
    Recorder (WithPriority Log)
-> (GetCodeRange
    -> NormalizedFilePath -> Action (IdeResult CodeRange))
-> Rules ()
forall k v.
IdeRule k v =>
Recorder (WithPriority Log)
-> (k -> NormalizedFilePath -> Action (IdeResult v)) -> Rules ()
define ((Log -> Log)
-> Recorder (WithPriority Log) -> Recorder (WithPriority Log)
forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogShake Recorder (WithPriority Log)
recorder) ((GetCodeRange
  -> NormalizedFilePath -> Action (IdeResult CodeRange))
 -> Rules ())
-> (GetCodeRange
    -> NormalizedFilePath -> Action (IdeResult CodeRange))
-> Rules ()
forall a b. (a -> b) -> a -> b
$ \GetCodeRange
GetCodeRange NormalizedFilePath
file -> Recorder (WithPriority Log)
-> ExceptT Log Action CodeRange -> Action (IdeResult CodeRange)
forall msg a.
Recorder (WithPriority msg)
-> ExceptT msg Action a -> Action (IdeResult a)
handleError Recorder (WithPriority Log)
recorder (ExceptT Log Action CodeRange -> Action (IdeResult CodeRange))
-> ExceptT Log Action CodeRange -> Action (IdeResult CodeRange)
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 :: HieASTs a
hieAst :: ()
hieAst, RefMap a
refMap :: RefMap a
refMap :: ()
refMap} <- Action HieAstResult -> ExceptT Log Action HieAstResult
forall (m :: * -> *) a. Monad m => m a -> ExceptT Log m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Action HieAstResult -> ExceptT Log Action HieAstResult)
-> Action HieAstResult -> ExceptT Log Action HieAstResult
forall a b. (a -> b) -> a -> b
$ GetHieAst -> NormalizedFilePath -> Action HieAstResult
forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ GetHieAst
GetHieAst NormalizedFilePath
file
        HieAST a
ast <- Log -> MaybeT Action (HieAST a) -> ExceptT Log Action (HieAST a)
forall (m :: * -> *) e a.
Functor m =>
e -> MaybeT m a -> ExceptT e m a
maybeToExceptT Log
LogNoAST (MaybeT Action (HieAST a) -> ExceptT Log Action (HieAST a))
-> (Maybe (HieAST a) -> MaybeT Action (HieAST a))
-> Maybe (HieAST a)
-> ExceptT Log Action (HieAST a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Action (Maybe (HieAST a)) -> MaybeT Action (HieAST a)
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (Action (Maybe (HieAST a)) -> MaybeT Action (HieAST a))
-> (Maybe (HieAST a) -> Action (Maybe (HieAST a)))
-> Maybe (HieAST a)
-> MaybeT Action (HieAST a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (HieAST a) -> Action (Maybe (HieAST a))
forall a. a -> Action a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (HieAST a) -> ExceptT Log Action (HieAST a))
-> Maybe (HieAST a) -> ExceptT Log Action (HieAST a)
forall a b. (a -> b) -> a -> b
$
            HieASTs a -> Map HiePath (HieAST a)
forall a. HieASTs a -> Map HiePath (HieAST a)
getAsts HieASTs a
hieAst Map HiePath (HieAST a) -> HiePath -> Maybe (HieAST a)
forall k a. Ord k => Map k a -> k -> Maybe a
Map.!? (FastString -> HiePath
forall a b. Coercible a b => a -> b
coerce (FastString -> HiePath)
-> (NormalizedFilePath -> FastString)
-> NormalizedFilePath
-> HiePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> FastString
mkFastString (String -> FastString)
-> (NormalizedFilePath -> String)
-> NormalizedFilePath
-> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NormalizedFilePath -> String
fromNormalizedFilePath) NormalizedFilePath
file
        let (CodeRange
codeRange, [Log]
warnings) = Writer [Log] CodeRange -> (CodeRange, [Log])
forall w a. Monoid w => Writer w a -> (a, w)
runWriter (HieAST a -> RefMap a -> Writer [Log] CodeRange
forall a. HieAST a -> RefMap a -> Writer [Log] CodeRange
buildCodeRange HieAST a
ast RefMap a
refMap)
        (Log -> ExceptT Log Action ()) -> [Log] -> ExceptT Log Action ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Recorder (WithPriority Log)
-> Priority -> Log -> ExceptT Log Action ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Warning) [Log]
warnings

        CodeRange -> ExceptT Log Action CodeRange
forall a. a -> ExceptT Log Action a
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 <- ExceptT msg Action a -> Action (Either msg a)
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
            Recorder (WithPriority msg) -> Priority -> msg -> Action ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority msg)
recorder Priority
Warning msg
msg
            IdeResult a -> Action (IdeResult a)
forall a. a -> Action a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IdeResult a -> Action (IdeResult a))
-> IdeResult a -> Action (IdeResult a)
forall a b. (a -> b) -> a -> b
$ Either [FileDiagnostic] a -> IdeResult a
forall v. Either [FileDiagnostic] v -> IdeResult v
toIdeResult ([FileDiagnostic] -> Either [FileDiagnostic] a
forall a b. a -> Either a b
Left [])
        Right a
value -> IdeResult a -> Action (IdeResult a)
forall a. a -> Action a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IdeResult a -> Action (IdeResult a))
-> IdeResult a -> Action (IdeResult a)
forall a b. (a -> b) -> a -> b
$ Either [FileDiagnostic] a -> IdeResult a
forall v. Either [FileDiagnostic] v -> IdeResult v
toIdeResult (a -> Either [FileDiagnostic] a
forall a b. b -> Either a b
Right a
value)

-- | Maps type CodeRangeKind to FoldingRangeKind
crkToFrk :: CodeRangeKind -> FoldingRangeKind
crkToFrk :: CodeRangeKind -> FoldingRangeKind
crkToFrk CodeRangeKind
crk = case CodeRangeKind
crk of
        CodeRangeKind
CodeKindComment -> FoldingRangeKind
FoldingRangeKind_Comment
        CodeRangeKind
CodeKindImports -> FoldingRangeKind
FoldingRangeKind_Imports
        CodeRangeKind
CodeKindRegion  -> FoldingRangeKind
FoldingRangeKind_Region