{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns        #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE Strict                #-}
module Tokstyle.Linter.DocComments (descr) where

import           Control.Monad               (forM_)
import           Control.Monad.State.Strict  (State)
import qualified Control.Monad.State.Strict  as State
import           Data.Fix                    (Fix (..))
import           Data.Text                   (Text)
import qualified Data.Text                   as Text
import           Language.Cimple             (CommentStyle (..), Lexeme (..),
                                              Node, NodeF (..))
import           Language.Cimple.Diagnostics (CimplePos, Diagnostic,
                                              HasDiagnosticsRich (..))
import           Language.Cimple.Pretty      (ppTranslationUnit)
import           Language.Cimple.TraverseAst (AstActions, astActions, doNode,
                                              traverseAst)
import           Prettyprinter               (line, pretty)
import           Tokstyle.Common             (functionName, semEq, warnDoc)


data Linter = Linter
    { Linter -> [Diagnostic CimplePos]
diags :: [Diagnostic CimplePos]
    , Linter -> [(Text, (FilePath, Node (Lexeme Text)))]
docs  :: [(Text, (FilePath, Node (Lexeme Text)))]
    }

empty :: Linter
empty :: Linter
empty = [Diagnostic CimplePos]
-> [(Text, (FilePath, Node (Lexeme Text)))] -> Linter
Linter [] []

instance HasDiagnosticsRich Linter CimplePos where
    addDiagnosticRich :: Diagnostic CimplePos -> Linter -> Linter
addDiagnosticRich Diagnostic CimplePos
diag l :: Linter
l@Linter{[Diagnostic CimplePos]
diags :: [Diagnostic CimplePos]
diags :: Linter -> [Diagnostic CimplePos]
diags} = Linter
l{diags :: [Diagnostic CimplePos]
diags = Diagnostic CimplePos
diag Diagnostic CimplePos
-> [Diagnostic CimplePos] -> [Diagnostic CimplePos]
forall a. a -> [a] -> [a]
: [Diagnostic CimplePos]
diags}


linter :: AstActions (State Linter) Text
linter :: AstActions (State Linter) Text
linter = AstActions (State Linter) Text
forall (f :: * -> *) text. Applicative f => AstActions f text
astActions
    { doNode :: FilePath
-> Node (Lexeme Text) -> State Linter () -> State Linter ()
doNode = \FilePath
file Node (Lexeme Text)
node State Linter ()
act ->
        case Node (Lexeme Text) -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node (Lexeme Text)
node of
            Commented Node (Lexeme Text)
doc Node (Lexeme Text)
entity -> do
                Maybe Text -> (Text -> State Linter ()) -> State Linter ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Node (Lexeme Text) -> Maybe Text
forall a. Show a => Node (Lexeme a) -> Maybe a
functionName Node (Lexeme Text)
entity) ((Text -> State Linter ()) -> State Linter ())
-> (Text -> State Linter ()) -> State Linter ()
forall a b. (a -> b) -> a -> b
$
                    FilePath
-> Node (Lexeme Text)
-> Node (Lexeme Text)
-> Text
-> State Linter ()
checkCommentEquals FilePath
file Node (Lexeme Text)
node Node (Lexeme Text)
doc
                State Linter ()
act

            FunctionDefn{} -> () -> State Linter ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            NodeF (Lexeme Text) (Node (Lexeme Text))
_ -> State Linter ()
act
    }
  where
    checkCommentEquals :: FilePath
-> Node (Lexeme Text)
-> Node (Lexeme Text)
-> Text
-> State Linter ()
checkCommentEquals FilePath
file Node (Lexeme Text)
node Node (Lexeme Text)
doc Text
fname = do
        l :: Linter
l@Linter{[(Text, (FilePath, Node (Lexeme Text)))]
docs :: [(Text, (FilePath, Node (Lexeme Text)))]
docs :: Linter -> [(Text, (FilePath, Node (Lexeme Text)))]
docs} <- StateT Linter Identity Linter
forall s (m :: * -> *). MonadState s m => m s
State.get
        case Text
-> [(Text, (FilePath, Node (Lexeme Text)))]
-> Maybe (FilePath, Node (Lexeme Text))
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
fname [(Text, (FilePath, Node (Lexeme Text)))]
docs of
            Maybe (FilePath, Node (Lexeme Text))
