{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns        #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE Strict                #-}
module Tokstyle.Common.EnumLinter
    ( EnumInfo (..)
    , MkFunBody
    , analyseEnums
    , mkLAt
    ) where

import           Control.Monad               (unless)
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             (Lexeme (..), LexemeClass (..),
                                              Node, NodeF (..))
import           Language.Cimple.Diagnostics (CimplePos, Diagnostic,
                                              HasDiagnosticsRich (..))
import           Language.Cimple.Pretty      (ppTranslationUnit)
import           Language.Cimple.TraverseAst (AstActions, astActions, doNode,
                                              traverseAst)
import           Prettyprinter               (line, pretty)
import           Tokstyle.Common             (semEq, warn, warnDoc)

data EnumInfo = EnumInfo
    { EnumInfo -> Text
enumName    :: Text
    , EnumInfo -> [Node (Lexeme Text)]
enumMembers :: [Node (Lexeme Text)]
    }

type SymbolTable = [(Text, EnumInfo)]

data Linter = Linter
    { Linter -> [Diagnostic CimplePos]
diags :: [Diagnostic CimplePos]
    , Linter -> SymbolTable
types :: SymbolTable
    }

instance HasDiagnosticsRich Linter CimplePos where
    addDiagnosticRich :: Diagnostic CimplePos -> Linter -> Linter
addDiagnosticRich Diagnostic CimplePos
diag l :: Linter
l@Linter{[Diagnostic CimplePos]
diags :: [Diagnostic CimplePos]
diags :: Linter -> [Diagnostic CimplePos]
diags} = Linter
l{diags :: [Diagnostic CimplePos]
diags = Diagnostic CimplePos
diag Diagnostic CimplePos
-> [Diagnostic CimplePos] -> [Diagnostic CimplePos]
forall a. a -> [a] -> [a]
: [Diagnostic CimplePos]
diags}

empty :: Linter
empty :: Linter
empty = [Diagnostic CimplePos] -> SymbolTable -> Linter
Linter [] []

mkLAt :: Lexeme a -> LexemeClass -> a -> Lexeme a
mkLAt :: Lexeme a -> LexemeClass -> a -> Lexeme a
mkLAt (L AlexPosn
p LexemeClass
_ a
_) = AlexPosn -> LexemeClass -> a -> Lexeme a
forall text. AlexPosn -> LexemeClass -> text -> Lexeme text
L AlexPosn
p

collectEnums :: [(FilePath, [Node (Lexeme Text)])] -> State Linter ()
collectEnums :: [(FilePath, [Node (Lexeme Text)])] -> State Linter ()
collectEnums = 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
actions
  where
    actions :: AstActions (State Linter) Text
    actions :: AstActions (State Linter) Text
actions = 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
                EnumDecl (L AlexPosn
_ LexemeClass
_ Text
ename) [Node (Lexeme Text)]
enumrs Lexeme Text
_ -> do
                    l :: Linter
l@Linter{SymbolTable
types :: SymbolTable
types :: Linter -> SymbolTable
types} <- State Linter Linter
forall s (m :: * -> *). MonadState s m => m s
State.get
                    case Text -> SymbolTable -> Maybe EnumInfo
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
ename SymbolTable
types of
                        Maybe EnumInfo
Nothing -> Linter -> State Linter ()
forall s (m :: * -> *). MonadState s m => s -> m ()
State.put Linter
l{types :: SymbolTable
types = (Text -> Text
Text.toLower Text
ename, Text -> [Node (Lexeme Text)] -> EnumInfo
EnumInfo Text
ename [Node (Lexeme Text)]
enumrs)(Text, EnumInfo) -> SymbolTable -> SymbolTable
forall a. a -> [a] -> [a]
:SymbolTable
types}
                        Just{} -> FilePath -> Node (Lexeme Text) -> Text -> State Linter ()
forall diags at.
(HasDiagnosticsRich diags CimplePos,
 HasDiagnosticInfo at CimplePos) =>
FilePath -> at -> Text -> DiagnosticsT diags ()
warn FilePath
file Node (Lexeme Text)
node (Text -> State Linter ()) -> Text -> State Linter ()
forall a b. (a -> b) -> a -> b
$ Text
"duplicate enum: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ename

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

type MkFunBody = SymbolTable -> Lexeme Text -> EnumInfo -> Maybe (Node (Lexeme Text))

checkEnums :: Text -> MkFunBody -> [(FilePath, [Node (Lexeme Text)])] -> State Linter ()
checkEnums :: Text
-> MkFunBody
-> [(FilePath, [Node (Lexeme Text)])]
-> State Linter ()
checkEnums Text
funSuffix MkFunBody
mkFunBody = 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
actions
  where
    actions :: AstActions (State Linter) Text
    actions :: AstActions (State Linter) Text
actions = 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
                FunctionDefn Scope
_ (Fix (FunctionPrototype Node (Lexeme Text)
_ (L AlexPosn
_ LexemeClass
_ Text
fname) (Fix (VarDecl Node (Lexeme Text)
_ Lexeme Text
varName [Node (Lexeme Text)]
_):[Node (Lexeme Text)]
_))) Node (Lexeme Text)
body
                    | Text
funSuffix Text -> Text -> Bool
`Text.isSuffixOf` Text
fname -> do
                    Linter{SymbolTable
types :: SymbolTable
types :: Linter -> SymbolTable
types} <- State Linter Linter
forall s (m :: * -> *). MonadState s m => m s
State.get
                    case Text -> SymbolTable -> Maybe EnumInfo
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (Int -> Text -> Text
Text.dropEnd (Text -> Int
Text.length Text
funSuffix) Text
fname) SymbolTable
types of
                        Maybe EnumInfo
Nothing -> () -> State Linter ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()  -- not every _to_string function is for enums
                        Just e :: EnumInfo
e@(EnumInfo Text
ename [Node (Lexeme Text)]
_) -> do
                            case MkFunBody
mkFunBody SymbolTable
types Lexeme Text
varName EnumInfo
e of
                                Maybe (Node (Lexeme Text))
Nothing ->
                                    FilePath -> Node (Lexeme Text) -> Text -> State Linter ()
forall diags at.
(HasDiagnosticsRich diags CimplePos,
 HasDiagnosticInfo at CimplePos) =>
FilePath -> at -> Text -> DiagnosticsT diags ()
warn FilePath
file Node (Lexeme Text)
node (Text -> State Linter ()) -> Text -> State Linter ()
forall a b. (a -> b) -> a -> b
$ Text
"invalid enum format for `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ename Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"`"
                                Just Node (Lexeme Text)
wanted ->
                                    Bool -> State Linter () -> State Linter ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Node (Lexeme Text)
body Node (Lexeme Text) -> Node (Lexeme Text) -> Bool
`semEq` Node (Lexeme Text)
wanted) (State Linter () -> State Linter ())
-> State Linter () -> State Linter ()
forall a b. (a -> b) -> a -> b
$
                                        FilePath -> Node (Lexeme Text) -> Doc AnsiStyle -> State Linter ()
forall diags at.
(HasDiagnosticsRich diags CimplePos,
 HasDiagnosticInfo at CimplePos) =>
FilePath -> at -> Doc AnsiStyle -> DiagnosticsT diags ()
warnDoc FilePath
file Node (Lexeme Text)
node (Doc AnsiStyle -> State Linter ())
-> Doc AnsiStyle -> State Linter ()
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle
"enum `" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Text -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty Text
funSuffix Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
"` function for `" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Text -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty Text
ename Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
"` should be:" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
forall ann. Doc ann
line
                                            Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> [Node (Lexeme Text)] -> Doc AnsiStyle
forall a. Pretty a => [Node (Lexeme a)] -> Doc AnsiStyle
ppTranslationUnit [Node (Lexeme Text)
wanted]

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


analyseEnums :: Text -> MkFunBody -> [(FilePath, [Node (Lexeme Text)])] -> [Diagnostic CimplePos]
analyseEnums :: Text
-> MkFunBody
-> [(FilePath, [Node (Lexeme Text)])]
-> [Diagnostic CimplePos]
analyseEnums Text
funSuffix MkFunBody
mkFunBody =
    [Diagnostic CimplePos] -> [Diagnostic CimplePos]
forall a. [a] -> [a]
reverse ([Diagnostic CimplePos] -> [Diagnostic CimplePos])
-> ([(FilePath, [Node (Lexeme Text)])] -> [Diagnostic CimplePos])
-> [(FilePath, [Node (Lexeme Text)])]
-> [Diagnostic CimplePos]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Linter -> [Diagnostic CimplePos]
diags (Linter -> [Diagnostic CimplePos])
-> ([(FilePath, [Node (Lexeme Text)])] -> Linter)
-> [(FilePath, [Node (Lexeme Text)])]
-> [Diagnostic CimplePos]
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
. (\[(FilePath, [Node (Lexeme Text)])]
tus -> [(FilePath, [Node (Lexeme Text)])] -> State Linter ()
collectEnums [(FilePath, [Node (Lexeme Text)])]
tus State Linter () -> State Linter () -> State Linter ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text
-> MkFunBody
-> [(FilePath, [Node (Lexeme Text)])]
-> State Linter ()
checkEnums Text
funSuffix MkFunBody
mkFunBody [(FilePath, [Node (Lexeme Text)])]
tus) ([(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