{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StrictData #-}
module Tokstyle.Cimple.Analysis.DocComments (analyse) where
import qualified Control.Monad.State.Lazy as State
import Data.Text (Text)
import qualified Data.Text as Text
import Language.Cimple (AlexPosn (..), AstActions,
Lexeme (..), LexemeClass (..),
Node (..), defaultActions, doNode,
traverseAst)
import Language.Cimple.Diagnostics (HasDiagnostics (..), warn)
import qualified Language.Cimple.Diagnostics as Diagnostics
import Language.Cimple.Pretty (ppTranslationUnit)
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 Linter
linter :: AstActions Linter
linter = AstActions Linter
forall a. IdentityActions (State a) () Text
defaultActions
{ doNode :: FilePath
-> Node () (Lexeme Text)
-> State Linter (Node () (Lexeme Text))
-> State Linter (Node () (Lexeme Text))
doNode = \FilePath
file Node () (Lexeme Text)
node State Linter (Node () (Lexeme Text))
act ->
case Node () (Lexeme Text)
node of
Commented Node () (Lexeme Text)
doc (FunctionDecl Scope
_ (FunctionPrototype Node () (Lexeme Text)
_ (L AlexPosn
_ LexemeClass
IdVar Text
fname) [Node () (Lexeme Text)]
_) Maybe (Node () (Lexeme Text))
_) -> do
FilePath
-> Node () (Lexeme Text) -> Text -> StateT Linter Identity ()
checkCommentEquals FilePath
file Node () (Lexeme Text)
doc Text
fname
State Linter (Node () (Lexeme Text))
act
Commented Node () (Lexeme Text)
doc (FunctionDefn Scope
_ (FunctionPrototype Node () (Lexeme Text)
_ (L AlexPosn
_ LexemeClass
IdVar Text
fname) [Node () (Lexeme Text)]
_) [Node () (Lexeme Text)]
_) -> do
FilePath
-> Node () (Lexeme Text) -> Text -> StateT Linter Identity ()
checkCommentEquals FilePath
file Node () (Lexeme Text)
doc Text
fname
State Linter (Node () (Lexeme Text))
act
Node () (Lexeme Text)
_ -> State Linter (Node () (Lexeme Text))
act
}
where
tshow :: Doc -> Text
tshow = FilePath -> Text
Text.pack (FilePath -> Text) -> (Doc -> FilePath) -> Doc -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> FilePath
forall a. Show a => a -> FilePath
show
removeSloc :: Node a (Lexeme text) -> Node a (Lexeme text)
removeSloc :: Node a (Lexeme text) -> Node a (Lexeme text)
removeSloc = (Lexeme text -> Lexeme text)
-> Node a (Lexeme text) -> Node a (Lexeme text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Lexeme text -> Lexeme text)
-> Node a (Lexeme text) -> Node a (Lexeme text))
-> (Lexeme text -> Lexeme text)
-> Node a (Lexeme text)
-> Node a (Lexeme text)
forall a b. (a -> b) -> a -> b
$ \(L AlexPosn
_ LexemeClass
c text
t) -> AlexPosn -> LexemeClass -> text -> Lexeme text
forall text. AlexPosn -> LexemeClass -> text -> Lexeme text
L (Int -> Int -> Int -> AlexPosn
AlexPn Int
0 Int
0 Int
0) LexemeClass
c text
t
checkCommentEquals :: FilePath
-> Node () (Lexeme Text) -> Text -> StateT Linter Identity ()
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 -> StateT Linter Identity ()
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)
forall a text. Node a (Lexeme text) -> Node a (Lexeme text)
removeSloc Node () (Lexeme Text)
doc Node () (Lexeme Text) -> Node () (Lexeme Text) -> Bool
forall a. Eq a => a -> a -> Bool
== Node () (Lexeme Text) -> Node () (Lexeme Text)
forall a text. Node a (Lexeme text) -> Node a (Lexeme text)
removeSloc Node () (Lexeme Text)
doc' -> () -> StateT Linter Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just (FilePath
file', Node () (Lexeme Text)
doc') -> do
FilePath -> Lexeme Text -> Text -> StateT Linter Identity ()
forall diags.
HasDiagnostics diags =>
FilePath -> Lexeme Text -> Text -> DiagnosticsT diags ()
warn FilePath
file (Node () (Lexeme Text) -> Lexeme Text
forall a. Node a (Lexeme Text) -> Lexeme Text
Diagnostics.at Node () (Lexeme Text)
doc) (Text -> StateT Linter Identity ())
-> Text -> StateT Linter Identity ()
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 -> Text
tshow ([Node () (Lexeme Text)] -> Doc
forall a. Show a => [Node a (Lexeme Text)] -> Doc
ppTranslationUnit [Node () (Lexeme Text)
doc])
FilePath -> Lexeme Text -> Text -> StateT Linter Identity ()
forall diags.
HasDiagnostics diags =>
FilePath -> Lexeme Text -> Text -> DiagnosticsT diags ()
warn FilePath
file' (Node () (Lexeme Text) -> Lexeme Text
forall a. Node a (Lexeme Text) -> Lexeme Text
Diagnostics.at Node () (Lexeme Text)
doc') (Text -> StateT Linter Identity ())
-> Text -> StateT Linter Identity ()
forall a b. (a -> b) -> a -> b
$ Text
"mismatching comment found here:\n"
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Doc -> Text
tshow ([Node () (Lexeme Text)] -> Doc
forall a. Show a => [Node a (Lexeme Text)] -> Doc
ppTranslationUnit [Node () (Lexeme Text)
doc'])
analyse :: [(FilePath, [Node () (Lexeme Text)])] -> [Text]
analyse :: [(FilePath, [Node () (Lexeme Text)])] -> [Text]
analyse = [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 [(FilePath, [Node () (Lexeme Text)])]
-> Linter -> Linter)
-> Linter
-> State Linter [(FilePath, [Node () (Lexeme Text)])]
-> Linter
forall a b c. (a -> b -> c) -> b -> a -> c
flip State Linter [(FilePath, [Node () (Lexeme Text)])]
-> Linter -> Linter
forall s a. State s a -> s -> s
State.execState Linter
empty (State Linter [(FilePath, [Node () (Lexeme Text)])] -> Linter)
-> ([(FilePath, [Node () (Lexeme Text)])]
-> State Linter [(FilePath, [Node () (Lexeme Text)])])
-> [(FilePath, [Node () (Lexeme Text)])]
-> Linter
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AstActions Linter
-> [(FilePath, [Node () (Lexeme Text)])]
-> State Linter [(FilePath, [Node () (Lexeme Text)])]
forall iattr oattr itext otext a (f :: * -> *).
(TraverseAst iattr oattr itext otext a a, Applicative f) =>
AstActions f iattr oattr itext otext -> a -> f a
traverseAst AstActions Linter
linter ([(FilePath, [Node () (Lexeme Text)])]
-> State Linter [(FilePath, [Node () (Lexeme Text)])])
-> ([(FilePath, [Node () (Lexeme Text)])]
-> [(FilePath, [Node () (Lexeme Text)])])
-> [(FilePath, [Node () (Lexeme Text)])]
-> State Linter [(FilePath, [Node () (Lexeme Text)])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(FilePath, [Node () (Lexeme Text)])]
-> [(FilePath, [Node () (Lexeme Text)])]
forall a. [a] -> [a]
reverse