{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Strict            #-}
module Tokstyle.Common.StructLinter
    ( MkFunBody
    , analyseStructs
    , 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)
import qualified Tokstyle.Common.TypeSystem  as TypeSystem
import           Tokstyle.Common.TypeSystem  (TypeDescr (..), TypeSystem)

newtype Linter = Linter
    { Linter -> [Text]
diags :: [Text]
    }

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] -> 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

type MkFunBody = TypeSystem -> Lexeme Text -> TypeDescr -> Maybe (Either Text (Node (Lexeme Text)))

checkStructs :: TypeSystem -> Text -> MkFunBody -> [(FilePath, [Node (Lexeme Text)])] -> State Linter ()
checkStructs :: TypeSystem
-> Text
-> MkFunBody
-> [(FilePath, [Node (Lexeme Text)])]
-> State Linter ()
checkStructs TypeSystem
tys 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
                    case Text -> TypeSystem -> Maybe TypeDescr
TypeSystem.lookupType (Int -> Text -> Text
Text.dropEnd (Text -> Int
Text.length Text
funSuffix) Text
fname) TypeSystem
tys of
                        Just e :: TypeDescr
e@(StructDescr (L AlexPosn
_ LexemeClass
_ Text
sname) [(Lexeme Text, TypeInfo)]
_) -> do
                            case MkFunBody
mkFunBody TypeSystem
tys Lexeme Text
varName TypeDescr
e of
                                Maybe (Either Text (Node (Lexeme Text)))
Nothing -> () -> State Linter ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                                Just (Left Text
err) ->
                                    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 struct format for `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
sname Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"`: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
err
                                Just (Right 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
"struct `" 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
sname 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])
                        Maybe TypeDescr
_ -> () -> State Linter ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()  -- not every _to_string function is for structs

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


analyseStructs :: Text -> MkFunBody -> [(FilePath, [Node (Lexeme Text)])] -> [Text]
analyseStructs :: Text -> MkFunBody -> [(FilePath, [Node (Lexeme Text)])] -> [Text]
analyseStructs 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 -> TypeSystem
-> Text
-> MkFunBody
-> [(FilePath, [Node (Lexeme Text)])]
-> State Linter ()
checkStructs ([(FilePath, [Node (Lexeme Text)])] -> TypeSystem
TypeSystem.collect [(FilePath, [Node (Lexeme Text)])]
tus) 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