{-# 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 (HasDiagnostics (..), warn)
import           Language.Cimple.Pretty      (ppTranslationUnit, render)
import           Language.Cimple.TraverseAst (AstActions, astActions, doNode,
                                              traverseAst)
import           Tokstyle.Common             (semEq)

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

type SymbolTable = [(Text, EnumInfo)]

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

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}

empty :: Linter
empty :: Linter
empty = [Text] -> 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 at diags.
(HasLocation at, HasDiagnostics diags) =>
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 at diags.
(HasLocation at, HasDiagnostics diags) =>
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) -> Text -> State Linter ()
forall at diags.
(HasLocation at, HasDiagnostics diags) =>
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
"enum `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
funSuffix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"` function for `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ename Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"` should be:\n"
                                            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle -> Text
render ([Node (Lexeme Text)] -> Doc AnsiStyle
ppTranslationUnit [Node (Lexeme Text)
wanted])

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


analyseEnums :: Text -> MkFunBody -> [(FilePath, [Node (Lexeme Text)])] -> [Text]
analyseEnums :: Text -> MkFunBody -> [(FilePath, [Node (Lexeme Text)])] -> [Text]
analyseEnums Text
funSuffix MkFunBody
mkFunBody =
    [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 () -> 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