tokstyle 0.0.5 → 0.0.6
raw patch · 29 files changed
+454/−1871 lines, 29 filesdep +cimpledep −arraydep −compactdep −language-cdep ~base
Dependencies added: cimple
Dependencies removed: array, compact, language-c
Dependency ranges changed: base
Files
- src/Tokstyle/C.hs +0/−72
- src/Tokstyle/C/Naming.hs +0/−78
- src/Tokstyle/Cimple/AST.hs +0/−175
- src/Tokstyle/Cimple/Analysis.hs +28/−6
- src/Tokstyle/Cimple/Analysis/DeclaredOnce.hs +46/−0
- src/Tokstyle/Cimple/Analysis/DeclsHaveDefns.hs +59/−0
- src/Tokstyle/Cimple/Analysis/DocComments.hs +69/−0
- src/Tokstyle/Cimple/Analysis/ForLoops.hs +29/−0
- src/Tokstyle/Cimple/Analysis/FuncPrototypes.hs +24/−0
- src/Tokstyle/Cimple/Analysis/FuncScopes.hs +6/−6
- src/Tokstyle/Cimple/Analysis/GlobalFuncs.hs +8/−8
- src/Tokstyle/Cimple/Analysis/LoggerCalls.hs +12/−13
- src/Tokstyle/Cimple/Analysis/LoggerNoEscapes.hs +16/−15
- src/Tokstyle/Cimple/Analysis/VarUnusedInScope.hs +60/−0
- src/Tokstyle/Cimple/Diagnostics.hs +0/−17
- src/Tokstyle/Cimple/IO.hs +0/−51
- src/Tokstyle/Cimple/Lexer.x +0/−280
- src/Tokstyle/Cimple/Parser.y +0/−608
- src/Tokstyle/Cimple/Tokens.hs +0/−114
- src/Tokstyle/Cimple/TraverseAst.hs +0/−208
- src/Tokstyle/Result.hs +7/−4
- src/Tokstyle/Sources.hs +0/−65
- test/Tokstyle/Cimple/AnalysisSpec.hs +46/−0
- test/Tokstyle/CimpleSpec.hs +0/−53
- tokstyle.cabal +18/−44
- tools/check-c.hs +0/−7
- tools/check-cimple.hs +20/−16
- tools/dump-tokens.hs +0/−23
- web/Tokstyle/App.hs +6/−8
− src/Tokstyle/C.hs
@@ -1,72 +0,0 @@-module Tokstyle.C (main) where--import Control.Applicative ((<$>))-import qualified Data.List as List-import Language.C (CError, CTranslUnit,- ErrorInfo (..), InputStream,- errorInfo, initPos, parseC,- posFile, posRow)-import Language.C.Analysis.AstAnalysis (analyseAST)-import Language.C.Analysis.SemRep (GlobalDecls)-import Language.C.Analysis.TravMonad (runTrav_)-import Language.C.System.GCC (newGCC)-import Language.C.System.Preprocess (rawCppArgs, runPreprocessor)-import System.Environment (getArgs)--import qualified Tokstyle.C.Naming-import Tokstyle.Result---phaseCpp :: FilePath -> IO InputStream-phaseCpp file = do- cppArgs <- (["-std=c99", "-U__BLOCKS__", "-D_VA_LIST", "-D_Nonnull=", "-D_Nullable=", "-D__attribute__(x)="] ++) <$> getArgs- result <- runPreprocessor (newGCC "gcc") $ rawCppArgs cppArgs file- case result of- Left err -> fail $ show err- Right ok -> return ok---phaseParse :: FilePath -> InputStream -> Result CTranslUnit-phaseParse file preprocessed =- case parseC preprocessed (initPos file) of- Left err -> fail $ show err- Right tu -> return tu---phaseAnalyse :: CTranslUnit -> Result (CTranslUnit, GlobalDecls, [CError])-phaseAnalyse tu =- case runTrav_ (analyseAST tu) of- Left errs -> fail $ concatMap show errs- Right (decls, cerr) -> return (tu, decls, cerr)---phaseCheck :: (CTranslUnit, GlobalDecls, [CError]) -> [CError]-phaseCheck (tu, decls, _cerr) =- --cerr ++- Tokstyle.C.Naming.check tu decls---printError :: ErrorInfo -> IO ()-printError (ErrorInfo _ pos msgs) =- putStrLn $ file ++ ":" ++ show line ++ ": " ++ List.intercalate "\n\t" msgs- where- file = posFile pos- line = posRow pos---showResult :: Result [CError] -> IO ()-showResult (Success cerr) = mapM_ (printError . errorInfo) cerr-showResult (Failure err) = putStr err---process :: FilePath -> IO ()-process path = do- preprocessed <- phaseCpp path- let analysis = phaseParse path preprocessed >>= phaseAnalyse- let results = phaseCheck <$> analysis- showResult results--main :: [String] -> IO ()-main sources = do- putStrLn "[=] preprocessing..."- mapM_ process sources
− src/Tokstyle/C/Naming.hs
@@ -1,78 +0,0 @@-{-# LANGUAGE LambdaCase #-}-module Tokstyle.C.Naming where--import qualified Data.Char as Char-import qualified Data.List as List-import Language.C-import Language.C.Analysis.SemRep-import Language.C.Data.Ident-import System.FilePath---getSrcFile :: NodeInfo -> String-getSrcFile (OnlyPos _ (pos, _) ) = posFile pos-getSrcFile (NodeInfo _ (pos, _) _) = posFile pos---toLower :: String -> String-toLower = map Char.toLower---check :: CTranslUnit -> GlobalDecls -> [CError]-check (CTranslUnit edecls ni) _ =- reverse . map (CError . mkNamingError) . foldl globalNamesCED [] $ edecls- where- srcFile = getSrcFile ni- namespace =- case toLower . takeFileName . dropExtension $ srcFile of- "audio" -> "ac"- "bwcontroller" -> "bwc"- "list" -> "bs_list"- "messenger" -> "m"- "network" -> "net"- "onion_announce" -> "onion"- "onion_client" -> "onion"- "ring_buffer" -> "rb"- "video" -> "vc"- ns -> ns-- mkNamingError (Ident name _ nameNi) =- mkErrorInfo LevelWarn name nameNi-- globalNamesCED names (CDeclExt cde) =- globalNamesCDE names cde- globalNamesCED names (CFDefExt cfde) =- globalNamesCFDE names cfde- globalNamesCED names _ = names-- globalNamesCFDE names (CFunDef declspec dcl _ _ _) =- if isGlobal declspec- then globalNamesCDR names dcl- else names-- globalNamesCDE names (CDecl declspec dcls _) =- if isGlobal declspec- then foldl globalNamesCDL names dcls- else names- globalNamesCDE names _ = names-- globalNamesCDL names (Just cdr, _, _) =- globalNamesCDR names cdr- globalNamesCDL names _ = names-- globalNamesCDR names (CDeclr (Just name) _ _ _ nameNi) =- if getSrcFile nameNi == srcFile- && (violatesNamingScheme . toLower . identToString $ name)- then name : names- else names- globalNamesCDR names _ = names-- isGlobal = all $ \case- CStorageSpec (CStatic _) -> False- _ -> True-- violatesNamingScheme name =- not (- name == namespace ||- List.isPrefixOf (namespace ++ "_") name- )
− src/Tokstyle/Cimple/AST.hs
@@ -1,175 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveTraversable #-}-module Tokstyle.Cimple.AST- ( AssignOp (..)- , BinaryOp (..)- , UnaryOp (..)- , LiteralType (..)- , Node (..)- , Scope (..)- ) where--import Data.Aeson (FromJSON, ToJSON)-import GHC.Generics (Generic)--data Node lexeme- -- Preprocessor- = PreprocInclude lexeme- | PreprocDefine lexeme- | PreprocDefineConst lexeme (Node lexeme)- | PreprocDefineMacro lexeme [Node lexeme] (Node lexeme)- | PreprocIf (Node lexeme) [Node lexeme] (Node lexeme)- | PreprocIfdef lexeme [Node lexeme] (Node lexeme)- | PreprocIfndef lexeme [Node lexeme] (Node lexeme)- | PreprocElse [Node lexeme]- | PreprocElif (Node lexeme) [Node lexeme] (Node lexeme)- | PreprocError lexeme- | PreprocUndef lexeme- | PreprocDefined lexeme- | PreprocScopedDefine (Node lexeme) [Node lexeme] (Node lexeme)- | MacroBodyStmt [Node lexeme]- | MacroBodyFunCall (Node lexeme)- | MacroParam lexeme- -- Comments- | Comment [Node lexeme]- | CommentBlock lexeme- | CommentWord lexeme- -- extern "C" block- | ExternC [Node lexeme]- -- Statements- | CompoundStmt [Node lexeme]- | Break- | Goto lexeme- | Continue- | Return (Maybe (Node lexeme))- | Switch (Node lexeme) [Node lexeme]- | IfStmt (Node lexeme) [Node lexeme] (Maybe (Node lexeme))- | ForStmt (Maybe (Node lexeme)) (Maybe (Node lexeme)) (Maybe (Node lexeme)) [Node lexeme]- | WhileStmt (Node lexeme) [Node lexeme]- | DoWhileStmt [Node lexeme] (Node lexeme)- | Case (Node lexeme) (Node lexeme)- | Default (Node lexeme)- | Label lexeme (Node lexeme)- -- Variable declarations- | VLA (Node lexeme) lexeme (Node lexeme)- | VarDecl (Node lexeme) [Node lexeme]- | Declarator (Node lexeme) (Maybe (Node lexeme))- | DeclSpecVar lexeme- | DeclSpecArray (Node lexeme) (Maybe (Node lexeme))- -- Expressions- | InitialiserList [Node lexeme]- | UnaryExpr UnaryOp (Node lexeme)- | BinaryExpr (Node lexeme) BinaryOp (Node lexeme)- | TernaryExpr (Node lexeme) (Node lexeme) (Node lexeme)- | AssignExpr (Node lexeme) AssignOp (Node lexeme)- | ParenExpr (Node lexeme)- | CastExpr (Node lexeme) (Node lexeme)- | SizeofExpr (Node lexeme)- | LiteralExpr LiteralType lexeme- | VarExpr lexeme- | MemberAccess (Node lexeme) lexeme- | PointerAccess (Node lexeme) lexeme- | ArrayAccess (Node lexeme) (Node lexeme)- | FunctionCall (Node lexeme) [Node lexeme]- | CommentExpr (Node lexeme) (Node lexeme)- -- Type definitions- | EnumDecl lexeme [Node lexeme] lexeme- | Enumerator lexeme (Maybe (Node lexeme))- | Typedef (Node lexeme) lexeme- | TypedefFunction (Node lexeme)- | Struct lexeme [Node lexeme]- | Union lexeme [Node lexeme]- | MemberDecl (Node lexeme) (Node lexeme) (Maybe lexeme)- | TyConst (Node lexeme)- | TyPointer (Node lexeme)- | TyStruct lexeme- | TyFunc lexeme- | TyStd lexeme- | TyUserDefined lexeme- -- Functions- | FunctionDecl Scope (Node lexeme)- | FunctionDefn Scope (Node lexeme) [Node lexeme]- | FunctionPrototype (Node lexeme) lexeme [Node lexeme]- | FunctionParam (Node lexeme) (Node lexeme)- | Ellipsis- -- Constants- | ConstDecl (Node lexeme) lexeme- | ConstDefn Scope (Node lexeme) lexeme (Node lexeme)- deriving (Show, Eq, Generic, Functor, Foldable, Traversable)--instance FromJSON lexeme => FromJSON (Node lexeme)-instance ToJSON lexeme => ToJSON (Node lexeme)--data AssignOp- = AopEq- | AopMul- | AopDiv- | AopPlus- | AopMinus- | AopBitAnd- | AopBitOr- | AopBitXor- | AopMod- | AopLsh- | AopRsh- deriving (Show, Eq, Generic)--instance FromJSON AssignOp-instance ToJSON AssignOp--data BinaryOp- = BopNe- | BopEq- | BopOr- | BopBitXor- | BopBitOr- | BopAnd- | BopBitAnd- | BopDiv- | BopMul- | BopMod- | BopPlus- | BopMinus- | BopLt- | BopLe- | BopLsh- | BopGt- | BopGe- | BopRsh- deriving (Show, Eq, Generic)--instance FromJSON BinaryOp-instance ToJSON BinaryOp--data UnaryOp- = UopNot- | UopNeg- | UopMinus- | UopAddress- | UopDeref- | UopIncr- | UopDecr- deriving (Show, Eq, Generic)--instance FromJSON UnaryOp-instance ToJSON UnaryOp--data LiteralType- = Char- | Int- | Bool- | String- | ConstId- deriving (Show, Eq, Generic)--instance FromJSON LiteralType-instance ToJSON LiteralType--data Scope- = Global- | Static- deriving (Show, Eq, Generic)--instance FromJSON Scope-instance ToJSON Scope
src/Tokstyle/Cimple/Analysis.hs view
@@ -1,18 +1,40 @@-module Tokstyle.Cimple.Analysis (analyse) where+module Tokstyle.Cimple.Analysis+ ( analyse+ , analyseGlobal+ ) where import Data.Text (Text)-import Tokstyle.Cimple.AST (Node (..))-import Tokstyle.Cimple.Lexer (Lexeme)+import Language.Cimple (Lexeme, Node (..)) +import qualified Tokstyle.Cimple.Analysis.ForLoops as ForLoops+import qualified Tokstyle.Cimple.Analysis.FuncPrototypes as FuncPrototypes import qualified Tokstyle.Cimple.Analysis.FuncScopes as FuncScopes import qualified Tokstyle.Cimple.Analysis.GlobalFuncs as GlobalFuncs import qualified Tokstyle.Cimple.Analysis.LoggerCalls as LoggerCalls import qualified Tokstyle.Cimple.Analysis.LoggerNoEscapes as LoggerNoEscapes+--import qualified Tokstyle.Cimple.Analysis.VarUnusedInScope as VarUnusedInScope -analyse :: FilePath -> [Node (Lexeme Text)] -> [Text]-analyse file ast = concatMap (\f -> f file ast)- [ FuncScopes.analyse+import qualified Tokstyle.Cimple.Analysis.DeclaredOnce as DeclaredOnce+import qualified Tokstyle.Cimple.Analysis.DeclsHaveDefns as DeclsHaveDefns+import qualified Tokstyle.Cimple.Analysis.DocComments as DocComments+++type TranslationUnit = (FilePath, [Node () (Lexeme Text)])++analyse :: TranslationUnit -> [Text]+analyse tu = concatMap ($ tu)+ [ ForLoops.analyse+ , FuncPrototypes.analyse+ , FuncScopes.analyse , GlobalFuncs.analyse , LoggerCalls.analyse , LoggerNoEscapes.analyse+ --, VarUnusedInScope.analyse+ ]++analyseGlobal :: [TranslationUnit] -> [Text]+analyseGlobal tus = concatMap ($ tus)+ [ DeclaredOnce.analyse+ , DeclsHaveDefns.analyse+ , DocComments.analyse ]
+ src/Tokstyle/Cimple/Analysis/DeclaredOnce.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StrictData #-}+module Tokstyle.Cimple.Analysis.DeclaredOnce (analyse) where++import qualified Control.Monad.State.Lazy as State+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Text (Text)+import Language.Cimple (AstActions, Lexeme (..),+ LexemeClass (..), Node (..),+ defaultActions, doNode,+ traverseAst)+import Language.Cimple.Diagnostics (HasDiagnostics (..), warn)+++data Linter = Linter+ { diags :: [Text]+ , decls :: Map Text (FilePath, Lexeme Text)+ }++empty :: Linter+empty = Linter [] Map.empty++instance HasDiagnostics Linter where+ addDiagnostic diag l@Linter{diags} = l{diags = addDiagnostic diag diags}+++linter :: AstActions Linter+linter = defaultActions+ { doNode = \file node act ->+ case node of+ FunctionDecl _ (FunctionPrototype _ fn@(L _ IdVar fname) _) _ -> do+ l@Linter{decls} <- State.get+ case Map.lookup fname decls of+ Nothing -> State.put l{decls = Map.insert fname (file, fn) decls }+ Just (file', fn') -> do+ warn file' fn' $ "duplicate declaration of function `" <> fname <> "'"+ warn file fn $ "function `" <> fname <> "' also declared here"+ act++ _ -> act+ }++analyse :: [(FilePath, [Node () (Lexeme Text)])] -> [Text]+analyse tus = reverse . diags $ State.execState (traverseAst linter tus) empty
+ src/Tokstyle/Cimple/Analysis/DeclsHaveDefns.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StrictData #-}+module Tokstyle.Cimple.Analysis.DeclsHaveDefns (analyse) where++import qualified Control.Monad.State.Lazy as State+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe (mapMaybe)+import Data.Text (Text)+import Language.Cimple (AstActions, Lexeme (..),+ LexemeClass (..), Node (..),+ defaultActions, doNode,+ traverseAst)+import qualified Language.Cimple.Diagnostics as Diagnostics+import System.FilePath (takeFileName)+++data DeclDefn = DeclDefn+ { decl :: Maybe (FilePath, Lexeme Text)+ , defn :: Maybe (FilePath, Lexeme Text)+ }+++collectPairs :: AstActions (Map Text DeclDefn)+collectPairs = defaultActions+ { doNode = \file node act ->+ case node of+ FunctionDecl _ (FunctionPrototype _ fn@(L _ IdVar fname) _) _ -> do+ State.modify $ \pairs ->+ case Map.lookup fname pairs of+ Nothing -> Map.insert fname (DeclDefn{ decl = Just (file, fn), defn = Nothing }) pairs+ Just dd -> Map.insert fname (dd { decl = Just (file, fn) }) pairs+ act++ FunctionDefn _ (FunctionPrototype _ fn@(L _ IdVar fname) _) _ -> do+ State.modify $ \pairs ->+ case Map.lookup fname pairs of+ Nothing -> Map.insert fname (DeclDefn{ decl = Nothing, defn = Just (file, fn) }) pairs+ Just dd -> Map.insert fname (dd { defn = Just (file, fn) }) pairs+ act++ _ -> act+ }++analyse :: [(FilePath, [Node () (Lexeme Text)])] -> [Text]+analyse =+ map makeDiagnostic+ . mapMaybe lacksDefn+ . Map.elems+ . flip State.execState Map.empty+ . traverseAst collectPairs+ . filter (not . (`elem` ["ccompat.h", "tox.h"]) . takeFileName . fst)+ where+ lacksDefn DeclDefn{decl, defn = Nothing} = decl+ lacksDefn _ = Nothing++ makeDiagnostic (file, fn@(L _ _ fname)) =+ Diagnostics.sloc file fn <> ": missing definition for `" <> fname <> "'"
+ src/Tokstyle/Cimple/Analysis/DocComments.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StrictData #-}+module Tokstyle.Cimple.Analysis.DocComments (analyse) where++import qualified Control.Monad.State.Lazy as State+import Data.Text (Text)+import qualified Data.Text as Text+import Language.Cimple (AlexPosn (..), AstActions,+ Lexeme (..), LexemeClass (..),+ Node (..), defaultActions, doNode,+ traverseAst)+import Language.Cimple.Diagnostics (HasDiagnostics (..), warn)+import qualified Language.Cimple.Diagnostics as Diagnostics+import Language.Cimple.Pretty (ppTranslationUnit)+++data Linter = Linter+ { diags :: [Text]+ , docs :: [(Text, (FilePath, Node () (Lexeme Text)))]+ }++empty :: Linter+empty = Linter [] []++instance HasDiagnostics Linter where+ addDiagnostic diag l@Linter{diags} = l{diags = addDiagnostic diag diags}+++linter :: AstActions Linter+linter = defaultActions+ { doNode = \file node act ->+ case node of+ Commented doc (FunctionDecl _ (FunctionPrototype _ (L _ IdVar fname) _) _) -> do+ checkCommentEquals file doc fname+ act++ Commented doc (FunctionDefn _ (FunctionPrototype _ (L _ IdVar fname) _) _) -> do+ checkCommentEquals file doc fname+ act++ {-+ Commented _ n -> do+ warn file node . Text.pack . show $ n+ act+ -}++ _ -> act+ }+ where+ tshow = Text.pack . show++ removeSloc :: Node a (Lexeme text) -> Node a (Lexeme text)+ removeSloc = fmap $ \(L _ c t) -> L (AlexPn 0 0 0) c t++ checkCommentEquals file doc fname = do+ l@Linter{docs} <- State.get+ case lookup fname docs of+ Nothing -> State.put l{docs = (fname, (file, doc)):docs}+ Just (_, doc') | removeSloc doc == removeSloc doc' -> return ()+ Just (file', doc') -> do+ warn file (Diagnostics.at doc) $ "comment on definition of `" <> fname+ <> "' does not match declaration:\n"+ <> tshow (ppTranslationUnit [doc])+ warn file' (Diagnostics.at doc') $ "mismatching comment found here:\n"+ <> tshow (ppTranslationUnit [doc'])++analyse :: [(FilePath, [Node () (Lexeme Text)])] -> [Text]+analyse = reverse . diags . flip State.execState empty . traverseAst linter . reverse
+ src/Tokstyle/Cimple/Analysis/ForLoops.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE OverloadedStrings #-}+module Tokstyle.Cimple.Analysis.ForLoops (analyse) where++import qualified Control.Monad.State.Lazy as State+import Data.Text (Text)+import qualified Data.Text as Text+import Language.Cimple (AssignOp (..), AstActions,+ Lexeme (..), Node (..),+ defaultActions, doNode,+ traverseAst)+import qualified Language.Cimple.Diagnostics as Diagnostics+++linter :: AstActions [Text]+linter = defaultActions+ { doNode = \file node act ->+ case node of+ ForStmt (VarDecl _ty (Declarator (DeclSpecVar _i) (Just _v))) _ _ _ -> act+ ForStmt (AssignExpr (VarExpr _i) AopEq _v) _ _ _ -> act+ ForStmt i _ _ _ -> do+ warn file node . Text.pack . show $ i+ act++ _ -> act+ }+ where warn file node = Diagnostics.warn file (Diagnostics.at node)++analyse :: (FilePath, [Node () (Lexeme Text)]) -> [Text]+analyse = reverse . flip State.execState [] . traverseAst linter
+ src/Tokstyle/Cimple/Analysis/FuncPrototypes.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE OverloadedStrings #-}+module Tokstyle.Cimple.Analysis.FuncPrototypes (analyse) where++import qualified Control.Monad.State.Lazy as State+import Data.Text (Text)+import Language.Cimple (AstActions, Lexeme, Node (..),+ defaultActions, doNode,+ traverseAst)+import qualified Language.Cimple.Diagnostics as Diagnostics+++linter :: AstActions [Text]+linter = defaultActions+ { doNode = \file node act ->+ case node of+ FunctionPrototype _ name [] -> do+ Diagnostics.warn file name "empty parameter list must be written as (void)"+ act++ _ -> act+ }++analyse :: (FilePath, [Node () (Lexeme Text)]) -> [Text]+analyse = reverse . flip State.execState [] . traverseAst linter
src/Tokstyle/Cimple/Analysis/FuncScopes.hs view
@@ -5,16 +5,16 @@ import qualified Control.Monad.State.Lazy as State import Data.Text (Text) import qualified Data.Text as Text-import Tokstyle.Cimple.AST (Node (..), Scope (..))-import Tokstyle.Cimple.Diagnostics (warn)-import Tokstyle.Cimple.Lexer (Lexeme (..), lexemeLine,+import Language.Cimple (Lexeme (..), Node (..),+ Scope (..), lexemeLine, lexemeText)+import Language.Cimple.Diagnostics (warn) -analyse :: FilePath -> [Node (Lexeme Text)] -> [Text]-analyse file ast = reverse $ snd $ State.runState (foldM go [] ast) []+analyse :: (FilePath, [Node a (Lexeme Text)]) -> [Text]+analyse (file, ast) = reverse $ snd $ State.runState (foldM go [] ast) [] where- go decls (FunctionDecl declScope (FunctionPrototype _ name _)) =+ go decls (FunctionDecl declScope (FunctionPrototype _ name _) _) = return $ (lexemeText name, (name, declScope)) : decls go decls (FunctionDefn defnScope (FunctionPrototype _ name _) _) = case lookup (lexemeText name) decls of
src/Tokstyle/Cimple/Analysis/GlobalFuncs.hs view
@@ -3,17 +3,17 @@ import qualified Control.Monad.State.Lazy as State import Data.Text (Text)+import Language.Cimple (Lexeme (..), Node (..),+ Scope (..), lexemeText)+import Language.Cimple.Diagnostics (warn) import System.FilePath (takeExtension)-import Tokstyle.Cimple.AST (Node (..), Scope (..))-import Tokstyle.Cimple.Diagnostics (warn)-import Tokstyle.Cimple.Lexer (Lexeme (..), lexemeText) -analyse :: FilePath -> [Node (Lexeme Text)] -> [Text]-analyse file _ | takeExtension file /= ".c" = []-analyse file ast = reverse $ snd $ State.runState (mapM go ast) []+analyse :: (FilePath, [Node a (Lexeme Text)]) -> [Text]+analyse (file, _) | takeExtension file /= ".c" = []+analyse (file, ast) = reverse $ State.execState (mapM go ast) [] where- go (FunctionDecl Global (FunctionPrototype _ name _)) =+ go (FunctionDecl Global (FunctionPrototype _ name _) _) = warn file name $- "global function `" <> lexemeText name <> "' defined in .c file"+ "global function `" <> lexemeText name <> "' declared in .c file" go _ = return ()
src/Tokstyle/Cimple/Analysis/LoggerCalls.hs view
@@ -1,20 +1,20 @@ {-# LANGUAGE OverloadedStrings #-} module Tokstyle.Cimple.Analysis.LoggerCalls (analyse) where -import Control.Monad.State.Lazy (State) import qualified Control.Monad.State.Lazy as State import Data.Text (Text) import qualified Data.Text as Text+import Language.Cimple (AstActions, Lexeme (..),+ LiteralType (String), Node (..),+ defaultActions, doNode,+ traverseAst)+import qualified Language.Cimple.Diagnostics as Diagnostics import System.FilePath (takeFileName)-import Tokstyle.Cimple.AST (LiteralType (String), Node (..))-import qualified Tokstyle.Cimple.Diagnostics as Diagnostics-import Tokstyle.Cimple.Lexer (Lexeme (..))-import Tokstyle.Cimple.TraverseAst -linter :: FilePath -> AstActions (State [Text]) Text-linter file = defaultActions- { doNode = \node act ->+linter :: AstActions [Text]+linter = defaultActions+ { doNode = \file node act -> case node of -- Ignore all function calls where the second argument is a string -- literal. If it's a logger call, it's a valid one.@@ -23,17 +23,16 @@ FunctionCall (LiteralExpr _ (L _ _ "LOGGER_ASSERT")) (_:_:LiteralExpr String _:_) -> act FunctionCall (LiteralExpr _ name@(L _ _ func)) _ | Text.isPrefixOf "LOGGER_" func -> do- warn name $ "logger call `" <> func <> "' has a non-literal format argument"+ Diagnostics.warn file name $ "logger call `" <> func <> "' has a non-literal format argument" act _ -> act }- where warn = Diagnostics.warn file -analyse :: FilePath -> [Node (Lexeme Text)] -> [Text]+analyse :: (FilePath, [Node () (Lexeme Text)]) -> [Text] -- Ignore logger.h, which contains a bunch of macros that call LOGGER functions -- with their (literal) arguments. We don't know that they are literals at this -- point, though.-analyse file _ | takeFileName file == "logger.h" = []-analyse file ast = reverse $ State.execState (traverseAst (linter file) ast) []+analyse (file, _) | takeFileName file == "logger.h" = []+analyse tu = reverse . flip State.execState [] . traverseAst linter $ tu
src/Tokstyle/Cimple/Analysis/LoggerNoEscapes.hs view
@@ -6,16 +6,17 @@ import qualified Control.Monad.State.Lazy as State import Data.Text (Text, isInfixOf) import qualified Data.Text as Text-import Tokstyle.Cimple.AST (LiteralType (String), Node (..))-import qualified Tokstyle.Cimple.Diagnostics as Diagnostics-import Tokstyle.Cimple.Lexer (Lexeme (..), lexemeText)-import Tokstyle.Cimple.TraverseAst+import Language.Cimple (AstActions, Lexeme (..),+ LiteralType (String), Node (..),+ defaultActions, doNode,+ lexemeText, traverseAst)+import qualified Language.Cimple.Diagnostics as Diagnostics -linter :: FilePath -> AstActions (State [Text]) Text-linter file = defaultActions- { doNode = \node act -> case node of- -- LOGGER_ASSERT has its format as the third parameter.+linter :: AstActions [Text]+linter = defaultActions+ { doNode = \file node act -> case node of+ -- LOGGER_ASSERT has its format as the third parameter. FunctionCall (LiteralExpr _ (L _ _ "LOGGER_ASSERT")) (_ : _ : LiteralExpr String fmt : _) -> do checkFormat file fmt@@ -33,13 +34,13 @@ checkFormat :: FilePath -> Lexeme Text -> State [Text] () checkFormat file fmt =- when ("\\" `isInfixOf` text)- $ Diagnostics.warn file fmt- $ "logger format "- <> text- <> " contains escape sequences (newlines, tabs, or escaped quotes)"+ when ("\\" `isInfixOf` text) $+ Diagnostics.warn file fmt $+ "logger format "+ <> text+ <> " contains escape sequences (newlines, tabs, or escaped quotes)" where text = lexemeText fmt -analyse :: FilePath -> [Node (Lexeme Text)] -> [Text]-analyse file ast = reverse $ State.execState (traverseAst (linter file) ast) []+analyse :: (FilePath, [Node () (Lexeme Text)]) -> [Text]+analyse = reverse . flip State.execState [] . traverseAst linter
+ src/Tokstyle/Cimple/Analysis/VarUnusedInScope.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+module Tokstyle.Cimple.Analysis.VarUnusedInScope (analyse) where++import Control.Monad.State.Lazy (State)+import qualified Control.Monad.State.Lazy as State+import Data.Text (Text)+import qualified Data.Text as Text+import Language.Cimple (AstActions, Lexeme (..),+ Node (..), defaultActions, doNode,+ traverseAst)+import Language.Cimple.Diagnostics (HasDiagnostics (..), at, warn)+++data Linter = Linter+ { diags :: [Text]+ , scope :: [Text]+ , stack :: [[Text]]+ }++empty :: Linter+empty = Linter [] [] []++instance HasDiagnostics Linter where+ addDiagnostic diag l@Linter{diags} = l{diags = addDiagnostic diag diags}+++pushScope :: State Linter ()+pushScope = State.modify $ \l@Linter{scope, stack} -> l+ { scope = []+ , stack = scope:stack+ }++popScope :: State Linter [Text]+popScope = do+ l@Linter{stack} <- State.get+ case stack of+ [] -> return []+ scope:rest -> State.put l{stack = rest} >> return scope+++linter :: AstActions Linter+linter = defaultActions+ { doNode = \file node act ->+ case node of+ FunctionDefn _ (FunctionPrototype _ _ _) _ -> do+ pushScope+ r <- act+ _ <- popScope+ return r++ ForStmt{} -> do+ warn file (at node) $ Text.pack $ show node+ act++ _ -> act+ }++analyse :: (FilePath, [Node () (Lexeme Text)]) -> [Text]+analyse = reverse . diags . flip State.execState empty . traverseAst linter
− src/Tokstyle/Cimple/Diagnostics.hs
@@ -1,17 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Tokstyle.Cimple.Diagnostics (Diagnostics, warn) where--import Control.Monad.State.Lazy (State)-import qualified Control.Monad.State.Lazy as State-import Data.Text (Text)-import qualified Data.Text as Text-import Tokstyle.Cimple.Lexer (Lexeme (..), lexemeLine)--type Diagnostics a = State [Text] a--warn :: FilePath -> Lexeme Text -> Text -> Diagnostics ()-warn file l w = do- diags <- State.get- State.put $ diag : diags- where- diag = Text.pack file <> ":" <> Text.pack (show (lexemeLine l)) <> ": " <> w
− src/Tokstyle/Cimple/IO.hs
@@ -1,51 +0,0 @@-module Tokstyle.Cimple.IO- ( parseFile- , parseText- ) where--import Control.Monad.State.Lazy (State, get, put, runState)-import qualified Data.ByteString as BS-import qualified Data.Compact as Compact-import Data.Map.Strict (Map)-import qualified Data.Map.Strict as Map-import Data.Text (Text)-import qualified Data.Text as Text-import qualified Data.Text.Encoding as Text-import Tokstyle.Cimple.AST (Node (..))-import Tokstyle.Cimple.Lexer (Lexeme, runAlex)-import Tokstyle.Cimple.Parser (parseCimple)---type CompactState a = State (Map String Text) a--cacheText :: String -> CompactState Text-cacheText s = do- m <- get- case Map.lookup s m of- Nothing -> do- let text = Text.pack s- put $ Map.insert s text m- return text- Just text ->- return text---process :: [Node (Lexeme String)] -> IO [Node (Lexeme Text)]-process stringAst = do- let (textAst, _) = runState (mapM (mapM (mapM cacheText)) stringAst) Map.empty- Compact.getCompact <$> Compact.compactWithSharing textAst---parseText :: Text -> IO (Either String [Node (Lexeme Text)])-parseText contents =- mapM process res- where- res :: Either String [Node (Lexeme String)]- res = runAlex (Text.unpack contents) parseCimple---parseFile :: FilePath -> IO (Either String [Node (Lexeme Text)])-parseFile source = do- putStrLn $ "Processing " ++ source- contents <- Text.decodeUtf8 <$> BS.readFile source- parseText contents
− src/Tokstyle/Cimple/Lexer.x
@@ -1,280 +0,0 @@-{-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE StandaloneDeriving #-}-module Tokstyle.Cimple.Lexer- ( Alex- , AlexPosn (..)- , alexError- , alexScanTokens- , alexMonadScan- , Lexeme (..)- , lexemeClass- , lexemePosn- , lexemeText- , lexemeLine- , mkL- , runAlex- ) where--import Data.Aeson (FromJSON, ToJSON)-import GHC.Generics (Generic)-import Tokstyle.Cimple.Tokens (LexemeClass (..))-}--%wrapper "monad"--tokens :----- Ignore attributes.-<0> "GNU_PRINTF("[^\)]+")" ;-<0> "VLA" { mkL KwVla }---- Winapi functions.-<0> "WSAAddressToString" { mkL IdVar }-<0> "LocalFree" { mkL IdVar }-<0> "FormatMessageA" { mkL IdVar }-<0> "WSAGetLastError" { mkL IdVar }-<0> "WSAStringToAddress" { mkL IdVar }-<0> "WSAStartup" { mkL IdVar }-<0> "GetAdaptersInfo" { mkL IdVar }-<0> "WSACleanup" { mkL IdVar }-<0> "GetSystemTimeAsFileTime" { mkL IdVar }-<0> "GetTickCount" { mkL IdVar }---- Winapi struct members.-<0> "GatewayList" { mkL IdVar }-<0> "Next" { mkL IdVar }-<0> "IpAddress" { mkL IdVar }-<0> "IpAddressList" { mkL IdVar }-<0> "IpMask" { mkL IdVar }-<0> "String" { mkL IdVar }---- Windows typedefs.-<0> "DWORD" { mkL IdStdType }-<0> "FILETIME" { mkL IdStdType }-<0> "INT" { mkL IdStdType }-<0> "LPSOCKADDR" { mkL IdStdType }-<0> "IP_ADAPTER_INFO" { mkL IdStdType }-<0> "LPTSTR" { mkL IdStdType }-<0> "u_long" { mkL IdStdType }-<0> "WSADATA" { mkL IdStdType }---- System struct types.-<0> "addrinfo" { mkL IdSueType }-<0> "ifconf" { mkL IdSueType }-<0> "ifreq" { mkL IdSueType }-<0> "epoll_event" { mkL IdSueType }-<0> "in_addr" { mkL IdSueType }-<0> "in6_addr" { mkL IdSueType }-<0> "ipv6_mreq" { mkL IdSueType }-<0> "sockaddr" { mkL IdSueType }-<0> "sockaddr_in" { mkL IdSueType }-<0> "sockaddr_in6" { mkL IdSueType }-<0> "sockaddr_storage" { mkL IdSueType }-<0> "timespec" { mkL IdSueType }-<0> "timeval" { mkL IdSueType }---- Sodium constants.-<0,ppSC> "crypto_auth_"[A-Z][A-Z0-9_]* { mkL IdConst }-<0,ppSC> "crypto_box_"[A-Z][A-Z0-9_]* { mkL IdConst }-<0,ppSC> "crypto_hash_sha256_"[A-Z][A-Z0-9_]* { mkL IdConst }-<0,ppSC> "crypto_hash_sha512_"[A-Z][A-Z0-9_]* { mkL IdConst }-<0,ppSC> "crypto_sign_"[A-Z][A-Z0-9_]* { mkL IdConst }-<0> "MAX" { mkL IdConst }-<0> "MIN" { mkL IdConst }---- Standard C (ish).-<ppSC> defined { mkL PpDefined }-<ppSC> \"[^\"]*\" { mkL LitString }-<ppSC> \n { mkL PpNewline `andBegin` 0 }-<ppSC> \\\n ;-<ppSC> $white ;--<ignoreSC> "//!TOKSTYLE+" { start 0 }-<ignoreSC> [.\n] ;--<0,ppSC> "//"\n ;-<0,ppSC> "// ".* ;-<0> $white+ ;-<0> "//!TOKSTYLE-" { start ignoreSC }-<0> "/*""*"? { mkL CmtStart `andBegin` cmtSC }-<0> "/""*"+\n" *"\n" * :: ".+\n" *"\n" ""*"+"/" { mkL CmtBlock }-<0,cmtSC> \"(\\.|[^\"])*\" { mkL LitString }-<0> '(\\|[^'])*' { mkL LitChar }-<0> "<"[a-z0-9\.\/_]+">" { mkL LitSysInclude }-<0> "#if" { mkL PpIf `andBegin` ppSC }-<0> "#ifdef" { mkL PpIfdef }-<0> "#ifndef" { mkL PpIfndef }-<0> "#elif" { mkL PpElif `andBegin` ppSC }-<0> "#else" { mkL PpElse }-<0> "#endif" { mkL PpEndif }-<0> "#define" { mkL PpDefine `andBegin` ppSC }-<0> "#undef" { mkL PpUndef }-<0> "#include" { mkL PpInclude }-<0> "#error" { mkL PpError }-<0,ppSC> "break" { mkL KwBreak }-<0,ppSC> "case" { mkL KwCase }-<0,ppSC> "const" { mkL KwConst }-<0,ppSC> "continue" { mkL KwContinue }-<0,ppSC> "default" { mkL KwDefault }-<0,ppSC> "do" { mkL KwDo }-<0,ppSC> "else" { mkL KwElse }-<0,ppSC> "enum" { mkL KwEnum }-<0,ppSC> "extern" { mkL KwExtern }-<0,ppSC> "for" { mkL KwFor }-<0,ppSC> "goto" { mkL KwGoto }-<0,ppSC> "if" { mkL KwIf }-<0,ppSC> "return" { mkL KwReturn }-<0,ppSC> "sizeof" { mkL KwSizeof }-<0,ppSC> "static" { mkL KwStatic }-<0,ppSC> "struct" { mkL KwStruct }-<0,ppSC> "switch" { mkL KwSwitch }-<0,ppSC> "typedef" { mkL KwTypedef }-<0,ppSC> "union" { mkL KwUnion }-<0,ppSC> "void" { mkL KwVoid }-<0,ppSC> "while" { mkL KwWhile }-<0,ppSC> "bool" { mkL IdStdType }-<0,ppSC> "char" { mkL IdStdType }-<0,ppSC> "double" { mkL IdStdType }-<0,ppSC> "float" { mkL IdStdType }-<0,ppSC> "int" { mkL IdStdType }-<0,ppSC> "long int" { mkL IdStdType }-<0,ppSC> "long signed int" { mkL IdStdType }-<0,ppSC> "long" { mkL IdStdType }-<0,ppSC> "signed int" { mkL IdStdType }-<0,ppSC> "unsigned int" { mkL IdStdType }-<0,ppSC> "unsigned long" { mkL IdStdType }-<0,ppSC> "unsigned" { mkL IdStdType }-<0,ppSC> "va_list" { mkL IdStdType }-<0,ppSC> "false" { mkL LitFalse }-<0,ppSC> "true" { mkL LitTrue }-<0,ppSC> "__func__" { mkL IdVar }-<0,ppSC> "__"[a-zA-Z]+"__"? { mkL IdConst }-<0,ppSC> [A-Z][A-Z0-9_]{1,2} { mkL IdSueType }-<0,ppSC> _*[A-Z][A-Z0-9_]* { mkL IdConst }-<0,ppSC> [A-Z][A-Za-z0-9_]*[a-z][A-Za-z0-9_]* { mkL IdSueType }-<0,ppSC> [a-z][a-z0-9_]*_t { mkL IdStdType }-<0,ppSC> [a-z][a-z0-9_]*_cb { mkL IdFuncType }-<0,ppSC> [a-z][A-Za-z0-9_]* { mkL IdVar }-<0,ppSC,cmtSC> [0-9]+[LU]* { mkL LitInteger }-<0,ppSC> [0-9]+"."[0-9]+f? { mkL LitInteger }-<0,ppSC> 0x[0-9a-fA-F]+[LU]* { mkL LitInteger }-<0,ppSC,cmtSC> "=" { mkL PctEq }-<0,ppSC> "==" { mkL PctEqEq }-<0,ppSC> "&" { mkL PctAmpersand }-<0,ppSC> "&&" { mkL PctAmpersandAmpersand }-<0,ppSC> "&=" { mkL PctAmpersandEq }-<0,ppSC> "->" { mkL PctArrow }-<0,ppSC,cmtSC> "," { mkL PctComma }-<0,ppSC,cmtSC> "+" { mkL PctPlus }-<0,ppSC> "++" { mkL PctPlusPlus }-<0,ppSC> "+=" { mkL PctPlusEq }-<0,ppSC,cmtSC> "-" { mkL PctMinus }-<0,ppSC> "--" { mkL PctMinusMinus }-<0,ppSC> "-=" { mkL PctMinusEq }-<0,ppSC> "~" { mkL PctTilde }-<0,ppSC,cmtSC> "/" { mkL PctSlash }-<0,ppSC> "/=" { mkL PctSlashEq }-<0,ppSC,cmtSC> "." { mkL PctPeriod }-<0,ppSC> "..." { mkL PctEllipsis }-<0,ppSC> "%" { mkL PctPercent }-<0,ppSC> "%=" { mkL PctPercentEq }-<0,ppSC,cmtSC> ";" { mkL PctSemicolon }-<0,ppSC,cmtSC> ":" { mkL PctColon }-<0,ppSC,cmtSC> "<" { mkL PctLess }-<0,ppSC> "<<" { mkL PctLessLess }-<0,ppSC> "<<=" { mkL PctLessLessEq }-<0,ppSC> "<=" { mkL PctLessEq }-<0,ppSC,cmtSC> ">" { mkL PctGreater }-<0,ppSC> ">>" { mkL PctGreaterGreater }-<0,ppSC> ">>=" { mkL PctGreaterGreaterEq }-<0,ppSC> ">=" { mkL PctGreaterEq }-<0,ppSC> "|" { mkL PctPipe }-<0,ppSC> "||" { mkL PctPipePipe }-<0,ppSC> "|=" { mkL PctPipeEq }-<0,ppSC> "[" { mkL PctLBrack }-<0,ppSC> "]" { mkL PctRBrack }-<0,ppSC> "{" { mkL PctLBrace }-<0,ppSC> "}" { mkL PctRBrace }-<0,ppSC,cmtSC> "(" { mkL PctLParen }-<0,ppSC,cmtSC> ")" { mkL PctRParen }-<0,ppSC,cmtSC> "?" { mkL PctQMark }-<0,ppSC,cmtSC> "!" { mkL PctEMark }-<0,ppSC> "!=" { mkL PctEMarkEq }-<0,ppSC> "*" { mkL PctAsterisk }-<0,ppSC> "*=" { mkL PctAsteriskEq }-<0,ppSC> "^" { mkL PctCaret }-<0,ppSC> "^=" { mkL PctCaretEq }---- Comments.-<cmtSC> "Copyright ©" { mkL CmtSpdxCopyright }-<cmtSC> "SPDX-License-Identifier:" { mkL CmtSpdxLicense }-<cmtSC> "GPL-3.0-or-later" { mkL CmtWord }-<cmtSC> "TODO("[^\)]+"):" { mkL CmtWord }-<cmtSC> [@\\][a-z]+ { mkL CmtWord }-<cmtSC> "*"[A-Za-z][A-Za-z0-9_']*"*" { mkL CmtWord }-<cmtSC> [A-Za-z][A-Za-z0-9_']* { mkL CmtWord }-<cmtSC> "#"[0-9]+ { mkL CmtWord }-<cmtSC> "http://"[^ ]+ { mkL CmtWord }-<cmtSC> [0-9]+"%" { mkL LitInteger }-<cmtSC> "<code>" { mkL CmtCode `andBegin` codeSC }-<cmtSC> "`"[^`]+"`" { mkL CmtCode }-<cmtSC> "*/" { mkL CmtEnd `andBegin` 0 }-<cmtSC> \n" "+"*/" { mkL CmtEnd `andBegin` 0 }-<cmtSC,codeSC> \n" "+"*" { mkL PpNewline }-<cmtSC,codeSC> \n { mkL PpNewline }-<cmtSC> " "+ ;---- <code></code> blocks in comments.-<codeSC> "</code>" { mkL CmtCode `andBegin` cmtSC }-<codeSC> [^\<]+ { mkL CmtCode }---- Error handling.-<0,ppSC,cmtSC,codeSC> . { mkL Error }--{-deriving instance Generic AlexPosn-instance FromJSON AlexPosn-instance ToJSON AlexPosn--data Lexeme text = L AlexPosn LexemeClass text- deriving (Show, Eq, Generic, Functor, Foldable, Traversable)--instance FromJSON text => FromJSON (Lexeme text)-instance ToJSON text => ToJSON (Lexeme text)--mkL :: Applicative m => LexemeClass -> AlexInput -> Int -> m (Lexeme String)-mkL c (p, _, _, str) len = pure $ L p c (take len str)--lexemePosn :: Lexeme text -> AlexPosn-lexemePosn (L p _ _) = p--lexemeClass :: Lexeme text -> LexemeClass-lexemeClass (L _ c _) = c--lexemeText :: Lexeme text -> text-lexemeText (L _ _ s) = s--lexemeLine :: Lexeme text -> Int-lexemeLine (L (AlexPn _ l _) _ _) = l--start :: Int -> AlexInput -> Int -> Alex (Lexeme String)-start code _ _ = do- alexSetStartCode code- alexMonadScan--alexEOF :: Alex (Lexeme String)-alexEOF = return (L (AlexPn 0 0 0) Eof "")--alexScanTokens :: String -> Either String [Lexeme String]-alexScanTokens str =- runAlex str $ loop []- where- loop toks = do- tok@(L _ cl _) <- alexMonadScan- if cl == Eof- then return $ reverse toks- else loop $! (tok:toks)-}
− src/Tokstyle/Cimple/Parser.y
@@ -1,608 +0,0 @@-{-module Tokstyle.Cimple.Parser where--import Tokstyle.Cimple.AST (AssignOp (..), BinaryOp (..),- LiteralType (..), Node (..),- Scope (..), UnaryOp (..))-import Tokstyle.Cimple.Lexer (Alex, AlexPosn, Lexeme (..), alexError,- alexMonadScan)-import Tokstyle.Cimple.Tokens (LexemeClass (..))-}---- Conflict between (static) FunctionDecl and (static) ConstDecl.-%expect 2--%name parseCimple-%error {parseError}-%lexer {lexwrap} {L _ Eof _}-%monad {Alex}-%tokentype {Lexeme String}-%token- ID_CONST { L _ IdConst _ }- ID_FUNC_TYPE { L _ IdFuncType _ }- ID_STD_TYPE { L _ IdStdType _ }- ID_SUE_TYPE { L _ IdSueType _ }- ID_VAR { L _ IdVar _ }- break { L _ KwBreak _ }- case { L _ KwCase _ }- const { L _ KwConst _ }- continue { L _ KwContinue _ }- default { L _ KwDefault _ }- do { L _ KwDo _ }- else { L _ KwElse _ }- enum { L _ KwEnum _ }- extern { L _ KwExtern _ }- for { L _ KwFor _ }- goto { L _ KwGoto _ }- if { L _ KwIf _ }- return { L _ KwReturn _ }- sizeof { L _ KwSizeof _ }- static { L _ KwStatic _ }- struct { L _ KwStruct _ }- switch { L _ KwSwitch _ }- typedef { L _ KwTypedef _ }- union { L _ KwUnion _ }- VLA { L _ KwVla _ }- void { L _ KwVoid _ }- while { L _ KwWhile _ }- LIT_CHAR { L _ LitChar _ }- LIT_FALSE { L _ LitFalse _ }- LIT_TRUE { L _ LitTrue _ }- LIT_INTEGER { L _ LitInteger _ }- LIT_STRING { L _ LitString _ }- LIT_SYS_INCLUDE { L _ LitSysInclude _ }- '&' { L _ PctAmpersand _ }- '&&' { L _ PctAmpersandAmpersand _ }- '&=' { L _ PctAmpersandEq _ }- '->' { L _ PctArrow _ }- '*' { L _ PctAsterisk _ }- '*=' { L _ PctAsteriskEq _ }- '^' { L _ PctCaret _ }- '^=' { L _ PctCaretEq _ }- ':' { L _ PctColon _ }- ',' { L _ PctComma _ }- '!' { L _ PctEMark _ }- '!=' { L _ PctEMarkEq _ }- '=' { L _ PctEq _ }- '==' { L _ PctEqEq _ }- '>' { L _ PctGreater _ }- '>=' { L _ PctGreaterEq _ }- '>>' { L _ PctGreaterGreater _ }- '>>=' { L _ PctGreaterGreaterEq _ }- '{' { L _ PctLBrace _ }- '[' { L _ PctLBrack _ }- '<' { L _ PctLess _ }- '<=' { L _ PctLessEq _ }- '<<' { L _ PctLessLess _ }- '<<=' { L _ PctLessLessEq _ }- '(' { L _ PctLParen _ }- '-' { L _ PctMinus _ }- '-=' { L _ PctMinusEq _ }- '--' { L _ PctMinusMinus _ }- '%' { L _ PctPercent _ }- '%=' { L _ PctPercentEq _ }- '.' { L _ PctPeriod _ }- '...' { L _ PctEllipsis _ }- '|' { L _ PctPipe _ }- '|=' { L _ PctPipeEq _ }- '||' { L _ PctPipePipe _ }- '+' { L _ PctPlus _ }- '+=' { L _ PctPlusEq _ }- '++' { L _ PctPlusPlus _ }- '?' { L _ PctQMark _ }- '}' { L _ PctRBrace _ }- ']' { L _ PctRBrack _ }- ')' { L _ PctRParen _ }- ';' { L _ PctSemicolon _ }- '/' { L _ PctSlash _ }- '/=' { L _ PctSlashEq _ }- '~' { L _ PctTilde _ }- 'defined' { L _ PpDefined _ }- '#define' { L _ PpDefine _ }- '#elif' { L _ PpElif _ }- '#else' { L _ PpElse _ }- '#endif' { L _ PpEndif _ }- '#error' { L _ PpError _ }- '#if' { L _ PpIf _ }- '#ifdef' { L _ PpIfdef _ }- '#ifndef' { L _ PpIfndef _ }- '#include' { L _ PpInclude _ }- '#undef' { L _ PpUndef _ }- '\n' { L _ PpNewline _ }- '/**/' { L _ CmtBlock _ }- '/*' { L _ CmtStart _ }- '*/' { L _ CmtEnd _ }- 'Copyright' { L _ CmtSpdxCopyright _ }- 'License' { L _ CmtSpdxLicense _ }- COMMENT_CODE { L _ CmtCode _ }- COMMENT_WORD { L _ CmtWord _ }--%left ','-%right '=' '+=' '-=' '*=' '/=' '%=' '<<=' '>>=' '&=' '^=' '|='-%right '?' ':'-%left '||'-%left '&&'-%left '|'-%left '^'-%left '&'-%left '!=' '=='-%left '<' '<=' '>' '>='-%left '<<' '>>'-%left '+' '-'-%left '*' '/' '%'-%right CAST ADDRESS NEG DEREF sizeof '!' '~' '++' '--'-%left '->' '.' '(' '['--%%--TranslationUnit :: { [StringNode] }-TranslationUnit-: ToplevelDecls { reverse $1 }--ToplevelDecls :: { [StringNode] }-ToplevelDecls-: ToplevelDecl { [$1] }-| ToplevelDecls ToplevelDecl { $2 : $1 }--ToplevelDecl :: { StringNode }-ToplevelDecl-: PreprocIfdef(ToplevelDecls) { $1 }-| PreprocIf(ToplevelDecls) { $1 }-| PreprocInclude { $1 }-| PreprocDefine { $1 }-| PreprocUndef { $1 }-| PreprocError { $1 }-| ExternC { $1 }-| TypedefDecl { $1 }-| AggregateDecl { $1 }-| EnumDecl { $1 }-| FunctionDecl { $1 }-| ConstDecl { $1 }-| Comment { $1 }--Comment :: { StringNode }-Comment-: '/*' CommentBody '*/' { Comment (reverse $2) }-| '/**/' { CommentBlock $1 }--CommentBody :: { [StringNode] }-CommentBody-: CommentWord { [$1] }-| CommentBody CommentWord { $2 : $1 }--CommentWord :: { StringNode }-CommentWord-: COMMENT_WORD { CommentWord $1 }-| COMMENT_CODE { CommentWord $1 }-| LIT_INTEGER { CommentWord $1 }-| LIT_STRING { CommentWord $1 }-| 'Copyright' { CommentWord $1 }-| 'License' { CommentWord $1 }-| '.' { CommentWord $1 }-| '?' { CommentWord $1 }-| '!' { CommentWord $1 }-| ',' { CommentWord $1 }-| ';' { CommentWord $1 }-| ':' { CommentWord $1 }-| '(' { CommentWord $1 }-| ')' { CommentWord $1 }-| '<' { CommentWord $1 }-| '>' { CommentWord $1 }-| '/' { CommentWord $1 }-| '+' { CommentWord $1 }-| '-' { CommentWord $1 }-| '=' { CommentWord $1 }-| '\n' { CommentWord $1 }--PreprocIfdef(decls)-: '#ifdef' ID_CONST decls PreprocElse(decls) '#endif' { PreprocIfdef $2 $3 $4 }-| '#ifndef' ID_CONST decls PreprocElse(decls) '#endif' { PreprocIfndef $2 $3 $4 }--PreprocIf(decls)-: '#if' ConstExpr '\n' decls PreprocElse(decls) '#endif' { PreprocIf $2 $4 $5 }--PreprocElse(decls)-: { PreprocElse [] }-| '#else' decls { PreprocElse $2 }-| '#elif' ConstExpr '\n' decls PreprocElse(decls) { PreprocElif $2 $4 $5 }--PreprocError :: { StringNode }-PreprocError-: '#error' LIT_STRING { PreprocError $2 }--PreprocInclude :: { StringNode }-PreprocInclude-: '#include' LIT_STRING { PreprocInclude $2 }-| '#include' LIT_SYS_INCLUDE { PreprocInclude $2 }--PreprocDefine :: { StringNode }-PreprocDefine-: '#define' ID_CONST '\n' { PreprocDefine $2 }-| '#define' ID_CONST ConstExpr '\n' { PreprocDefineConst $2 $3 }-| '#define' ID_CONST MacroParamList MacroBody '\n' { PreprocDefineMacro $2 $3 $4 }--PreprocUndef :: { StringNode }-PreprocUndef-: '#undef' ID_CONST { PreprocUndef $2 }--ConstExpr :: { StringNode }-ConstExpr-: LiteralExpr { $1 }-| 'defined' '(' ID_CONST ')' { PreprocDefined $3 }-| PureExpr(ConstExpr) { $1 }--MacroParamList :: { [StringNode] }-MacroParamList-: '(' ')' { [] }-| '(' MacroParams ')' { reverse $2 }-| '(' MacroParams ',' '...' ')' { reverse $ Ellipsis : $2 }--MacroParams :: { [StringNode] }-MacroParams-: MacroParam { [$1] }-| MacroParams ',' MacroParam { $3 : $1 }--MacroParam :: { StringNode }-MacroParam-: ID_VAR { MacroParam $1 }--MacroBody :: { StringNode }-MacroBody-: do CompoundStmt while '(' LIT_INTEGER ')' {% macroBodyStmt $2 $5 }-| FunctionCall { MacroBodyFunCall $1 }--ExternC :: { StringNode }-ExternC-: '#ifdef' ID_CONST- extern LIT_STRING '{'- '#endif'- ToplevelDecls- '#ifdef' ID_CONST- '}'- '#endif' {% externC $2 $4 $7 $9 }--Stmts :: { [StringNode] }-Stmts-: Stmt { [$1] }-| Stmts Stmt { $2 : $1 }--Stmt :: { StringNode }-Stmt-: PreprocIfdef(Stmts) { $1 }-| PreprocIf(Stmts) { $1 }-| PreprocDefine Stmts PreprocUndef { PreprocScopedDefine $1 $2 $3 }-| LabelStmt { $1 }-| DeclStmt { $1 }-| CompoundStmt { CompoundStmt $1 }-| IfStmt { $1 }-| ForStmt { $1 }-| WhileStmt { $1 }-| DoWhileStmt { $1 }-| AssignExpr ';' { $1 }-| ExprStmt ';' { $1 }-| FunctionCall ';' { $1 }-| break ';' { Break }-| goto ID_CONST ';' { Goto $2 }-| continue ';' { Continue }-| return ';' { Return Nothing }-| return Expr ';' { Return (Just $2) }-| switch '(' Expr ')' CompoundStmt { Switch $3 $5 }-| Comment { $1 }--IfStmt :: { StringNode }-IfStmt-: if '(' Expr ')' CompoundStmt { IfStmt $3 $5 Nothing }-| if '(' Expr ')' CompoundStmt else IfStmt { IfStmt $3 $5 (Just $7) }-| if '(' Expr ')' CompoundStmt else CompoundStmt { IfStmt $3 $5 (Just (CompoundStmt $7)) }--ForStmt :: { StringNode }-ForStmt-: for '(' ForInit Opt(Expr) ';' Opt(ForNext) ')' CompoundStmt { ForStmt $3 $4 $6 $8 }--ForInit :: { Maybe (StringNode) }-ForInit-: ';' { Nothing }-| AssignExpr ';' { Just $1 }-| SingleVarDecl { Just $1 }--ForNext :: { StringNode }-ForNext-: ExprStmt { $1 }-| AssignExpr { $1 }--Opt(x)-: { Nothing }-| x { Just $1 }--WhileStmt :: { StringNode }-WhileStmt-: while '(' Expr ')' CompoundStmt { WhileStmt $3 $5 }--DoWhileStmt :: { StringNode }-DoWhileStmt-: do CompoundStmt while '(' Expr ')' ';' { DoWhileStmt $2 $5 }--LabelStmt :: { StringNode }-LabelStmt-: case Expr ':' Stmt { Case $2 $4 }-| default ':' Stmt { Default $3 }-| ID_CONST ':' Stmt { Label $1 $3 }--DeclStmt :: { StringNode }-DeclStmt-: VarDecl { $1 }-| VLA '(' Type ',' ID_VAR ',' Expr ')' ';' { VLA $3 $5 $7 }--SingleVarDecl :: { StringNode }-SingleVarDecl-: QualType Declarator ';' { VarDecl $1 [$2] }--VarDecl :: { StringNode }-VarDecl-: QualType Declarators ';' { VarDecl $1 (reverse $2) }--Declarators :: { [StringNode] }-Declarators-: Declarator { [$1] }-| Declarators ',' Declarator { $3 : $1 }--Declarator :: { StringNode }-Declarator-: DeclSpec(Expr) '=' InitialiserExpr { Declarator $1 (Just $3) }-| DeclSpec(Expr) { Declarator $1 Nothing }--InitialiserExpr :: { StringNode }-InitialiserExpr-: InitialiserList { InitialiserList $1 }-| Expr { $1 }--DeclSpec(expr)-: ID_VAR { DeclSpecVar $1 }-| DeclSpec(expr) '[' ']' { DeclSpecArray $1 Nothing }-| DeclSpec(expr) '[' expr ']' { DeclSpecArray $1 (Just $3) }--InitialiserList :: { [StringNode] }-InitialiserList-: '{' Initialisers '}' { reverse $2 }-| '{' Initialisers ',' '}' { reverse $2 }--Initialisers :: { [StringNode] }-Initialisers-: Initialiser { [$1] }-| Initialisers ',' Initialiser { $3 : $1 }--Initialiser :: { StringNode }-Initialiser-: Expr { $1 }-| InitialiserList { InitialiserList $1 }--CompoundStmt :: { [StringNode] }-CompoundStmt-: '{' Stmts '}' { $2 }--PureExpr(x)-: x '!=' x { BinaryExpr $1 BopNe $3 }-| x '==' x { BinaryExpr $1 BopEq $3 }-| x '||' x { BinaryExpr $1 BopOr $3 }-| x '^' x { BinaryExpr $1 BopBitXor $3 }-| x '|' x { BinaryExpr $1 BopBitOr $3 }-| x '&&' x { BinaryExpr $1 BopAnd $3 }-| x '&' x { BinaryExpr $1 BopBitAnd $3 }-| x '/' x { BinaryExpr $1 BopDiv $3 }-| x '*' x { BinaryExpr $1 BopMul $3 }-| x '%' x { BinaryExpr $1 BopMod $3 }-| x '+' x { BinaryExpr $1 BopPlus $3 }-| x '-' x { BinaryExpr $1 BopMinus $3 }-| x '<' x { BinaryExpr $1 BopLt $3 }-| x '<=' x { BinaryExpr $1 BopLe $3 }-| x '<<' x { BinaryExpr $1 BopLsh $3 }-| x '>' x { BinaryExpr $1 BopGt $3 }-| x '>=' x { BinaryExpr $1 BopGe $3 }-| x '>>' x { BinaryExpr $1 BopRsh $3 }-| x '?' x ':' x { TernaryExpr $1 $3 $5 }-| '(' x ')' { ParenExpr $2 }-| '!' x { UnaryExpr UopNot $2 }-| '~' x { UnaryExpr UopNeg $2 }-| '-' x %prec NEG { UnaryExpr UopMinus $2 }-| '&' x %prec ADDRESS { UnaryExpr UopAddress $2 }-| '(' QualType ')' x %prec CAST { CastExpr $2 $4 }-| sizeof '(' x ')' { SizeofExpr $3 }-| sizeof '(' Type ')' { SizeofExpr $3 }--LiteralExpr :: { StringNode }-LiteralExpr-: LIT_CHAR { LiteralExpr Char $1 }-| LIT_INTEGER { LiteralExpr Int $1 }-| LIT_FALSE { LiteralExpr Bool $1 }-| LIT_TRUE { LiteralExpr Bool $1 }-| LIT_STRING { LiteralExpr String $1 }-| ID_CONST { LiteralExpr ConstId $1 }--Expr :: { StringNode }-Expr-: LhsExpr { $1 }-| ExprStmt { $1 }-| LiteralExpr { $1 }-| FunctionCall { $1 }-| PureExpr(Expr) { $1 }--AssignExpr :: { StringNode }-AssignExpr-: LhsExpr AssignOperator Expr { AssignExpr $1 $2 $3 }--AssignOperator :: { AssignOp }-AssignOperator-: '=' { AopEq }-| '*=' { AopMul }-| '/=' { AopDiv }-| '+=' { AopPlus }-| '-=' { AopMinus }-| '&=' { AopBitAnd }-| '|=' { AopBitOr }-| '^=' { AopBitXor }-| '%=' { AopMod }-| '<<=' { AopLsh }-| '>>=' { AopRsh }--ExprStmt :: { StringNode }-ExprStmt-: '++' Expr { UnaryExpr UopIncr $2 }-| '--' Expr { UnaryExpr UopDecr $2 }--LhsExpr :: { StringNode }-LhsExpr-: ID_VAR { VarExpr $1 }-| '*' LhsExpr %prec DEREF { UnaryExpr UopDeref $2 }-| LhsExpr '.' ID_VAR { MemberAccess $1 $3 }-| LhsExpr '->' ID_VAR { PointerAccess $1 $3 }-| LhsExpr '[' Expr ']' { ArrayAccess $1 $3 }--FunctionCall :: { StringNode }-FunctionCall-: Expr ArgList { FunctionCall $1 $2 }--ArgList :: { [StringNode] }-ArgList-: '(' ')' { [] }-| '(' Args ')' { reverse $2 }--Args :: { [StringNode] }-Args-: Arg { [$1] }-| Args ',' Arg { $3 : $1 }--Arg :: { StringNode }-Arg-: Expr { $1 }-| Comment Expr { CommentExpr $1 $2 }--EnumDecl :: { StringNode }-EnumDecl-: typedef enum ID_SUE_TYPE EnumeratorList ID_SUE_TYPE ';' { EnumDecl $3 $4 $5 }--EnumeratorList :: { [StringNode] }-EnumeratorList-: '{' Enumerators '}' { $2 }--Enumerators :: { [StringNode] }-Enumerators-: Enumerator { [$1] }-| Enumerators Enumerator { $2 : $1 }--Enumerator :: { StringNode }-Enumerator-: ID_CONST ',' { Enumerator $1 Nothing }-| ID_CONST '=' ConstExpr ',' { Enumerator $1 (Just $3) }-| Comment { $1 }--AggregateDecl :: { StringNode }-AggregateDecl-: AggregateType ';' { $1 }-| typedef AggregateType ID_SUE_TYPE ';' { Typedef $2 $3 }--AggregateType :: { StringNode }-AggregateType-: struct ID_SUE_TYPE '{' MemberDecls '}' { Struct $2 $4 }-| union ID_SUE_TYPE '{' MemberDecls '}' { Union $2 $4 }--MemberDecls :: { [StringNode] }-MemberDecls-: MemberDecl { [$1] }-| MemberDecls MemberDecl { $2 : $1 }--MemberDecl :: { StringNode }-MemberDecl-: QualType DeclSpec(ConstExpr) ';' { MemberDecl $1 $2 Nothing }-| QualType DeclSpec(ConstExpr) ':' LIT_INTEGER ';' { MemberDecl $1 $2 (Just $4) }-| PreprocIfdef(MemberDecls) { $1 }-| Comment { $1 }--TypedefDecl :: { StringNode }-TypedefDecl-: typedef QualType ID_SUE_TYPE ';' { Typedef $2 $3 }-| typedef FunctionPrototype(ID_FUNC_TYPE) ';' { TypedefFunction $2 }--QualType :: { StringNode }-QualType-: Type { $1 }-| const Type { TyConst $2 }--Type :: { StringNode }-Type-: LeafType { $1 }-| Type '*' { TyPointer $1 }-| Type const { TyConst $1 }--LeafType :: { StringNode }-LeafType-: struct ID_SUE_TYPE { TyStruct $2 }-| void { TyStd $1 }-| ID_FUNC_TYPE { TyFunc $1 }-| ID_STD_TYPE { TyStd $1 }-| ID_SUE_TYPE { TyUserDefined $1 }--FunctionDecl :: { StringNode }-FunctionDecl-: FunctionDeclarator { $1 Global }-| static FunctionDeclarator { $2 Static }--FunctionDeclarator :: { Scope -> StringNode }-FunctionDeclarator-: FunctionPrototype(ID_VAR) ';' { \s -> FunctionDecl s $1 }-| FunctionPrototype(ID_VAR) CompoundStmt { \s -> FunctionDefn s $1 $2 }--FunctionPrototype(id)-: QualType id FunctionParamList { FunctionPrototype $1 $2 $3 }--FunctionParamList :: { [StringNode] }-FunctionParamList-: '(' void ')' { [] }-| '(' FunctionParams ')' { reverse $2 }-| '(' FunctionParams ',' '...' ')' { reverse $ Ellipsis : $2 }--FunctionParams :: { [StringNode] }-FunctionParams-: FunctionParam { [$1] }-| FunctionParams ',' FunctionParam { $3 : $1 }--FunctionParam :: { StringNode }-FunctionParam-: QualType DeclSpec(ConstExpr) { FunctionParam $1 $2 }--ConstDecl :: { StringNode }-ConstDecl-: extern const LeafType ID_VAR ';' { ConstDecl $3 $4 }-| const LeafType ID_VAR '=' InitialiserExpr ';' { ConstDefn Global $2 $3 $5 }-| static const LeafType ID_VAR '=' InitialiserExpr ';' { ConstDefn Static $3 $4 $6 }--{-type StringNode = Node (Lexeme String)--parseError :: Show text => Lexeme text -> Alex a-parseError token = alexError $ "Parse error near token: " <> show token--lexwrap :: (Lexeme String -> Alex a) -> Alex a-lexwrap = (alexMonadScan >>=)--externC- :: Lexeme String- -> Lexeme String- -> [StringNode]- -> Lexeme String- -> Alex StringNode-externC (L _ _ "__cplusplus") (L _ _ "\"C\"") decls (L _ _ "__cplusplus") =- return $ ExternC decls-externC _ lang _ _ =- alexError $ show lang- <> ": extern \"C\" declaration invalid (did you spell __cplusplus right?)"--macroBodyStmt- :: [StringNode]- -> Lexeme String- -> Alex StringNode-macroBodyStmt decls (L _ _ "0") =- return $ MacroBodyStmt decls-macroBodyStmt _ cond =- alexError $ show cond- <> ": macro do-while body must end in 'while (0)'"-}
− src/Tokstyle/Cimple/Tokens.hs
@@ -1,114 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-module Tokstyle.Cimple.Tokens- ( LexemeClass (..)- ) where--import Data.Aeson (FromJSON, ToJSON)-import GHC.Generics (Generic)--data LexemeClass- = IdConst- | IdFuncType- | IdStdType- | IdSueType- | IdVar- | KwBreak- | KwCase- | KwConst- | KwContinue- | KwDefault- | KwDo- | KwFor- | KwGoto- | KwIf- | KwElse- | KwEnum- | KwExtern- | KwReturn- | KwSizeof- | KwStatic- | KwStruct- | KwSwitch- | KwTypedef- | KwUnion- | KwVla- | KwVoid- | KwWhile- | LitFalse- | LitTrue- | LitChar- | LitInteger- | LitString- | LitSysInclude- | PctAmpersand- | PctAmpersandAmpersand- | PctAmpersandEq- | PctArrow- | PctAsterisk- | PctAsteriskEq- | PctCaret- | PctCaretEq- | PctColon- | PctComma- | PctEllipsis- | PctEMark- | PctEMarkEq- | PctEq- | PctEqEq- | PctGreater- | PctGreaterEq- | PctGreaterGreater- | PctGreaterGreaterEq- | PctLBrace- | PctLBrack- | PctLess- | PctLessEq- | PctLessLess- | PctLessLessEq- | PctLParen- | PctMinus- | PctMinusEq- | PctMinusMinus- | PctPeriod- | PctPercent- | PctPercentEq- | PctPipe- | PctPipeEq- | PctPipePipe- | PctPlus- | PctPlusEq- | PctPlusPlus- | PctQMark- | PctRBrace- | PctRBrack- | PctRParen- | PctSemicolon- | PctSlash- | PctSlashEq- | PctTilde- | PpDefine- | PpDefined- | PpElif- | PpElse- | PpEndif- | PpError- | PpIf- | PpIfdef- | PpIfndef- | PpInclude- | PpNewline- | PpUndef- | CmtBlock- | CmtStart- | CmtSpdxCopyright- | CmtSpdxLicense- | CmtCode- | CmtWord- | CmtEnd-- | Error- | Eof- deriving (Show, Eq, Generic, Ord)--instance FromJSON LexemeClass-instance ToJSON LexemeClass
− src/Tokstyle/Cimple/TraverseAst.hs
@@ -1,208 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE ScopedTypeVariables #-}-module Tokstyle.Cimple.TraverseAst- ( TraverseAst (..)- , AstActions (..)- , defaultActions- ) where--import Data.Text (Text)-import Tokstyle.Cimple.AST (Node (..))-import Tokstyle.Cimple.Lexer (Lexeme (..))--class TraverseAst a where- traverseAst :: Applicative f => AstActions f Text -> a -> f a--data AstActions f text = AstActions- { doNodes :: [Node (Lexeme text)] -> f [Node (Lexeme text)] -> f [Node (Lexeme text)]- , doNode :: Node (Lexeme text) -> f (Node (Lexeme text)) -> f (Node (Lexeme text))- , doLexeme :: Lexeme text -> f (Lexeme text) -> f (Lexeme text)- , doText :: text -> f text -> f text- }--instance TraverseAst a => TraverseAst (Maybe a) where- traverseAst _ Nothing = pure Nothing- traverseAst astActions (Just x) = Just <$> traverseAst astActions x--defaultActions :: Applicative f => AstActions f lexeme-defaultActions = AstActions- { doNodes = const id- , doNode = const id- , doLexeme = const id- , doText = const id- }--instance TraverseAst Text where- traverseAst :: forall f . Applicative f- => AstActions f Text -> Text -> f Text- traverseAst astActions = doText astActions <*> pure--instance TraverseAst (Lexeme Text) where- traverseAst :: forall f . Applicative f- => AstActions f Text -> Lexeme Text -> f (Lexeme Text)- traverseAst astActions = doLexeme astActions <*> \case- L p c s -> L p c <$> recurse s- where- recurse :: TraverseAst a => a -> f a- recurse = traverseAst astActions--instance TraverseAst (Node (Lexeme Text)) where- traverseAst :: forall f . Applicative f- => AstActions f Text -> Node (Lexeme Text) -> f (Node (Lexeme Text))- traverseAst astActions = doNode astActions <*> \case- PreprocInclude path ->- PreprocInclude <$> recurse path- PreprocDefine name ->- PreprocDefine <$> recurse name- PreprocDefineConst name value ->- PreprocDefineConst <$> recurse name <*> recurse value- PreprocDefineMacro name params body ->- PreprocDefineMacro <$> recurse name <*> recurse params <*> recurse body- PreprocIf cond thenDecls elseBranch ->- PreprocIf <$> recurse cond <*> recurse thenDecls <*> recurse elseBranch- PreprocIfdef name thenDecls elseBranch ->- PreprocIfdef <$> recurse name <*> recurse thenDecls <*> recurse elseBranch- PreprocIfndef name thenDecls elseBranch ->- PreprocIfndef <$> recurse name <*> recurse thenDecls <*> recurse elseBranch- PreprocElse decls ->- PreprocElse <$> recurse decls- PreprocElif cond decls elseBranch ->- PreprocElif <$> recurse cond <*> recurse decls <*> recurse elseBranch- PreprocError msg ->- PreprocError <$> recurse msg- PreprocUndef name ->- PreprocUndef <$> recurse name- PreprocDefined name ->- PreprocDefined <$> recurse name- PreprocScopedDefine define stmts undef ->- PreprocScopedDefine <$> recurse define <*> recurse stmts <*> recurse undef- MacroBodyStmt stmts ->- MacroBodyStmt <$> recurse stmts- MacroBodyFunCall expr ->- MacroBodyFunCall <$> recurse expr- MacroParam name ->- MacroParam <$> recurse name- Comment contents ->- Comment <$> recurse contents- CommentBlock comment ->- CommentBlock <$> recurse comment- CommentWord word ->- CommentWord <$> recurse word- ExternC decls ->- ExternC <$> recurse decls- CompoundStmt stmts ->- CompoundStmt <$> recurse stmts- Break ->- pure Break- Goto label ->- Goto <$> recurse label- Continue ->- pure Continue- Return value ->- Return <$> recurse value- Switch value cases ->- Switch <$> recurse value <*> recurse cases- IfStmt cond thenStmts elseStmt ->- IfStmt <$> recurse cond <*> recurse thenStmts <*> recurse elseStmt- ForStmt initStmt cond next stmts ->- ForStmt <$> recurse initStmt <*> recurse cond <*> recurse next <*> recurse stmts- WhileStmt cond stmts ->- WhileStmt <$> recurse cond <*> recurse stmts- DoWhileStmt stmts cond ->- DoWhileStmt <$> recurse stmts <*> recurse cond- Case value stmt ->- Case <$> recurse value <*> recurse stmt- Default stmt ->- Default <$> recurse stmt- Label label stmt ->- Label <$> recurse label <*> recurse stmt- VLA ty name size ->- VLA <$> recurse ty <*> recurse name <*> recurse size- VarDecl ty decls ->- VarDecl <$> recurse ty <*> recurse decls- Declarator spec value ->- Declarator <$> recurse spec <*> recurse value- DeclSpecVar name ->- DeclSpecVar <$> recurse name- DeclSpecArray spec size ->- DeclSpecArray <$> recurse spec <*> recurse size- InitialiserList values ->- InitialiserList <$> recurse values- UnaryExpr op expr ->- UnaryExpr op <$> recurse expr- BinaryExpr lhs op rhs ->- BinaryExpr <$> recurse lhs <*> pure op <*> recurse rhs- TernaryExpr cond thenExpr elseExpr ->- TernaryExpr <$> recurse cond <*> recurse thenExpr <*> recurse elseExpr- AssignExpr lhs op rhs ->- AssignExpr <$> recurse lhs <*> pure op <*> recurse rhs- ParenExpr expr ->- ParenExpr <$> recurse expr- CastExpr ty expr ->- CastExpr <$> recurse ty <*> recurse expr- SizeofExpr expr ->- SizeofExpr <$> recurse expr- LiteralExpr ty value ->- LiteralExpr ty <$> recurse value- VarExpr name ->- VarExpr <$> recurse name- MemberAccess name field ->- MemberAccess <$> recurse name <*> recurse field- PointerAccess name field ->- PointerAccess <$> recurse name <*> recurse field- ArrayAccess arr idx ->- ArrayAccess <$> recurse arr <*> recurse idx- FunctionCall callee args ->- FunctionCall <$> recurse callee <*> recurse args- CommentExpr comment expr ->- CommentExpr <$> recurse comment <*> recurse expr- EnumDecl name members tyName ->- EnumDecl <$> recurse name <*> recurse members <*> recurse tyName- Enumerator name value ->- Enumerator <$> recurse name <*> recurse value- Typedef ty name ->- Typedef <$> recurse ty <*> recurse name- TypedefFunction ty ->- TypedefFunction <$> recurse ty- Struct name members ->- Struct <$> recurse name <*> recurse members- Union name members ->- Union <$> recurse name <*> recurse members- MemberDecl ty decl width ->- MemberDecl <$> recurse ty <*> recurse decl <*> recurse width- TyConst ty ->- TyConst <$> recurse ty- TyPointer ty ->- TyPointer <$> recurse ty- TyStruct name ->- TyStruct <$> recurse name- TyFunc name ->- TyFunc <$> recurse name- TyStd name ->- TyStd <$> recurse name- TyUserDefined name ->- TyUserDefined <$> recurse name- FunctionDecl scope proto ->- FunctionDecl scope <$> recurse proto- FunctionDefn scope proto body ->- FunctionDefn scope <$> recurse proto <*> recurse body- FunctionPrototype ty name params ->- FunctionPrototype <$> recurse ty <*> recurse name <*> recurse params- FunctionParam ty decl ->- FunctionParam <$> recurse ty <*> recurse decl- Ellipsis ->- pure Ellipsis- ConstDecl ty name ->- ConstDecl <$> recurse ty <*> recurse name- ConstDefn scope ty name value ->- ConstDefn scope <$> recurse ty <*> recurse name <*> recurse value-- where- recurse :: TraverseAst a => a -> f a- recurse = traverseAst astActions--instance TraverseAst [Node (Lexeme Text)] where- traverseAst astActions = doNodes astActions <*>- traverse (traverseAst astActions)
src/Tokstyle/Result.hs view
@@ -1,11 +1,11 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE Safe #-}+{-# LANGUAGE StrictData #-} module Tokstyle.Result where -import Control.Applicative (Applicative (..))-import Control.DeepSeq (NFData)-import GHC.Generics (Generic)+import Control.DeepSeq (NFData)+import GHC.Generics (Generic) data Result a@@ -25,7 +25,10 @@ instance Monad Result where return = pure- fail = Failure Success x >>= f = f x Failure msg >>= _ = Failure msg+++instance MonadFail Result where+ fail = Failure
− src/Tokstyle/Sources.hs
@@ -1,65 +0,0 @@-module Tokstyle.Sources (sources) where--sources :: [String]-sources = map ("../c-toxcore/" ++)- [ "toxav/audio.c"- , "toxav/audio.h"- , "toxav/bwcontroller.c"- , "toxav/bwcontroller.h"- , "toxav/groupav.c"- , "toxav/groupav.h"- , "toxav/msi.c"- , "toxav/msi.h"- , "toxav/rtp.c"- , "toxav/rtp.h"- , "toxav/toxav.c"- , "toxav/toxav_old.c"- , "toxav/video.c"- , "toxav/video.h"- , "toxcore/DHT.c"- , "toxcore/DHT.h"- , "toxcore/LAN_discovery.c"- , "toxcore/LAN_discovery.h"- , "toxcore/Messenger.c"- , "toxcore/Messenger.h"- , "toxcore/TCP_client.c"- , "toxcore/TCP_client.h"- , "toxcore/TCP_connection.c"- , "toxcore/TCP_connection.h"- , "toxcore/TCP_server.c"- , "toxcore/TCP_server.h"- , "toxcore/crypto_core.c"- , "toxcore/crypto_core.h"- , "toxcore/friend_connection.c"- , "toxcore/friend_connection.h"- , "toxcore/friend_requests.c"- , "toxcore/friend_requests.h"- , "toxcore/group.c"- , "toxcore/group.h"- , "toxcore/list.c"- , "toxcore/list.h"- , "toxcore/logger.c"- , "toxcore/logger.h"- , "toxcore/mono_time.c"- , "toxcore/mono_time.h"- , "toxcore/network.c"- , "toxcore/network.h"- , "toxcore/net_crypto.c"- , "toxcore/net_crypto.h"- , "toxcore/onion.c"- , "toxcore/onion.h"- , "toxcore/onion_announce.c"- , "toxcore/onion_announce.h"- , "toxcore/onion_client.c"- , "toxcore/onion_client.h"- , "toxcore/ping.c"- , "toxcore/ping.h"- , "toxcore/ping_array.c"- {-, "toxcore/ping_array.h"-}- , "toxcore/state.c"- , "toxcore/state.h"- , "toxcore/tox.c"- {-, "toxcore/tox.h"-}- , "toxcore/util.c"- , "toxcore/util.h"- ]
+ test/Tokstyle/Cimple/AnalysisSpec.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE OverloadedStrings #-}+module Tokstyle.Cimple.AnalysisSpec where++import Test.Hspec (Spec, describe, it, shouldBe)++import Data.Text (Text)+import qualified Data.Text as Text+import Language.Cimple (Lexeme, Node)+import Language.Cimple.IO (parseText)+import Tokstyle.Cimple.Analysis (analyse)+++mustParse :: MonadFail m => [Text] -> m [Node () (Lexeme Text)]+mustParse code =+ case parseText $ Text.unlines code of+ Left err -> fail err+ Right ok -> return ok+++spec :: Spec+spec =+ describe "analyse" $ do+ it "should parse a simple function" $ do+ let Right ast = parseText "int a(void) { return 3; }"+ analyse ("test.c", ast) `shouldBe` []++ it "should give diagnostics on extern decls in .c files" $ do+ let Right ast = parseText "int a(void);"+ analyse ("test.c", ast)+ `shouldBe` ["test.c:1: global function `a' declared in .c file"]++ it "should not give diagnostics on extern decls in .h files" $ do+ let Right ast = parseText "int a(void);"+ analyse ("test.h", ast) `shouldBe` []++{-+ it "should give diagnostics on vars that can be reduced in scope" $ do+ ast <- mustParse+ [ "int a(void) {"+ , " int i;"+ , " for (i = 0; i < 10; ++i) { puts(\"hello!\"); }"+ , "}"+ ]+ analyse ("test.c", ast)+ `shouldBe` ["test.c:3: loop variable `i' should be declared in the for-init-decl"]+-}
− test/Tokstyle/CimpleSpec.hs
@@ -1,53 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Tokstyle.CimpleSpec where--import Test.Hspec (Spec, describe, it, shouldBe)--import Tokstyle.Cimple.AST (LiteralType (..), Node (..),- Scope (..))-import Tokstyle.Cimple.Lexer (AlexPosn (..), Lexeme (..), runAlex)-import Tokstyle.Cimple.Parser (parseCimple)-import Tokstyle.Cimple.Tokens (LexemeClass (..))---spec :: Spec-spec =- describe "C parsing" $ do- it "should parse a simple function" $ do- let ast = runAlex "int a(void) { return 3; }" parseCimple- ast `shouldBe` Right [- FunctionDefn- Global- (FunctionPrototype- (TyStd (L (AlexPn 0 1 1) IdStdType "int"))- (L (AlexPn 4 1 5) IdVar "a")- [])- [Return (Just (LiteralExpr Int (L (AlexPn 21 1 22) LitInteger "3")))]]-- it "should parse a type declaration" $ do- let ast = runAlex "typedef struct Foo { int x; } Foo;" parseCimple- ast `shouldBe` Right [- Typedef (- Struct (L (AlexPn 15 1 16) IdSueType "Foo")- [MemberDecl- (TyStd (L (AlexPn 21 1 22) IdStdType "int"))- (DeclSpecVar (L (AlexPn 25 1 26) IdVar "x"))- Nothing])- (L (AlexPn 30 1 31) IdSueType "Foo")]-- it "should parse a struct with bit fields" $ do- let ast = runAlex "typedef struct Foo { int x : 123; } Foo;" parseCimple- ast `shouldBe` Right [- Typedef (- Struct- (L (AlexPn 15 1 16) IdSueType "Foo")- [MemberDecl- (TyStd (L (AlexPn 21 1 22) IdStdType "int"))- (DeclSpecVar (L (AlexPn 25 1 26) IdVar "x"))- (Just (L (AlexPn 29 1 30) LitInteger "123"))])- (L (AlexPn 36 1 37) IdSueType "Foo")]-- it "should parse a comment" $ do- let ast = runAlex "/* hello */" parseCimple- ast `shouldBe` Right [- Comment [CommentWord (L (AlexPn 3 1 4) CmtWord "hello")]]
tokstyle.cabal view
@@ -1,5 +1,5 @@ name: tokstyle-version: 0.0.5+version: 0.0.6 synopsis: TokTok C code style checker description: TokTok C code style checker homepage: https://toktok.github.io/tokstyle@@ -18,22 +18,18 @@ library default-language: Haskell2010 exposed-modules:- Tokstyle.C- , Tokstyle.Cimple.Analysis+ Tokstyle.Cimple.Analysis+ other-modules:+ Tokstyle.Cimple.Analysis.DeclaredOnce+ , Tokstyle.Cimple.Analysis.DeclsHaveDefns+ , Tokstyle.Cimple.Analysis.DocComments+ , Tokstyle.Cimple.Analysis.ForLoops+ , Tokstyle.Cimple.Analysis.FuncPrototypes , Tokstyle.Cimple.Analysis.FuncScopes , Tokstyle.Cimple.Analysis.GlobalFuncs , Tokstyle.Cimple.Analysis.LoggerCalls , Tokstyle.Cimple.Analysis.LoggerNoEscapes- , Tokstyle.Cimple.AST- , Tokstyle.Cimple.Diagnostics- , Tokstyle.Cimple.IO- , Tokstyle.Cimple.Lexer- , Tokstyle.Cimple.Parser- , Tokstyle.Cimple.Tokens- , Tokstyle.Cimple.TraverseAst- , Tokstyle.Sources- other-modules:- Tokstyle.C.Naming+ , Tokstyle.Cimple.Analysis.VarUnusedInScope , Tokstyle.Result ghc-options: -Wall@@ -41,28 +37,15 @@ build-depends: base >= 4 && < 5 , aeson >= 0.8.1.0- , array , bytestring+ , cimple >= 0.0.5 , containers- , compact , deepseq , filepath , groom- , language-c , mtl , text -executable check-c- default-language: Haskell2010- hs-source-dirs:- tools- ghc-options:- -Wall- main-is: check-c.hs- build-depends:- base < 5- , tokstyle- executable check-cimple default-language: Haskell2010 hs-source-dirs:@@ -72,24 +55,10 @@ main-is: check-cimple.hs build-depends: base < 5+ , cimple , text , tokstyle- , text -executable dump-tokens- default-language: Haskell2010- hs-source-dirs:- tools- ghc-options:- -Wall- main-is: dump-tokens.hs- build-depends:- base < 5- , bytestring- , groom- , tokstyle- , text- executable webservice main-is: webservice.hs ghc-options:@@ -101,6 +70,7 @@ build-depends: base >= 4 && < 5 , bytestring+ , cimple , servant >= 0.5 , servant-server >= 0.5 , text@@ -116,11 +86,15 @@ hs-source-dirs: test main-is: testsuite.hs other-modules:- Tokstyle.CimpleSpec+ Tokstyle.Cimple.AnalysisSpec ghc-options: -Wall -fno-warn-unused-imports+ build-tool-depends:+ hspec-discover:hspec-discover build-depends: base < 5- , tokstyle+ , cimple , hspec+ , text+ , tokstyle
− tools/check-c.hs
@@ -1,7 +0,0 @@-module Main (main) where--import qualified Tokstyle.C-import Tokstyle.Sources (sources)--main :: IO ()-main = Tokstyle.C.main sources
tools/check-cimple.hs view
@@ -1,30 +1,34 @@+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Main (main) where +import Data.Text (Text) import qualified Data.Text.IO as Text+import Language.Cimple (Lexeme, Node)+import Language.Cimple.IO (parseFiles) import System.Environment (getArgs)-import Tokstyle.Cimple.IO (parseFile)-import Tokstyle.Sources (sources) -import Tokstyle.Cimple.Analysis (analyse)+import Tokstyle.Cimple.Analysis (analyse, analyseGlobal) -processFile :: FilePath -> IO ()-processFile file = do- ast <- parseFile file >>= getRight- case analyse file ast of+processAst :: [(FilePath, [Node () (Lexeme Text)])] -> IO ()+processAst tus = do+ report $ analyseGlobal tus+ mapM_ (report . analyse) tus+ where+ report = \case [] -> return () diags -> do mapM_ Text.putStrLn diags- fail $ "errors found in " <> file- where- getRight (Left err) = fail err- getRight (Right ok) = return ok+ fail "tokstyle violations detected" main :: IO ()-main = do- args <- getArgs- mapM_ processFile $ case args of- [] -> sources- _ -> args+main =+ getArgs+ >>= parseFiles+ >>= getRight+ >>= processAst+ where+ getRight (Left err) = fail err+ getRight (Right ok) = return ok
− tools/dump-tokens.hs
@@ -1,23 +0,0 @@-module Main (main) where--import qualified Data.ByteString as BS-import qualified Data.Text as Text-import qualified Data.Text.Encoding as Text-import System.Environment (getArgs)-import Text.Groom (groom)-import Tokstyle.Cimple.Lexer (alexScanTokens)--parseFile :: FilePath -> IO ()-parseFile source = do- putStrLn $ "Processing " ++ source- contents <- Text.unpack . Text.decodeUtf8 <$> BS.readFile source- case alexScanTokens contents of- Left err -> fail err- Right ok -> putStrLn $ groom ok--main :: IO ()-main = do- args <- getArgs- case args of- [src] -> parseFile src- _ -> fail "Usage: dump-tokens <file.c>"
web/Tokstyle/App.hs view
@@ -5,7 +5,6 @@ {-# LANGUAGE TypeOperators #-} module Tokstyle.App (app) where -import Control.Monad.IO.Class (liftIO) import Data.ByteString (ByteString) import Data.Text (Text) import qualified Data.Text as Text@@ -13,13 +12,12 @@ import qualified Data.Text.Encoding.Error as Text import Servant +import Language.Cimple (Lexeme, Node)+import qualified Language.Cimple.IO as Cimple import Tokstyle.Cimple.Analysis (analyse)-import Tokstyle.Cimple.AST (Node)-import qualified Tokstyle.Cimple.IO as Cimple-import Tokstyle.Cimple.Lexer (Lexeme) -type ParseResult = Either String [Node (Lexeme Text)]+type ParseResult = Either String [Node () (Lexeme Text)] -- API specification type TokstyleApi =@@ -47,10 +45,10 @@ where sourceH = return "https://github.com/TokTok/hs-tokstyle" - parseH = liftIO . Cimple.parseText . Text.decodeUtf8With Text.lenientDecode+ parseH = return . Cimple.parseText . Text.decodeUtf8With Text.lenientDecode - analyseH (_ , Left err) = return [Text.pack err]- analyseH (file, Right ast) = return $ analyse file ast+ analyseH (file, Left err) = return [Text.pack $ file <> ":" <> err]+ analyseH (file, Right ast) = return $ analyse (file, ast) -- Turn the server into a WAI app. 'serve' is provided by servant, -- more precisely by the Servant.Server module.