{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Strict            #-}
module Tokstyle.Linter.DeclsHaveDefns (descr) where

import           Control.Arrow               ((&&&))
import           Control.Monad.State.Strict  (State)
import qualified Control.Monad.State.Strict  as State
import           Data.Fix                    (Fix (..))
import           Data.List                   (sortOn)
import           Data.Map                    (Map)
import qualified Data.Map                    as Map
import           Data.Maybe                  (mapMaybe)
import           Data.Text                   (Text)
import qualified Data.Text                   as Text
import           Language.Cimple             (AlexPosn (..), Lexeme (..),
                                              LexemeClass (..), Node,
                                              NodeF (..), lexemeText)
import           Language.Cimple.Diagnostics (CimplePos, Diagnostic (..),
                                              DiagnosticLevel (..), lexemePos)
import qualified Language.Cimple.Diagnostics as Diagnostics
import           Language.Cimple.TraverseAst (AstActions, astActions, doNode,
                                              traverseAst)
import           Prettyprinter               (pretty)
import           Text.EditDistance           (defaultEditCosts,
                                              levenshteinDistance)


maxEditDistance :: Int
maxEditDistance :: Int
maxEditDistance = Int
5


data DeclDefn = DeclDefn
    { DeclDefn -> Maybe (FilePath, Lexeme Text)
decl :: Maybe (FilePath, Lexeme Text)
    , DeclDefn -> Maybe (FilePath, Lexeme Text)
defn :: Maybe (FilePath, Lexeme Text)
    }

type Env = Map Text DeclDefn

empty :: Env
empty :: Map Text DeclDefn
empty = [(Text, DeclDefn)] -> Map Text DeclDefn
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    [ (Text
"ev_loop", FilePath -> DeclDefn
inFile FilePath
"ev.h")
    ]
  where
    inFile :: FilePath -> DeclDefn
inFile FilePath
f = DeclDefn{ decl :: Maybe (FilePath, Lexeme Text)
decl = (FilePath, Lexeme Text) -> Maybe (FilePath, Lexeme Text)
forall a. a -> Maybe a
Just (FilePath
f, Lexeme Text
lexeme), defn :: Maybe (FilePath, Lexeme Text)
defn = (FilePath, Lexeme Text) -> Maybe (FilePath, Lexeme Text)
forall a. a -> Maybe a
Just (FilePath
f, Lexeme Text
lexeme) }
    lexeme :: Lexeme Text
lexeme = 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
Eof Text
""

addDecl :: FilePath -> Lexeme Text -> State Env ()
addDecl :: FilePath -> Lexeme Text -> State (Map Text DeclDefn) ()
addDecl FilePath
file l :: Lexeme Text
l@(L AlexPosn
_ LexemeClass
_ Text
name) =
    (Map Text DeclDefn -> Map Text DeclDefn)
-> State (Map Text DeclDefn) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify ((Map Text DeclDefn -> Map Text DeclDefn)
 -> State (Map Text DeclDefn) ())
-> (Map Text DeclDefn -> Map Text DeclDefn)
-> State (Map Text DeclDefn) ()
forall a b. (a -> b) -> a -> b
$ \Map Text DeclDefn
pairs ->
        case Text -> Map Text DeclDefn -> Maybe DeclDefn
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
name Map Text DeclDefn
pairs of
            Maybe DeclDefn
Nothing -> Text -> DeclDefn -> Map Text DeclDefn -> Map Text DeclDefn
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
name (DeclDefn{ decl :: Maybe (FilePath, Lexeme Text)
decl = (FilePath, Lexeme Text) -> Maybe (FilePath, Lexeme Text)
forall a. a -> Maybe a
Just (FilePath
file, Lexeme Text
l), defn :: Maybe (FilePath, Lexeme Text)
defn = Maybe (FilePath, Lexeme Text)
forall a. Maybe a
Nothing }) Map Text DeclDefn
pairs
            Just DeclDefn
dd -> Text -> DeclDefn -> Map Text DeclDefn -> Map Text DeclDefn
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
name (DeclDefn
dd      { decl = Just (file, l)                 }) Map Text DeclDefn
pairs

addDefn :: FilePath -> Lexeme Text -> State Env ()
addDefn :: FilePath -> Lexeme Text -> State (Map Text DeclDefn) ()
addDefn FilePath
file l :: Lexeme Text
l@(L AlexPosn
_ LexemeClass
_ Text
name) =
    (Map Text DeclDefn -> Map Text DeclDefn)
-> State (Map Text DeclDefn) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify ((Map Text DeclDefn -> Map Text DeclDefn)
 -> State (Map Text DeclDefn) ())
-> (Map Text DeclDefn -> Map Text DeclDefn)
-> State (Map Text DeclDefn) ()
forall a b. (a -> b) -> a -> b
$ \Map Text DeclDefn
pairs ->
        case Text -> Map Text DeclDefn -> Maybe DeclDefn
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
name Map Text DeclDefn
pairs of
            Maybe DeclDefn
Nothing -> Text -> DeclDefn -> Map Text DeclDefn -> Map Text DeclDefn
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
name (DeclDefn{ decl :: Maybe (FilePath, Lexeme Text)
decl = Maybe (FilePath, Lexeme Text)
forall a. Maybe a
Nothing, defn :: Maybe (FilePath, Lexeme Text)
defn = (FilePath, Lexeme Text) -> Maybe (FilePath, Lexeme Text)
forall a. a -> Maybe a
Just (FilePath
file, Lexeme Text
l) }) Map Text DeclDefn
pairs
            Just DeclDefn
dd -> Text -> DeclDefn -> Map Text DeclDefn -> Map Text DeclDefn
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
name (DeclDefn
dd      {                 defn = Just (file, l) }) Map Text DeclDefn
pairs


collectPairs :: AstActions (State Env) Text
collectPairs :: AstActions (StateT (Map Text DeclDefn) Identity) Text
collectPairs = AstActions (StateT (Map Text DeclDefn) Identity) Text
forall (f :: * -> *) text. Applicative f => AstActions f text
astActions
    { doNode = \FilePath
file Node (Lexeme Text)
node State (Map Text DeclDefn) ()
act ->
        case Node (Lexeme Text) -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node (Lexeme Text)
node of
            FunctionDecl Scope
_ (Fix (FunctionPrototype Node (Lexeme Text)
_ Lexeme Text
fname [Node (Lexeme Text)]
_))   -> FilePath -> Lexeme Text -> State (Map Text DeclDefn) ()
addDecl FilePath
file Lexeme Text
fname
            FunctionDefn Scope
_ (Fix (FunctionPrototype Node (Lexeme Text)
_ Lexeme Text
fname [Node (Lexeme Text)]
_)) Node (Lexeme Text)
_ -> FilePath -> Lexeme Text -> State (Map Text DeclDefn) ()
addDefn FilePath
file Lexeme Text
fname
            TyStruct Lexeme Text
sname -> FilePath -> Lexeme Text -> State (Map Text DeclDefn) ()
addDecl FilePath
file Lexeme Text
sname
            Struct Lexeme Text
sname [Node (Lexeme Text)]
_ -> FilePath -> Lexeme Text -> State (Map Text DeclDefn) ()
addDefn FilePath
file Lexeme Text
sname

            NodeF (Lexeme Text) (Node (Lexeme Text))
_ -> State (Map Text DeclDefn) ()
act
    }

analyse :: [(FilePath, [Node (Lexeme Text)])] -> [Diagnostic CimplePos]
analyse :: [(FilePath, [Node (Lexeme Text)])] -> [Diagnostic CimplePos]
analyse =
    ([(FilePath, Lexeme Text)]
 -> [(FilePath, Lexeme Text)] -> [Diagnostic CimplePos])
-> ([(FilePath, Lexeme Text)], [(FilePath, Lexeme Text)])
-> [Diagnostic CimplePos]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (((FilePath, Lexeme Text) -> [Diagnostic CimplePos])
-> [(FilePath, Lexeme Text)] -> [Diagnostic CimplePos]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (((FilePath, Lexeme Text) -> [Diagnostic CimplePos])
 -> [(FilePath, Lexeme Text)] -> [Diagnostic CimplePos])
-> ([(FilePath, Lexeme Text)]
    -> (FilePath, Lexeme Text) -> [Diagnostic CimplePos])
-> [(FilePath, Lexeme Text)]
-> [(FilePath, Lexeme Text)]
-> [Diagnostic CimplePos]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(FilePath, Lexeme Text)]
-> (FilePath, Lexeme Text) -> [Diagnostic CimplePos]
makeDiagnostic)
    (([(FilePath, Lexeme Text)], [(FilePath, Lexeme Text)])
 -> [Diagnostic CimplePos])
