{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE Strict           #-}
module Tokstyle.Common
    ( functionName
    , isPointer
    , semEq
    , skip
    , warn
    , warnDoc
    , backticks
    , dquotes
    , (>+>)
    ) where

import           Data.Fix                      (Fix (..))
import qualified Data.List                     as List
import           Data.Text                     (Text)
import           Language.Cimple               (Lexeme (..), LexemeClass (..),
                                                Node, NodeF (..), removeSloc)
import           Language.Cimple.Diagnostics   (CimplePos, Diagnostic (..),
                                                DiagnosticLevel (..),
                                                DiagnosticsT,
                                                HasDiagnosticInfo (..),
                                                HasDiagnosticsRich, warnRich)
import           Prettyprinter                 (Doc, pretty)
import           Prettyprinter.Render.Terminal (AnsiStyle)


isPointer :: Node (Lexeme Text) -> Bool
isPointer :: Node (Lexeme Text) -> Bool
isPointer Node (Lexeme Text)
x = case Node (Lexeme Text) -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node (Lexeme Text)
x of
    VarDecl Node (Lexeme Text)
ty Lexeme Text
_ []  -> Node (Lexeme Text) -> Bool
isPointer Node (Lexeme Text)
ty
    VarDecl{}        -> Bool
True
    TyConst Node (Lexeme Text)
ty       -> Node (Lexeme Text) -> Bool
isPointer Node (Lexeme Text)
ty
    TyOwner Node (Lexeme Text)
ty       -> Node (Lexeme Text) -> Bool
isPointer Node (Lexeme Text)
ty
    TyPointer{}      -> Bool
True
    TyStd{}          -> Bool
False
    TyStruct{}       -> Bool
False
    TyUserDefined{}  -> Bool
False
    NonNullParam Node (Lexeme Text)
ty  -> Node (Lexeme Text) -> Bool
isPointer Node (Lexeme Text)
ty
    NullableParam Node (Lexeme Text)
ty -> Node (Lexeme Text) -> Bool
isPointer Node (Lexeme Text)
ty
    NodeF (Lexeme Text) (Node (Lexeme Text))
_                -> [Char] -> Bool
forall a. HasCallStack => [Char] -> a
error ([Char] -> Bool) -> [Char] -> Bool
forall a b. (a -> b) -> a -> b
$ Node (Lexeme Text) -> [Char]
forall a. Show a => a -> [Char]
show Node (Lexeme Text)
x


-- | Extract the name of a function, possibly inside an attribute node.
--
-- Non-function nodes result in 'Nothing'.
functionName :: Show a => Node (Lexeme a) -> Maybe a
functionName :: Node (Lexeme a) -> Maybe a
functionName (Fix (FunctionPrototype Node (Lexeme a)
_ (L AlexPosn
_ LexemeClass
_ a
name) [Node (Lexeme a)]
_)) = a -> Maybe a
forall a. a -> Maybe a
Just a
name
functionName (Fix (FunctionDecl Scope
_ Node (Lexeme a)
proto  ))             = Node (Lexeme a) -> Maybe a
forall a. Show a => Node (Lexeme a) -> Maybe a
functionName Node (Lexeme a)
proto
functionName (Fix (FunctionDefn Scope
_ Node (Lexeme a)
proto Node (Lexeme a)
_))             = Node (Lexeme a) -> Maybe a
forall a. Show a => Node (Lexeme a) -> Maybe a
functionName Node (Lexeme a)
proto
functionName (Fix (AttrPrintf Lexeme a
_ Lexeme a
_ Node (Lexeme a)
entity))              = Node (Lexeme a) -> Maybe a
forall a. Show a => Node (Lexeme a) -> Maybe a
functionName Node (Lexeme a)
entity
functionName (Fix (NonNull [Lexeme a]
_ [Lexeme a]
_ Node (Lexeme a)
entity))                 = Node (Lexeme a) -> Maybe a
forall a. Show a => Node (Lexeme a) -> Maybe a
functionName Node (Lexeme a)
entity
functionName Node (Lexeme a)
_                                          = Maybe a
forall a. Maybe a
Nothing


-- Semantic equality: nodes are the same, except for source locations.
semEq :: Node (Lexeme Text) -> Node (Lexeme Text) -> Bool
semEq :: Node (Lexeme Text) -> Node (Lexeme Text) -> Bool
semEq Node (Lexeme Text)
a Node (Lexeme Text)
b = Node (Lexeme Text) -> Node (Lexeme Text)
removeSloc Node (Lexeme Text)
a Node (Lexeme Text) -> Node (Lexeme Text) -> Bool
forall a. Eq a => a -> a -> Bool
== Node (Lexeme Text) -> Node (Lexeme Text)
removeSloc Node (Lexeme Text)
b


-- Don't apply the linter to certain files.
skip :: [FilePath] -> (FilePath, [Node (Lexeme Text)]) -> (FilePath, [Node (Lexeme Text)])
skip :: [[Char]]
-> ([Char], [Node (Lexeme Text)]) -> ([Char], [Node (Lexeme Text)])
skip [[Char]]
fps ([Char]
fp, [Node (Lexeme Text)]
_) | ([Char] -> Bool) -> [[Char]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ([Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`List.isSuffixOf` [Char]
fp) [[Char]]
fps = ([Char]
fp, [])
skip [[Char]]
_ ([Char], [Node (Lexeme Text)])
tu        = ([Char], [Node (Lexeme Text)])
tu

warn :: (HasDiagnosticsRich diags CimplePos, HasDiagnosticInfo at CimplePos) => FilePath -> at -> Text -> DiagnosticsT diags ()
warn :: [Char] -> at -> Text -> DiagnosticsT diags ()
warn [Char]
file at
at Text
msg = [Char] -> at -> Doc AnsiStyle -> DiagnosticsT diags ()
forall diags at.
(HasDiagnosticsRich diags CimplePos,
 HasDiagnosticInfo at CimplePos) =>
[Char] -> at -> Doc AnsiStyle -> DiagnosticsT diags ()
warnDoc [Char]
file at
at (Text -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty Text
msg)

warnDoc :: (HasDiagnosticsRich diags CimplePos, HasDiagnosticInfo at CimplePos) => FilePath -> at -> Doc AnsiStyle -> DiagnosticsT diags ()
warnDoc :: [Char] -> at -> Doc AnsiStyle -> DiagnosticsT diags ()
warnDoc [Char]
file at
at Doc AnsiStyle
doc =
    let (CimplePos
pos, Int
len) = [Char] -> at -> (CimplePos, Int)
forall at pos.
HasDiagnosticInfo at pos =>
[Char] -> at -> (pos, Int)
getDiagnosticInfo [Char]
file at
at
    in Diagnostic CimplePos -> DiagnosticsT diags ()
forall diags pos.
HasDiagnosticsRich diags pos =>
Diagnostic pos -> DiagnosticsT diags ()
warnRich (Diagnostic CimplePos -> DiagnosticsT diags ())
-> Diagnostic CimplePos -> DiagnosticsT diags ()
forall a b. (a -> b) -> a -> b
$ 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 CimplePos
pos Int
len DiagnosticLevel
WarningLevel Doc AnsiStyle
doc Maybe Text
forall a. Maybe a
Nothing [] []

backticks :: Doc ann -> Doc ann
backticks :: Doc ann -> Doc ann
backticks Doc ann
d = Char -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Char
'`' Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
d Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Char -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Char
'`'

dquotes :: Doc ann -> Doc ann
dquotes :: Doc ann -> Doc ann
dquotes Doc ann
d = Char -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Char
'"' Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
d Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Char -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Char
'"'

(>+>) :: Monad m => (t -> m ()) -> (t -> m ()) -> t -> m ()
>+> :: (t -> m ()) -> (t -> m ()) -> t -> m ()
(>+>) t -> m ()
f t -> m ()
g t
x = t -> m ()
f t
x m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> t -> m ()
g t
x