Nothing -> Linter -> State Linter ()
forall s (m :: * -> *). MonadState s m => s -> m ()
State.put Linter
l{docs :: [(Text, (FilePath, Node (Lexeme Text)))]
docs = (Text
fname, (FilePath
file, Node (Lexeme Text)
node))(Text, (FilePath, Node (Lexeme Text)))
-> [(Text, (FilePath, Node (Lexeme Text)))]
-> [(Text, (FilePath, Node (Lexeme Text)))]
forall a. a -> [a] -> [a]
:[(Text, (FilePath, Node (Lexeme Text)))]
docs}
            Just (FilePath
_, Node (Lexeme Text)
node') | Node (Lexeme Text) -> Node (Lexeme Text) -> Bool
semEq Node (Lexeme Text)
doc (Node (Lexeme Text) -> Node (Lexeme Text)
forall lexeme. Fix (NodeF lexeme) -> Fix (NodeF lexeme)
getDoc Node (Lexeme Text)
node') -> () -> State Linter ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Just (FilePath
file', Node (Lexeme Text)
node') -> do
                FilePath -> Node (Lexeme Text) -> Doc AnsiStyle -> State Linter ()
forall diags at.
(HasDiagnosticsRich diags CimplePos,
 HasDiagnosticInfo at CimplePos) =>
FilePath -> at -> Doc AnsiStyle -> DiagnosticsT diags ()
warnDoc FilePath
file Node (Lexeme Text)
node (Doc AnsiStyle -> State Linter ())
-> Doc AnsiStyle -> State Linter ()
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle
"comment on definition of `" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Text -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty Text
fname
                    Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
"` does not match declaration:" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
forall ann. Doc ann
line
                    Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> [Node (Lexeme Text)] -> Doc AnsiStyle
forall a. Pretty a => [Node (Lexeme a)] -> Doc AnsiStyle
ppTranslationUnit [Node (Lexeme Text)
node]
                FilePath -> Node (Lexeme Text) -> Doc AnsiStyle -> State Linter ()
forall diags at.
(HasDiagnosticsRich diags CimplePos,
 HasDiagnosticInfo at CimplePos) =>
FilePath -> at -> Doc AnsiStyle -> DiagnosticsT diags ()
warnDoc FilePath
file' Node (Lexeme Text)
node' (Doc AnsiStyle -> State Linter ())
-> Doc AnsiStyle -> State Linter ()
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle
"mismatching comment found here:" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
forall ann. Doc ann
line
                    Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> [Node (Lexeme Text)] -> Doc AnsiStyle
forall a. Pretty a => [Node (Lexeme a)] -> Doc AnsiStyle
ppTranslationUnit [Node (Lexeme Text)
node']

    getDoc :: Fix (NodeF lexeme) -> Fix (NodeF lexeme)
getDoc (Fix (Commented Fix (NodeF lexeme)
doc Fix (NodeF lexeme)
_)) = Fix (NodeF lexeme)
doc
    getDoc Fix (NodeF lexeme)
_                       = FilePath -> Fix (NodeF lexeme)
forall a. HasCallStack => FilePath -> a
error FilePath
"getDoc: not a Commented node"

associateComments :: [Node (Lexeme Text)] -> [Node (Lexeme Text)]
associateComments :: [Node (Lexeme Text)] -> [Node (Lexeme Text)]
associateComments [] = []
associateComments (doc :: Node (Lexeme Text)
doc@(Fix NodeF (Lexeme Text) (Node (Lexeme Text))
c) : Node (Lexeme Text)
nextNode : [Node (Lexeme Text)]
rest)
    | NodeF (Lexeme Text) (Node (Lexeme Text)) -> Bool
forall lexeme a. NodeF lexeme a -> Bool
isFunc (Node (Lexeme Text) -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node (Lexeme Text)
nextNode) Bool -> Bool -> Bool
&& NodeF (Lexeme Text) (Node (Lexeme Text)) -> Bool
forall lexeme a. NodeF lexeme a -> Bool
isDocComment NodeF (Lexeme Text) (Node (Lexeme Text))
c =
        NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Node (Lexeme Text)
-> Node (Lexeme Text) -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall lexeme a. a -> a -> NodeF lexeme a
Commented Node (Lexeme Text)
doc Node (Lexeme Text)
nextNode) Node (Lexeme Text) -> [Node (Lexeme Text)] -> [Node (Lexeme Text)]
forall a. a -> [a] -> [a]
: [Node (Lexeme Text)] -> [Node (Lexeme Text)]
associateComments [Node (Lexeme Text)]
rest
  where
    isFunc :: NodeF lexeme a -> Bool
isFunc FunctionDecl{} = Bool
True
    isFunc FunctionDefn{} = Bool
True
    isFunc NodeF lexeme a
_              = Bool
False
    isDocComment :: NodeF lexeme a -> Bool
isDocComment (Comment CommentStyle
Doxygen lexeme
_ [lexeme]
_ lexeme
_) = Bool
True
    isDocComment NodeF lexeme a
_                       = Bool
False
associateComments (Node (Lexeme Text)
x:[Node (Lexeme Text)]
xs) = Node (Lexeme Text)
x Node (Lexeme Text) -> [Node (Lexeme Text)] -> [Node (Lexeme Text)]
forall a. a -> [a] -> [a]
: [Node (Lexeme Text)] -> [Node (Lexeme Text)]
associateComments [Node (Lexeme Text)]
xs

analyse :: [(FilePath, [Node (Lexeme Text)])] -> [Diagnostic CimplePos]
analyse :: [(FilePath, [Node (Lexeme Text)])] -> [Diagnostic CimplePos]
analyse [(FilePath, [Node (Lexeme Text)])]
files =
    let processedFiles :: [(FilePath, [Node (Lexeme Text)])]
processedFiles = ((FilePath, [Node (Lexeme Text)])
 -> (FilePath, [Node (Lexeme Text)]))
-> [(FilePath, [Node (Lexeme Text)])]
-> [(FilePath, [Node (Lexeme Text)])]
forall a b. (a -> b) -> [a] -> [b]
map (([Node (Lexeme Text)] -> [Node (Lexeme Text)])
-> (FilePath, [Node (Lexeme Text)])
-> (FilePath, [Node (Lexeme Text)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Node (Lexeme Text)] -> [Node (Lexeme Text)]
associateComments) [(FilePath, [Node (Lexeme Text)])]
files
    in [Diagnostic CimplePos] -> [Diagnostic CimplePos]
forall a. [a] -> [a]
reverse ([Diagnostic CimplePos] -> [Diagnostic CimplePos])
-> ([(FilePath, [Node (Lexeme Text)])] -> [Diagnostic CimplePos])
-> [(FilePath, [Node (Lexeme Text)])]
-> [Diagnostic CimplePos]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Linter -> [Diagnostic CimplePos]
diags (Linter -> [Diagnostic CimplePos])
-> ([(FilePath, [Node (Lexeme Text)])] -> Linter)
-> [(FilePath, [Node (Lexeme Text)])]
-> [Diagnostic CimplePos]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (State Linter () -> Linter -> Linter)
-> Linter -> State Linter () -> Linter
forall a b c. (a -> b -> c) -> b -> a -> c
flip State Linter () -> Linter -> Linter
forall s a. State s a -> s -> s
State.execState Linter
empty (State Linter () -> Linter)
-> ([(FilePath, [Node (Lexeme Text)])] -> State Linter ())
-> [(FilePath, [Node (Lexeme Text)])]
-> Linter
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AstActions (State Linter) Text
-> [(FilePath, [Node (Lexeme Text)])] -> State Linter ()
forall text a (f :: * -> *).
(TraverseAst text a, Applicative f) =>
AstActions f text -> a -> f ()
traverseAst AstActions (State Linter) Text
linter ([(FilePath, [Node (Lexeme Text)])] -> State Linter ())
-> ([(FilePath, [Node (Lexeme Text)])]
    -> [(FilePath, [Node (Lexeme Text)])])
-> [(FilePath, [Node (Lexeme Text)])]
-> State Linter ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(FilePath, [Node (Lexeme Text)])]
-> [(FilePath, [Node (Lexeme Text)])]
forall a. [a] -> [a]
reverse ([(FilePath, [Node (Lexeme Text)])] -> [Diagnostic CimplePos])
-> [(FilePath, [Node (Lexeme Text)])] -> [Diagnostic CimplePos]
forall a b. (a -> b) -> a -> b
$ [(FilePath, [Node (Lexeme Text)])]
processedFiles

descr :: ([(FilePath, [Node (Lexeme Text)])] -> [Diagnostic CimplePos], (Text, Text))
descr :: ([(FilePath, [Node (Lexeme Text)])] -> [Diagnostic CimplePos],
 (Text, Text))
descr = ([(FilePath, [Node (Lexeme Text)])] -> [Diagnostic CimplePos]
analyse, (Text
"doc-comments", [Text] -> Text
Text.unlines
    [ Text
"Checks that doc comments on function definitions match the ones on their"
    , Text
"corresponding declarations."
    , Text
""
    , Text
"**Reason:** ideally, documentation should be only in one place, but if it is"
    , Text
"duplicated, it should not be different."
    ]))