{-# LANGUAGE OverloadedStrings #-}
module Tokstyle.C.Linter
    ( analyse
    , analyseText
    , allWarnings
    , markdown
    , renderIO
    , renderPure
    , LinterError
    , DiagnosticLevel(..)
    , Doc
    , AnsiStyle
    , diagToText
    ) where

import qualified Data.ByteString                      as BS
import           Data.List                            (sortBy)
import           Data.Map.Strict                      (Map)
import qualified Data.Map.Strict                      as Map
import           Data.Text                            (Text)
import qualified Data.Text                            as Text
import qualified Data.Text.Encoding                   as Text
import           Language.C.Analysis.AstAnalysis      (analyseAST)
import           Language.C.Analysis.SemRep           (GlobalDecls)
import           Language.C.Analysis.TravMonad        (CLanguage (..), Trav,
                                                       TravOptions (..),
                                                       modifyOptions,
                                                       modifyUserState, runTrav,
                                                       userState)
import           Language.C.Data.Error                (CError, errorPos)
import           Language.C.Data.Position             (isSourcePos)
import qualified Language.C.Data.Position             as C
import           Language.C.Syntax.AST                (CTranslUnit)
import           Language.Cimple.Diagnostics          (Diagnostic (..),
                                                       DiagnosticLevel (..),
                                                       IsPosition (..),
                                                       diagToText)
import qualified Language.Cimple.Diagnostics          as Diagnostics

import           Prettyprinter                        (Doc, pretty)
import           Prettyprinter.Render.Terminal        (AnsiStyle)
import qualified Tokstyle.C.Env                       as Env
import           Tokstyle.C.Env                       (DiagnosticLevel (..),
                                                       Env, LinterError,
                                                       defaultEnv, linterErrors)

import           Data.Function                        (on)
import qualified Tokstyle.C.Linter.BoolConversion     as BoolConversion (descr)
import qualified Tokstyle.C.Linter.BorrowCheck        as BorrowCheck (descr)
import qualified Tokstyle.C.Linter.CallbackData       as CallbackData (descr)
import qualified Tokstyle.C.Linter.CallbackDiscipline as CallbackDiscipline (descr)
import qualified Tokstyle.C.Linter.CallbackParams     as CallbackParams (descr)
import qualified Tokstyle.C.Linter.Cast               as Cast (descr)
import qualified Tokstyle.C.Linter.Conversion         as Conversion (descr)
import qualified Tokstyle.C.Linter.Memcpy             as Memcpy (descr)
import qualified Tokstyle.C.Linter.Memset             as Memset (descr)
import qualified Tokstyle.C.Linter.SizeArg            as SizeArg (descr)
import qualified Tokstyle.C.Linter.Sizeof             as Sizeof (descr)
import qualified Tokstyle.C.Linter.StrictTypedef      as StrictTypedef (descr)
import qualified Tokstyle.C.Linter.VoidCall           as VoidCall (descr)


type Linter = (GlobalDecls -> Trav Env (), (Text, Text))

linters :: [Linter]
linters :: [Linter]
linters =
    [ Linter
BoolConversion.descr
    , Linter
BorrowCheck.descr
    , Linter
CallbackData.descr
    , Linter
CallbackDiscipline.descr
    , Linter
CallbackParams.descr
    , Linter
Cast.descr
    , Linter
Conversion.descr
    , Linter
Memcpy.descr
    , Linter
Memset.descr
    , Linter
SizeArg.descr
    , Linter
Sizeof.descr
    , Linter
StrictTypedef.descr
    , Linter
VoidCall.descr
    ]


runLinters :: [Text] -> GlobalDecls -> Trav Env ()
runLinters :: [Text] -> GlobalDecls -> Trav Env ()
runLinters [Text]
flags GlobalDecls
tu =
    (Linter -> Trav Env ()) -> [Linter] -> Trav Env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(GlobalDecls -> Trav Env ()
f, (Text
flag, Text
_)) -> do
        (Env -> Env) -> Trav Env ()
forall s. (s -> s) -> Trav s ()
modifyUserState ((Env -> Env) -> Trav Env ()) -> (Env -> Env) -> Trav Env ()
forall a b. (a -> b) -> a -> b
$ \Env
env -> Env
env{currentFlag :: Maybe Text
Env.currentFlag = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
flag}
        GlobalDecls -> Trav Env ()
f GlobalDecls
tu
        (Env -> Env) -> Trav Env ()
forall s. (s -> s) -> Trav s ()
modifyUserState ((Env -> Env) -> Trav Env ()) -> (Env -> Env) -> Trav Env ()
forall a b. (a -> b) -> a -> b
$ \Env
env -> Env
env{currentFlag :: Maybe Text
Env.currentFlag = Maybe Text
forall a. Maybe a
Nothing}
    ) ([Linter] -> Trav Env ())
