{-# 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 (HasDiagnostics (..), warn)
import           Language.Cimple.Pretty      (ppTranslationUnit, render)
import           Language.Cimple.TraverseAst (AstActions, astActions, doNode,
                                              traverseAst)
import           Tokstyle.Common             (functionName, semEq)


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

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

instance HasDiagnostics Linter where
    addDiagnostic :: Text -> Linter -> Linter
addDiagnostic Text
diag l :: Linter
l@Linter{[Text]
diags :: [Text]
diags :: Linter -> [Text]
diags} = Linter
l{diags :: [Text]
diags = Text -> [Text] -> [Text]
forall a. HasDiagnostics a => Text -> a -> a
addDiagnostic Text
diag [Text]
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) -> Text -> State Linter ()
checkCommentEquals FilePath
file 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) -> Text -> State Linter ()
checkCommentEquals FilePath
file 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)
doc))(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)
doc') | Node (Lexeme Text) -> Node (Lexeme Text) -> Bool
semEq Node (Lexeme Text)
doc Node (Lexeme Text)
doc' -> () -> State Linter ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Just (FilePath
file', Node (Lexeme Text)
doc') -> do
                FilePath -> Node (Lexeme Text) -> Text -> State Linter ()
forall at diags.
(HasLocation at, HasDiagnostics diags) =>
FilePath -> at -> Text -> DiagnosticsT diags ()
warn FilePath
file Node (Lexeme Text)
doc (Text -> State Linter ()) -> Text -> State Linter ()
forall a b. (a -> b) -> a -> b
$ Text
"comment on definition of `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fname
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"` does not match declaration:\n"
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle -> Text
render ([Node (Lexeme Text)] -> Doc AnsiStyle
ppTranslationUnit [Node (Lexeme Text)
doc])
                FilePath -> Node (Lexeme Text) -> Text -> State Linter ()
forall at diags.
(HasLocation at, HasDiagnostics diags) =>
FilePath -> at -> Text -> DiagnosticsT diags ()
warn FilePath
file' Node (Lexeme Text)
doc' (Text -> State Linter ()) -> Text -> State Linter ()
forall a b. (a -> b) -> a -> b
$ Text
"mismatching comment found here:\n"
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle -> Text
render ([Node (Lexeme Text)] -> Doc AnsiStyle
ppTranslationUnit [Node (Lexeme Text)
doc'])

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)])] -> [Text]
analyse :: [(FilePath, [Node (Lexeme Text)])] -> [Text]
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 [Text] -> [Text]
forall a. [a] -> [a]
reverse ([Text] -> [Text])
-> ([(FilePath, [Node (Lexeme Text)])] -> [Text])
-> [(FilePath, [Node (Lexeme Text)])]
-> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Linter -> [Text]
diags (Linter -> [Text])
-> ([(FilePath, [Node (Lexeme Text)])] -> Linter)
-> [(FilePath, [Node (Lexeme Text)])]
-> [Text]
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)])] -> [Text])
-> [(FilePath, [Node (Lexeme Text)])] -> [Text]
forall a b. (a -> b) -> a -> b
$ [(FilePath, [Node (Lexeme Text)])]
processedFiles

descr :: ([(FilePath, [Node (Lexeme Text)])] -> [Text], (Text, Text))
descr :: ([(FilePath, [Node (Lexeme Text)])] -> [Text], (Text, Text))
descr = ([(FilePath, [Node (Lexeme Text)])] -> [Text]
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."
    ]))