-> ([(FilePath, [Node (Lexeme Text)])]
    -> ([(FilePath, Lexeme Text)], [(FilePath, Lexeme Text)]))
-> [(FilePath, [Node (Lexeme Text)])]
-> [Diagnostic CimplePos]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((DeclDefn -> Maybe (FilePath, Lexeme Text))
-> [DeclDefn] -> [(FilePath, Lexeme Text)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe DeclDefn -> Maybe (FilePath, Lexeme Text)
defn ([DeclDefn] -> [(FilePath, Lexeme Text)])
-> ([DeclDefn] -> [(FilePath, Lexeme Text)])
-> [DeclDefn]
-> ([(FilePath, Lexeme Text)], [(FilePath, Lexeme Text)])
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (DeclDefn -> Maybe (FilePath, Lexeme Text))
-> [DeclDefn] -> [(FilePath, Lexeme Text)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe DeclDefn -> Maybe (FilePath, Lexeme Text)
lacksDefn)
    ([DeclDefn]
 -> ([(FilePath, Lexeme Text)], [(FilePath, Lexeme Text)]))
-> ([(FilePath, [Node (Lexeme Text)])] -> [DeclDefn])
-> [(FilePath, [Node (Lexeme Text)])]
-> ([(FilePath, Lexeme Text)], [(FilePath, Lexeme Text)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Text DeclDefn -> [DeclDefn]
forall k a. Map k a -> [a]
Map.elems
    (Map Text DeclDefn -> [DeclDefn])
-> ([(FilePath, [Node (Lexeme Text)])] -> Map Text DeclDefn)
-> [(FilePath, [Node (Lexeme Text)])]
-> [DeclDefn]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (State (Map Text DeclDefn) ()
 -> Map Text DeclDefn -> Map Text DeclDefn)
-> Map Text DeclDefn
-> State (Map Text DeclDefn) ()
-> Map Text DeclDefn
forall a b c. (a -> b -> c) -> b -> a -> c
flip State (Map Text DeclDefn) ()
-> Map Text DeclDefn -> Map Text DeclDefn
forall s a. State s a -> s -> s
State.execState Map Text DeclDefn
empty
    (State (Map Text DeclDefn) () -> Map Text DeclDefn)
-> ([(FilePath, [Node (Lexeme Text)])]
    -> State (Map Text DeclDefn) ())
-> [(FilePath, [Node (Lexeme Text)])]
-> Map Text DeclDefn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AstActions (StateT (Map Text DeclDefn) Identity) Text
-> [(FilePath, [Node (Lexeme Text)])]
-> State (Map Text DeclDefn) ()
forall text a (f :: * -> *).
(TraverseAst text a, Applicative f) =>
AstActions f text -> a -> f ()
traverseAst AstActions (StateT (Map Text DeclDefn) Identity) Text
collectPairs
  where
    lacksDefn :: DeclDefn -> Maybe (FilePath, Lexeme Text)
lacksDefn DeclDefn{Maybe (FilePath, Lexeme Text)
decl :: DeclDefn -> Maybe (FilePath, Lexeme Text)
decl :: Maybe (FilePath, Lexeme Text)
decl, defn :: DeclDefn -> Maybe (FilePath, Lexeme Text)
defn = Maybe (FilePath, Lexeme Text)
Nothing} = Maybe (FilePath, Lexeme Text)
decl
    lacksDefn DeclDefn
_                              = Maybe (FilePath, Lexeme Text)
forall a. Maybe a
Nothing

makeDiagnostic :: [(FilePath, Lexeme Text)] -> (FilePath, Lexeme Text) -> [Diagnostic CimplePos]
makeDiagnostic :: [(FilePath, Lexeme Text)]
-> (FilePath, Lexeme Text) -> [Diagnostic CimplePos]
makeDiagnostic [(FilePath, Lexeme Text)]
defns (FilePath
file, fn :: Lexeme Text
fn@(L AlexPosn
_ LexemeClass
_ Text
name)) =
    CimplePos
-> Int
-> DiagnosticLevel
-> Doc AnsiStyle
-> Maybe Text
-> [DiagnosticSpan CimplePos]
-> [(DiagnosticLevel, Doc AnsiStyle)]
-> Diagnostic CimplePos
forall pos.
pos
-> Int
-> DiagnosticLevel
-> Doc AnsiStyle
-> Maybe Text
-> [DiagnosticSpan pos]
-> [(DiagnosticLevel, Doc AnsiStyle)]
-> Diagnostic pos
Diagnostic (FilePath -> Lexeme Text -> CimplePos
forall text. FilePath -> Lexeme text -> CimplePos
lexemePos FilePath
file Lexeme Text
fn) (Text -> Int
Text.length Text
name) DiagnosticLevel
WarningLevel (Text -> Doc AnsiStyle
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Text -> Doc AnsiStyle) -> Text -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ Text
"missing definition for `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"`") Maybe Text
forall a. Maybe a
Nothing [] []
    Diagnostic CimplePos
-> [Diagnostic CimplePos] -> [Diagnostic CimplePos]
forall a. a -> [a] -> [a]
: case [(FilePath, Lexeme Text)] -> [(Int, (FilePath, Lexeme Text))]
forall {a}. [(a, Lexeme Text)] -> [(Int, (a, Lexeme Text))]
dists [(FilePath, Lexeme Text)]
defns of
        (Int
d, (FilePath
dfile, dn :: Lexeme Text
dn@(L AlexPosn
_ LexemeClass
_ Text
dname))):[(Int, (FilePath, Lexeme Text))]
_ | Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
maxEditDistance ->
            [CimplePos
-> Int
-> DiagnosticLevel
-> Doc AnsiStyle
-> Maybe Text
-> [DiagnosticSpan CimplePos]
-> [(DiagnosticLevel, Doc AnsiStyle)]
-> Diagnostic CimplePos
forall pos.
pos
-> Int
-> DiagnosticLevel
-> Doc AnsiStyle
-> Maybe Text
-> [DiagnosticSpan pos]
-> [(DiagnosticLevel, Doc AnsiStyle)]
-> Diagnostic pos
Diagnostic (FilePath -> Lexeme Text -> CimplePos
forall text. FilePath -> Lexeme text -> CimplePos
lexemePos FilePath
dfile Lexeme Text
dn) (Text -> Int
Text.length Text
dname) DiagnosticLevel
NoteLevel (Text -> Doc AnsiStyle
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Text -> Doc AnsiStyle) -> Text -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ Text
"did you mean `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
dname Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"`?") Maybe Text
forall a. Maybe a
Nothing [] []]
        [(Int, (FilePath, Lexeme Text))]
_ -> []
  where
    dists :: [(a, Lexeme Text)] -> [(Int, (a, Lexeme Text))]
dists = ((Int, (a, Lexeme Text)) -> Int)
-> [(Int, (a, Lexeme Text))] -> [(Int, (a, Lexeme Text))]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Int, (a, Lexeme Text)) -> Int
forall a b. (a, b) -> a
fst ([(Int, (a, Lexeme Text))] -> [(Int, (a, Lexeme Text))])
-> ([(a, Lexeme Text)] -> [(Int, (a, Lexeme Text))])
-> [(a, Lexeme Text)]
-> [(Int, (a, Lexeme Text))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, Lexeme Text) -> (Int, (a, Lexeme Text)))
-> [(a, Lexeme Text)] -> [(Int, (a, Lexeme Text))]
forall a b. (a -> b) -> [a] -> [b]
map ((EditCosts -> FilePath -> FilePath -> Int
levenshteinDistance EditCosts
defaultEditCosts (Lexeme Text -> FilePath
normalise Lexeme Text
fn) (FilePath -> Int)
-> ((a, Lexeme Text) -> FilePath) -> (a, Lexeme Text) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lexeme Text -> FilePath
normalise (Lexeme Text -> FilePath)
-> ((a, Lexeme Text) -> Lexeme Text)
-> (a, Lexeme Text)
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, Lexeme Text) -> Lexeme Text
forall a b. (a, b) -> b
snd) ((a, Lexeme Text) -> Int)
-> ((a, Lexeme Text) -> (a, Lexeme Text))
-> (a, Lexeme Text)
-> (Int, (a, Lexeme Text))
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (a, Lexeme Text) -> (a, Lexeme Text)
forall a. a -> a
id)
    normalise :: Lexeme Text -> FilePath
normalise = Text -> FilePath
Text.unpack (Text -> FilePath)
-> (Lexeme Text -> Text) -> Lexeme Text -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Text.toLower (Text -> Text) -> (Lexeme Text -> Text) -> Lexeme Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lexeme Text -> Text
forall text. Lexeme text -> text
lexemeText

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
"decls-have-defns", [Text] -> Text
Text.unlines
    [ Text
"Checks that all function declarations also have matching definitions."
    , Text
""
    , Text
"**Reason:** extern function declarations without definitions are not implemented"
    , Text
"and cannot be used. This likely means the declaration was forgotten when"
    , Text
"deleting a function."
    ]))