-> ([Linter] -> [Linter]) -> [Linter] -> Trav Env ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Linter -> Bool) -> [Linter] -> [Linter]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
flags) (Text -> Bool) -> (Linter -> Text) -> Linter -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Text) -> Text
forall a b. (a, b) -> a
fst ((Text, Text) -> Text)
-> (Linter -> (Text, Text)) -> Linter -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Linter -> (Text, Text)
forall a b. (a, b) -> b
snd) ([Linter] -> Trav Env ()) -> [Linter] -> Trav Env ()
forall a b. (a -> b) -> a -> b
$ [Linter]
linters


analyse :: [Text] -> CTranslUnit -> [LinterError]
analyse :: [Text] -> CTranslUnit -> [LinterError]
analyse [Text]
enabled CTranslUnit
tu =
    case Either [CError] ((), TravState Identity Env)
analysis of
        Left [CError]
errs        -> (CError -> LinterError) -> [CError] -> [LinterError]
forall a b. (a -> b) -> [a] -> [b]
map CError -> LinterError
toLinterError [CError]
errs
        Right (()
_, TravState Identity Env
state) -> [LinterError] -> [LinterError]
forall a. [a] -> [a]
reverse ([LinterError] -> [LinterError])
-> (Env -> [LinterError]) -> Env -> [LinterError]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> [LinterError]
linterErrors (Env -> [LinterError]) -> Env -> [LinterError]
forall a b. (a -> b) -> a -> b
$ TravState Identity Env -> Env
forall (m :: * -> *) s. TravState m s -> s
userState TravState Identity Env
state
  where
    analysis :: Either [CError] ((), TravState Identity Env)
analysis = Env -> Trav Env () -> Either [CError] ((), TravState Identity Env)
forall s a.
s -> Trav s a -> Either [CError] (a, TravState Identity s)
runTrav Env
defaultEnv (Trav Env () -> Either [CError] ((), TravState Identity Env))
-> Trav Env () -> Either [CError] ((), TravState Identity Env)
forall a b. (a -> b) -> a -> b
$ do
        (TravOptions -> TravOptions) -> Trav Env ()
forall s. (TravOptions -> TravOptions) -> Trav s ()
modifyOptions (\TravOptions
opts -> TravOptions
opts { language :: CLanguage
language = CLanguage
GNU99 })
        GlobalDecls
decls <- CTranslUnit -> TravT Env Identity GlobalDecls
forall (m :: * -> *). MonadTrav m => CTranslUnit -> m GlobalDecls
analyseAST CTranslUnit
tu
        [Text] -> GlobalDecls -> Trav Env ()
runLinters [Text]
enabled GlobalDecls
decls

    toLinterError :: CError -> LinterError
    toLinterError :: CError -> LinterError
toLinterError CError
err = CPosition
-> Int
-> DiagnosticLevel
-> Doc AnsiStyle
-> Maybe Text
-> [DiagnosticSpan CPosition]
-> [(DiagnosticLevel, Doc AnsiStyle)]
-> LinterError
forall pos.
pos
-> Int
-> DiagnosticLevel
-> Doc AnsiStyle
-> Maybe Text
-> [DiagnosticSpan pos]
-> [(DiagnosticLevel, Doc AnsiStyle)]
-> Diagnostic pos
Diagnostic (Position -> CPosition
Env.CPosition (CError -> Position
forall e. Error e => e -> Position
errorPos CError
err)) Int
1 DiagnosticLevel
ErrorLevel (String -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty (CError -> String
forall a. Show a => a -> String
show CError
err)) Maybe Text
forall a. Maybe a
Nothing [] []


analyseText :: [Text] -> CTranslUnit -> [Text]
analyseText :: [Text] -> CTranslUnit -> [Text]
analyseText [Text]
enabled CTranslUnit
tu = (LinterError -> Text) -> [LinterError] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map LinterError -> Text
forall pos. IsPosition pos => Diagnostic pos -> Text
diagToText ([Text] -> CTranslUnit -> [LinterError]
analyse [Text]
enabled CTranslUnit
tu)


