{-# LANGUAGE MultiParamTypeClasses #-}
{-# 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 (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)
import qualified Tokstyle.Common.TypeSystem  as TypeSystem
import           Tokstyle.Common.TypeSystem  (TypeDescr (..), TypeSystem)

newtype Linter = Linter
    { Linter -> [Diagnostic CimplePos]
diags :: [Diagnostic CimplePos]
    }

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] -> 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 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 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) -> 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
"struct `" 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
sname 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]
                        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)])] -> [Diagnostic CimplePos]
analyseStructs :: Text
-> MkFunBody
-> [(FilePath, [Node (Lexeme Text)])]
-> [Diagnostic CimplePos]
analyseStructs 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 -> 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