{-# 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 :: Linter -> [Diagnostic CimplePos]
diags :: [Diagnostic CimplePos]
diags} = Linter
l{diags = diag : diags}


linter :: AstActions (State Linter) Text
linter :: AstActions (StateT Linter Identity) Text
linter = AstActions (StateT Linter Identity) Text
forall (f :: * -> *) text. Applicative f => AstActions f text
astActions
    { doNode = \FilePath
file Node (Lexeme Text)
node StateT Linter Identity ()
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 -> StateT Linter Identity ()) -> StateT Linter Identity ()
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 -> StateT Linter Identity ()) -> StateT Linter Identity ())
-> (Text -> StateT Linter Identity ()) -> StateT Linter Identity ()
forall a b. (a -> b) -> a -> b
$
                    FilePath
-> Node (Lexeme Text)
-> Node (Lexeme Text)
-> Text
-> StateT Linter Identity ()
checkCommentEquals FilePath
file Node (Lexeme Text)
node Node (Lexeme Text)
doc
                StateT Linter Identity ()
act

            FunctionDefn{} -> () -> StateT Linter Identity ()
forall a. a -> StateT Linter Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            NodeF (Lexeme Text) (Node (Lexeme Text))
_ -> StateT Linter Identity ()
act
    }
  where
    checkCommentEquals :: FilePath
-> Node (Lexeme Text)
-> Node (Lexeme Text)
-> Text
-> StateT Linter Identity ()
checkCommentEquals FilePath
file Node (Lexeme Text)
node Node (Lexeme Text)
doc Text
fname = do
        l :: Linter
l@Linter{[(Text, (FilePath, Node (Lexeme Text)))]
docs :: Linter -> [(Text, (FilePath, Node (Lexeme Text)))]
docs :: [(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 -> StateT Linter Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
State.put Linter
l{docs = (fname, (file, node)):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') -> () -> StateT Linter Identity ()
forall a. a -> StateT Linter Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Just (FilePath
file', Node (Lexeme Text)
node') -> do
                FilePath
-> Node (Lexeme Text) -> Doc AnsiStyle -> StateT Linter Identity ()
forall diags at.
(HasDiagnosticsRich diags CimplePos,
 HasDiagnosticInfo at CimplePos) =>
FilePath -> at -> Doc AnsiStyle -> DiagnosticsT diags ()
warnDoc FilePath
file Node (Lexeme Text)
node (Doc AnsiStyle -> StateT Linter Identity ())
-> Doc AnsiStyle -> StateT Linter Identity ()
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 ann. Text -> Doc ann
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 -> StateT Linter Identity ()
forall diags at.
(HasDiagnosticsRich diags CimplePos,
 HasDiagnosticInfo at CimplePos) =>
FilePath -> at -> Doc AnsiStyle -> DiagnosticsT diags ()
warnDoc FilePath
file' Node (Lexeme Text)
node' (Doc AnsiStyle -> StateT Linter Identity ())
-> Doc AnsiStyle -> StateT Linter Identity ()
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 a b. (a -> b) -> (FilePath, a) -> (FilePath, b)
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
. (StateT Linter Identity () -> Linter -> Linter)
-> Linter -> StateT Linter Identity () -> Linter
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT Linter Identity () -> Linter -> Linter
forall s a. State s a -> s -> s
State.execState Linter
empty (StateT Linter Identity () -> Linter)
-> ([(FilePath, [Node (Lexeme Text)])]
    -> StateT Linter Identity ())
-> [(FilePath, [Node (Lexeme Text)])]
-> Linter
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AstActions (StateT Linter Identity) Text
-> [(FilePath, [Node (Lexeme Text)])] -> StateT Linter Identity ()
forall text a (f :: * -> *).
(TraverseAst text a, Applicative f) =>
AstActions f text -> a -> f ()
traverseAst AstActions (StateT Linter Identity) Text
linter ([(FilePath, [Node (Lexeme Text)])] -> StateT Linter Identity ())
-> ([(FilePath, [Node (Lexeme Text)])]
    -> [(FilePath, [Node (Lexeme Text)])])
-> [(FilePath, [Node (Lexeme Text)])]
-> StateT Linter Identity ()
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."
    ]))