diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -10,8 +10,16 @@ Builds with Stack: [![CircleCI (all branches)](https://img.shields.io/circleci/project/github/mgajda/homplexity.svg)](https://circleci.com/gh/mgajda/homplexity) +Shippable CI: +[![Run Status](https://api.shippable.com/projects/5bf3f8b259e32e0700e952aa/badge?branch=master)](https://app.shippable.com/github/mgajda/homplexity) + +GitLab CI: +![Gitlab pipeline status](https://img.shields.io/gitlab/pipeline/migamake/homplexity.svg) + [![Hackage](https://img.shields.io/hackage/v/homplexity.svg)](https://hackage.haskell.org/package/homplexity) [![Hackage Dependencies](https://img.shields.io/hackage-deps/v/homplexity.svg?style=flat)](http://packdeps.haskellers.com/feed?needle=homplexity) + +If you just need latest static executable [it is always available here](https://gitlab.com/migamake/homplexity/-/jobs/artifacts/master/raw/bin/homplexity-cli?job=test_distribution). Official releases are on [Hackage](https://hackage.haskell.org/package/homplexity) diff --git a/app/Homplexity.hs b/app/Homplexity.hs --- a/app/Homplexity.hs +++ b/app/Homplexity.hs @@ -11,6 +11,7 @@ -- | Main module parsing inputs, and running analysis. module Main (main) where +import Control.Monad(when) import Data.Functor import Data.List import Data.Monoid @@ -71,7 +72,7 @@ concatMapM f = fmap concat . mapM f -- * Analysis --- | Analyze a set of modules. +-- | Analyze a single module. analyzeModule :: Module SrcLoc -> IO () analyzeModule = putStr . concatMap show @@ -96,12 +97,14 @@ main :: IO () main = do args <- $initHFlags "Homplexity - automatic analysis of Haskell code quality" - if null args - then do report ("Use Haskell source file or directory as an argument, " ++ - "or use --help to discover options.") + null args `when` do report ("Use Haskell source file or directory as an argument, " ++ + "or use --help to discover options.") + exitFailure + sums <- mapM processFile =<< concatMapM subTrees args + case length sums of + 0 -> do report "No valid Haskell source file found!" exitFailure - else do sums <- mapM processFile =<< concatMapM subTrees args - putStrLn $ unwords ["Correctly parsed", show $ length $ filter id sums, - "out of", show $ length sums, + n -> putStrLn $ unwords ["Correctly parsed", show $ length $ filter id sums, + "out of", show n, "input files."] diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,8 @@ Changelog ========= + 0.4.4.4 Nov 2018 + * Fix missing pattern for InfixMatch. + 0.4.4.3 Nov 2018 * Fixed wrong base bounds for tests. diff --git a/homplexity.cabal b/homplexity.cabal --- a/homplexity.cabal +++ b/homplexity.cabal @@ -1,5 +1,5 @@ name: homplexity -version: 0.4.4.3 +version: 0.4.4.4 synopsis: Haskell code quality tool description: Homplexity aims to measure code complexity, warning about fragments that might have higher defect probability @@ -57,7 +57,8 @@ deepseq >=1.3 && <1.7, containers >=0.3 && <0.7, template-haskell >=2.6 && <2.16, - cpphs >=1.5 && <1.21 + cpphs >=1.5 && <1.21, + pqueue other-extensions: FlexibleContexts, FlexibleInstances, UndecidableInstances, @@ -91,18 +92,26 @@ cpphs >=1.5 && <1.21, homplexity default-language: Haskell2010 - -- STATIC: ld-options: -static - -- STATIC: ghc-options: -fPIC + ld-options: -static + ghc-options: -fPIC test-suite Comments main-is: Comments.hs - hs-source-dirs: lib tests - other-modules: Language.Haskell.Homplexity.CodeFragment - Language.Haskell.Homplexity.Comments - Language.Haskell.Homplexity.SrcSlice + hs-source-dirs: tests + other-modules: TestSource type: exitcode-stdio-1.0 build-depends: base >=4.5 && <4.13, + containers >=0.3 && <0.7, + cpphs >=1.5 && <1.21, + deepseq >=1.3 && <1.7, + directory >=1.1 && <1.4, + filepath >=1.2 && <1.5, + uniplate >=1.4 && <1.7, haskell-src-exts >=1.18 && <1.21, - uniplate >=1.4 && <1.7 + hflags >=0.3 && <0.5, + template-haskell, + pqueue, + homplexity default-language: Haskell2010 + other-extensions: TemplateHaskell diff --git a/lib/Language/Haskell/Homplexity/Assessment.hs b/lib/Language/Haskell/Homplexity/Assessment.hs --- a/lib/Language/Haskell/Homplexity/Assessment.hs +++ b/lib/Language/Haskell/Homplexity/Assessment.hs @@ -9,10 +9,7 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} -- | Main module parsing inputs, and running analysis. -module Language.Haskell.Homplexity.Assessment ( - metrics - --, measureAllOccurs - ) where +module Language.Haskell.Homplexity.Assessment where import Data.Data import Data.Monoid diff --git a/lib/Language/Haskell/Homplexity/CodeFragment.hs b/lib/Language/Haskell/Homplexity/CodeFragment.hs --- a/lib/Language/Haskell/Homplexity/CodeFragment.hs +++ b/lib/Language/Haskell/Homplexity/CodeFragment.hs @@ -34,6 +34,7 @@ import Data.Generics.Uniplate.Data import Data.List import Data.Maybe +import Data.Monoid import Language.Haskell.Exts.Syntax import Language.Haskell.Exts.SrcLoc import Language.Haskell.Homplexity.SrcSlice @@ -115,7 +116,9 @@ (unName <$>) . take 1 -> functionNames, functionRhs, catMaybes -> functionBinds) = unzip4 $ map extract matches - extract (Match srcLoc name _ rhs binds) = (srcLoc, name, rhs, binds) + extract (Match srcLoc name _ rhs binds) = (srcLoc, name, rhs, binds) + extract (InfixMatch srcLoc _ name _ rhs binds) = (srcLoc, name, rhs, binds) + extract other = error $ "Undocumented constructor: " <> show other matchAST (PatBind (singleton -> functionLocations) pat (singleton -> functionRhs ) (maybeToList -> functionBinds )) = Just Function {..} diff --git a/lib/Language/Haskell/Homplexity/Comments.hs b/lib/Language/Haskell/Homplexity/Comments.hs --- a/lib/Language/Haskell/Homplexity/Comments.hs +++ b/lib/Language/Haskell/Homplexity/Comments.hs @@ -21,6 +21,8 @@ import Data.Function import Data.Functor import Data.List +import qualified Data.Map.Strict as Map +import qualified Data.PQueue.Max as Prio import Language.Haskell.Homplexity.CodeFragment import Language.Haskell.Homplexity.SrcSlice @@ -51,7 +53,7 @@ findCommentType txt = case (not . isSpace) `find` txt of Just '^' -> CommentsBefore Just '|' -> CommentsAfter - Just '*' -> CommentsInside -- since it comments out the group of declarations, it belongs to the containing object + Just '*' -> CommentsInside -- since it comments the group of declarations, it belongs to the containing object _ -> CommentsInside -- * Finding ranges of all commentable entities. @@ -59,8 +61,24 @@ data CommentSite = CommentSite { siteName :: String , siteSlice :: SrcSlice } - deriving (Show) + deriving (Eq, Show) +newtype Ends = End { siteEnded :: CommentSite } + deriving (Eq, Show) + +compareStarts :: CommentSite -> CommentSite -> Ordering +compareStarts = compare `on` start . siteSlice + +instance Ord Ends where + compare = compareEnds `on` siteEnded + +compareEnds :: CommentSite -> CommentSite -> Ordering +compareEnds = compare `on` end . siteSlice + +start, end :: SrcSlice -> (Int, Int) +start slice = (srcSpanStartColumn slice, srcSpanStartLine slice) +end slice = (srcSpanEndColumn slice, srcSpanEndLine slice) + -- | Find comment sites for entire program. commentable :: Data from => from -> [CommentSite] commentable code = ($ code) `concatMap` [slicesOf functionT @@ -85,13 +103,14 @@ loc (Right (siteSlice -> srcSpan)) = (srcSpan, False) elts = (Left <$> comments) ++ (Right <$> sites) +type Assignment = Map.Map CommentSite [CommentLink] {- -type Assignment = (CommentSite, [CommentLink]) -- | Assign comments to the commentable elements. assignComments :: [Either CommentLink CommentSite] + -> [Assignment] assignComments = foldr assign ([], [], [], []) where - assign :: ([Assignment], [Assignment], [CommentLink] + assign :: (Assignment, [Assignment], [CommentLink] assign (assigned, unclosed, commentingAfter) nextElt = case nextElt of Left (s@(CommentSite {})) -> (assigned, (s,commentingAfter):unclosed, []) diff --git a/lib/Language/Haskell/Homplexity/Message.hs b/lib/Language/Haskell/Homplexity/Message.hs --- a/lib/Language/Haskell/Homplexity/Message.hs +++ b/lib/Language/Haskell/Homplexity/Message.hs @@ -23,7 +23,6 @@ import Data.Foldable as Foldable import Data.Monoid #if __GLASGOW_HASKELL__ >= 800 --- MIN_VERSION_base(4,9,0) import Data.Semigroup #endif import Data.Sequence as Seq @@ -35,10 +34,9 @@ newtype Log = Log { unLog :: Seq Message } deriving(Monoid #if __GLASGOW_HASKELL__ >= 800 --- #if MIN_VERSION_base(4,9,0) ,Semigroup #endif - ) + ) instance NFData Log where rnf = rnf . unLog diff --git a/lib/Language/Haskell/Homplexity/Parse.hs b/lib/Language/Haskell/Homplexity/Parse.hs --- a/lib/Language/Haskell/Homplexity/Parse.hs +++ b/lib/Language/Haskell/Homplexity/Parse.hs @@ -5,7 +5,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} -- | Parsing of Haskell source files, and error reporting for unparsable files. -module Language.Haskell.Homplexity.Parse (parseSource) where +module Language.Haskell.Homplexity.Parse (parseSource, parseTest) where import Control.Exception as E import Data.Functor @@ -43,6 +43,15 @@ } } +-- | For use in test suite +parseTest :: String -> String -> IO (Module SrcLoc, [CommentLink]) +parseTest testId testSource = do + maybeParsed <- parseModuleWithComments (makeParseMode testId) + <$> runCpphs cppHsOptions testId testSource + case maybeParsed of + ParseOk (parsed, comments) -> return $ (getPointLoc <$> parsed, classifyComments comments) + other -> error $ show other + -- | Parse Haskell source file, using CppHs for preprocessing, -- and haskell-src-exts for parsing. -- @@ -51,7 +60,8 @@ parseSource inputFilename = do parseResult <- (do input <- readFile inputFilename - result <- parseModuleWithComments parseMode <$> runCpphs cppHsOptions inputFilename input + result <- parseModuleWithComments (makeParseMode inputFilename) + <$> runCpphs cppHsOptions inputFilename input evaluate result) `E.catch` handleException (ParseFailed thisFileLoc) case parseResult of @@ -65,17 +75,14 @@ where handleException helper (e :: SomeException) = return $ helper $ show e thisFileLoc = noLoc { srcFilename = inputFilename } - parseMode = ParseMode { - parseFilename = inputFilename - , baseLanguage = Haskell2010 - , extensions = myExtensions - , ignoreLanguagePragmas = False - , ignoreLinePragmas = False - , fixities = Just preludeFixities - , ignoreFunctionArity = False - } -{-putStrLn "COMMENTS:" - putStrLn $ unlines $ map show $ classifyComments comments - putStrLn "COMMENTABLES:" - putStrLn $ unlines $ map show $ commentable parsed-} - + +makeParseMode inputFilename = + ParseMode { + parseFilename = inputFilename + , baseLanguage = Haskell2010 + , extensions = myExtensions + , ignoreLanguagePragmas = False + , ignoreLinePragmas = False + , fixities = Just preludeFixities + , ignoreFunctionArity = False + } diff --git a/tests/Comments.hs b/tests/Comments.hs --- a/tests/Comments.hs +++ b/tests/Comments.hs @@ -3,6 +3,8 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} module Main ( main ) where @@ -15,8 +17,12 @@ import Language.Haskell.Exts import Language.Haskell.Homplexity.Comments +import Language.Haskell.Homplexity.Parse +import Language.Haskell.Homplexity.Metric --- * Tests for comments +import TestSource + +-- * Tests for comment types prop_commentsAfter :: Bool prop_commentsAfter = findCommentType " |" == CommentsAfter @@ -29,10 +35,26 @@ prop_commentsInside :: Bool prop_commentsInside = findCommentType " a" == CommentsInside +testSrc = do + (ast, comments) <- [tsrc| +module Amanitas where +-- | This is comment preceeding variable "a" +a=1 +b=2 +-- ^ This is comment following variable "b" +|] + putStrLn $ "Comments:\n" ++ show comments + assert (and [length comments == 2 + ]) $ + return () +--src = $withLocation "mystring" + -- Runs all unit tests. main :: IO () -main = assert (and [prop_commentsAfter - ,prop_commentsBefore - ,prop_commentsGroup - ,prop_commentsInside]) $ - return () +main = do + assert (and [prop_commentsAfter + ,prop_commentsBefore + ,prop_commentsGroup + ,prop_commentsInside]) $ + return () + testSrc diff --git a/tests/TestSource.hs b/tests/TestSource.hs new file mode 100644 --- /dev/null +++ b/tests/TestSource.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +-- | This module allows embedding source modules +-- Example: +-- +-- example1 :: IO ParseResult +-- example1 = [tsrc| +-- mod ule Main where +-- a=1 +-- |] +-- -- Filename and line where error happens will be correctly reported by Haskell parser. + +module TestSource(tsrc) where + +import Language.Haskell.TH +import Language.Haskell.TH.Quote + +import Language.Haskell.Homplexity.Parse(parseTest) + +-- | QuasiQuoter for a non-interpolating String +tsrc :: QuasiQuoter +tsrc = QuasiQuoter embedSource + (error "Cannot use tsrc as a pattern") + (error "Cannot use tsrc as a type" ) + (error "Cannot use tsrc as a dec" ) +embedSource :: String -> Q Exp +embedSource aString = do + loc <- location + let theString = linePragma loc ++ aString -- ^ Passes the information about correct location to the source + let testNote = "Test line " ++ showLine loc -- ^ Shown in case that LINE pragma is not parsed + [|parseTest testNote|] `appE` [| theString |] +-- parseTest :: FilePath -> String -> IO ParseResult + +linePragma :: Loc -> String +linePragma loc = concat ["{-# LINE ", showLine loc, " \"", loc_filename loc, "\" #-}\n"] + +showLine :: Loc -> String +showLine = show . fst . loc_start