renderIO :: [LinterError] -> IO [Doc AnsiStyle]
renderIO :: [LinterError] -> IO [Doc AnsiStyle]
renderIO [LinterError]
errors = do
    let files :: [String]
files = Map String () -> [String]
forall k a. Map k a -> [k]
Map.keys (Map String () -> [String])
-> ([(String, ())] -> Map String ()) -> [(String, ())] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(String, ())] -> Map String ()
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(String, ())] -> [String]) -> [(String, ())] -> [String]
forall a b. (a -> b) -> a -> b
$ [ (CPosition -> String
forall p. IsPosition p => p -> String
posFile (LinterError -> CPosition
forall pos. Diagnostic pos -> pos
diagPos LinterError
e), ()) | LinterError
e <- [LinterError]
errors, CPosition -> Bool
forall p. IsPosition p => p -> Bool
isRealPos (LinterError -> CPosition
forall pos. Diagnostic pos -> pos
diagPos LinterError
e) ]
    Map String [Text]
cache <- [(String, [Text])] -> Map String [Text]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(String, [Text])] -> Map String [Text])
-> IO [(String, [Text])] -> IO (Map String [Text])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> IO (String, [Text]))
-> [String] -> IO [(String, [Text])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\String
f -> do
        [Text]
ls <- Text -> [Text]
Text.lines (Text -> [Text]) -> (ByteString -> Text) -> ByteString -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
Text.decodeUtf8 (ByteString -> [Text]) -> IO ByteString -> IO [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
BS.readFile String
f
        (String, [Text]) -> IO (String, [Text])
forall (m :: * -> *) a. Monad m => a -> m a
return (String
f, [Text]
ls)) [String]
files
    [Doc AnsiStyle] -> IO [Doc AnsiStyle]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Doc AnsiStyle] -> IO [Doc AnsiStyle])
-> [Doc AnsiStyle] -> IO [Doc AnsiStyle]
forall a b. (a -> b) -> a -> b
$ Map String [Text] -> [LinterError] -> [Doc AnsiStyle]
renderPure Map String [Text]
cache [LinterError]
errors


renderPure :: Map FilePath [Text] -> [LinterError] -> [Doc AnsiStyle]
renderPure :: Map String [Text] -> [LinterError] -> [Doc AnsiStyle]
renderPure = Map String [Text] -> [LinterError] -> [Doc AnsiStyle]
forall pos.
IsPosition pos =>
Map String [Text] -> [Diagnostic pos] -> [Doc AnsiStyle]
Diagnostics.renderPure


allWarnings :: [Text]
allWarnings :: [Text]
allWarnings = (Linter -> Text) -> [Linter] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ((Text, Text) -> Text
forall a b. (a, b) -> a
fst ((Text, Text) -> Text)
-> (Linter -> (Text, Text)) -> Linter -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Linter -> (Text, Text)
forall a b. (a, b) -> b
snd) [Linter]
linters


markdown :: Text
markdown :: Text
markdown = Text -> [Text] -> Text
Text.intercalate Text
"\n" ([Text] -> Text) -> ([Linter] -> [Text]) -> [Linter] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Text]
prelude [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++) ([Text] -> [Text]) -> ([Linter] -> [Text]) -> [Linter] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Linter -> Text) -> [Linter] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Linter -> Text
forall a. (a, (Text, Text)) -> Text
mkDoc ([Linter] -> [Text])
-> ([Linter] -> [Linter]) -> [Linter] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Linter -> Linter -> Ordering) -> [Linter] -> [Linter]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Text -> Text -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Text -> Text -> Ordering)
-> (Linter -> Text) -> Linter -> Linter -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ((Text, Text) -> Text
forall a b. (a, b) -> a
fst ((Text, Text) -> Text)
-> (Linter -> (Text, Text)) -> Linter -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Linter -> (Text, Text)
forall a b. (a, b) -> b
snd)) ([Linter] -> Text) -> [Linter] -> Text
forall a b. (a -> b) -> a -> b
$ [Linter]
linters
  where
    prelude :: [Text]
prelude =
        [ Text
"# C-based linters (`check-c`)"
        , Text
""
        , Text
"There are currently " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ [Linter] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Linter]
linters) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" linters implemented."
        , Text
""
        ]
    mkDoc :: (a, (Text, Text)) -> Text
mkDoc (a
_, (Text
flag, Text
doc)) = Text
"## `-W" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
flag Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"`\n\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
Text.stripEnd Text
doc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"