{-# 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

            {-
            Commented _ n -> do
                warn file node . Text.pack . show $ n
                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