diff --git a/Homplexity.hs b/Homplexity.hs --- a/Homplexity.hs +++ b/Homplexity.hs @@ -15,6 +15,7 @@ import Data.List import Data.Monoid +import Language.Haskell.Exts.SrcLoc import Language.Haskell.Exts.Syntax import Language.Haskell.Homplexity.Assessment import Language.Haskell.Homplexity.CodeFragment @@ -71,7 +72,7 @@ -- * Analysis -- | Analyze a set of modules. -analyzeModule :: Module -> IO () +analyzeModule :: Module SrcLoc -> IO () analyzeModule = putStr . concatMap show . extract flags_severity diff --git a/Language/Haskell/Homplexity/CodeFragment.hs b/Language/Haskell/Homplexity/CodeFragment.hs --- a/Language/Haskell/Homplexity/CodeFragment.hs +++ b/Language/Haskell/Homplexity/CodeFragment.hs @@ -39,12 +39,12 @@ import Language.Haskell.Homplexity.SrcSlice -- | Program -data Program = Program { allModules :: [Module] } +data Program = Program { allModules :: [Module SrcLoc] } deriving (Data, Typeable, Show) -- | Smart constructor for adding cross-references in the future. -program :: [Module] -> Program -program = Program +program :: [Module SrcLoc] -> Program +program = Program -- | Proxy for passing @Program@ type as an argument. programT :: Proxy Program @@ -55,8 +55,8 @@ data Function = Function { functionNames :: [String] , functionLocations :: [SrcLoc] - , functionRhs :: [Rhs] - , functionBinds :: [Binds] + , functionRhs :: [Rhs SrcLoc] + , functionBinds :: [Binds SrcLoc] } deriving (Data, Typeable, Show) @@ -67,8 +67,8 @@ -- ** Type signature of a function -- | Type alias for a type signature of a function as a @CodeFragment@ data TypeSignature = TypeSignature { loc :: SrcLoc - , identifiers :: [Name] - , theType :: Type } + , identifiers :: [Name SrcLoc] + , theType :: Type SrcLoc } deriving (Data, Typeable, Show) -- | Proxy for passing @Program@ type as an argument. @@ -104,35 +104,29 @@ fragmentLoc = getPointLoc . fragmentSlice -#if MIN_VERSION_haskell_src_exts(1,17,0) -getBinds = maybe [] singleton mergeBinds = catMaybes -#else -getBinds = singleton -mergeBids = id -#endif instance CodeFragment Function where - type AST Function = Decl - matchAST (FunBind matches) = Just + type AST Function = Decl SrcLoc + matchAST (FunBind _ matches) = Just Function {..} where (functionLocations, (unName <$>) . take 1 -> functionNames, functionRhs, - mergeBinds -> functionBinds) = unzip4 $ map extract matches - extract (Match srcLoc name _ _ rhs binds) = (srcLoc, name, rhs, binds) + catMaybes -> functionBinds) = unzip4 $ map extract matches + extract (Match srcLoc name _ rhs binds) = (srcLoc, name, rhs, binds) matchAST (PatBind (singleton -> functionLocations) pat (singleton -> functionRhs ) - (getBinds -> functionBinds )) = Just Function {..} + (maybeToList -> functionBinds )) = Just Function {..} where - functionNames = wildcards ++ map unName (universeBi pat) - wildcards = mapMaybe wildcard $ universeBi pat + functionNames = wildcards ++ map unName (universeBi pat :: [Name SrcLoc]) + wildcards = mapMaybe wildcard (universe pat) where - wildcard PWildCard = Just ".." - wildcard _ = Nothing + wildcard PWildCard {} = Just ".." + wildcard _ = Nothing matchAST _ = Nothing - fragmentName (Function {..}) = unwords $ "function":functionNames + fragmentName Function {..} = unwords $ "function":functionNames -- | Make a single element list. singleton :: a -> [a] @@ -146,7 +140,6 @@ occursOf :: (Data from, CodeFragment c) => Proxy c -> from -> [c] occursOf _ = occurs --- | All occurences of given type of @CodeFragment@ fragment within another structure. allOccurs :: (CodeFragment c, Data from) => from -> [c] allOccurs = mapMaybe matchAST . universeBi @@ -159,23 +152,25 @@ matchAST = Just fragmentName _ = "program" -instance CodeFragment Module where - type AST Module = Module +instance CodeFragment (Module SrcLoc) where + type AST (Module SrcLoc)= Module SrcLoc matchAST = Just - fragmentName (Module _ (ModuleName theName) _ _ _ _ _) = "module " ++ theName + fragmentName (Module _ (Just (ModuleHead _ (ModuleName _ theName) _ _)) _ _ _) = + "module " ++ theName -- | Proxy for passing @Module@ type as an argument. -moduleT :: Proxy Module +moduleT :: Proxy (Module SrcLoc) moduleT = Proxy instance CodeFragment TypeSignature where - type AST TypeSignature = Decl + type AST TypeSignature = Decl SrcLoc matchAST (TypeSig loc identifiers theType) = Just TypeSignature {..} matchAST _ = Nothing - fragmentName (TypeSignature {..}) = "type signature for " ++ intercalate ", " (map unName identifiers) + fragmentName TypeSignature {..} = "type signature for " + ++ intercalate ", " (map unName identifiers) -- | Unpack @Name@ identifier into a @String@. -unName :: Name -> String -unName (Symbol s) = s -unName (Ident i) = i +unName :: Name a -> String +unName (Symbol _ s) = s +unName (Ident _ i) = i diff --git a/Language/Haskell/Homplexity/Cyclomatic.hs b/Language/Haskell/Homplexity/Cyclomatic.hs --- a/Language/Haskell/Homplexity/Cyclomatic.hs +++ b/Language/Haskell/Homplexity/Cyclomatic.hs @@ -14,13 +14,12 @@ import Data.Data import Data.Generics.Uniplate.Data ---import Data.Proxy (Proxy) +import Language.Haskell.Exts.SrcLoc import Language.Haskell.Exts.Syntax import Language.Haskell.Homplexity.CodeFragment import Language.Haskell.Homplexity.Metric ---import Debug.Trace -type MatchSet = [Match] +type MatchSet = [Match SrcLoc] -- * Cyclomatic complexity -- | Represents cyclomatic complexity @@ -50,19 +49,20 @@ -- | Compute cyclomatic complexity of pattern matches. cyclomaticOfMatches :: Data from => from -> Int -cyclomaticOfMatches = sumOf recurse . childrenBi +cyclomaticOfMatches = sumOf recurse . childrenBi where recurse :: MatchSet -> Int recurse x = length x - 1 + sumOf cyclomaticOfMatches x -- | Cyclomatic complexity of all expressions -cyclomaticOfExprs :: Data from => from -> Int -cyclomaticOfExprs = sumOf armCount . universeBi +cyclomaticOfExprs :: forall from. + Data from => from -> Int +cyclomaticOfExprs = sumOf armCount . (universeBi :: from -> [Exp SrcLoc]) where - armCount (If {} ) = 2 - 1 - armCount (MultiIf alts) = length alts - 1 - armCount (LCase alts) = length alts - 1 - armCount (Case _ alts) = length alts - 1 + armCount (If {} ) = 2 - 1 + armCount (MultiIf _ alts) = length alts - 1 + armCount (LCase _ alts) = length alts - 1 + armCount (Case _ _ alts) = length alts - 1 armCount _ = 0 -- others are ignored -- * Decision depth @@ -86,7 +86,7 @@ . shows d -- | Depth of branching within @Exp@ression. -depthOfExpr :: Exp -> Int +depthOfExpr :: Exp SrcLoc -> Int depthOfExpr x = fromEnum (isDecision x)+maxOf depthOfExpr (children x) -- | Helper function to compute depth of branching within @case@ expression match. @@ -96,7 +96,7 @@ depthOfMatches ms = 1+maxOf depthOfExpr (concatMap childrenBi ms) -- | Check whether given @Exp@ression node is a decision node (conditional branch.) -isDecision :: Exp -> Bool +isDecision :: Exp SrcLoc -> Bool isDecision (If {}) = True isDecision (MultiIf {}) = True isDecision (LCase {}) = True diff --git a/Language/Haskell/Homplexity/Metric.hs b/Language/Haskell/Homplexity/Metric.hs --- a/Language/Haskell/Homplexity/Metric.hs +++ b/Language/Haskell/Homplexity/Metric.hs @@ -13,11 +13,12 @@ import Data.Data import Data.Function -import Data.Functor +--import Data.Functor import Data.Generics.Uniplate.Data import Data.List import Control.Arrow -import Language.Haskell.Exts.Syntax +import Language.Haskell.Exts.SrcLoc +--import Language.Haskell.Exts.Syntax import Language.Haskell.Homplexity.CodeFragment diff --git a/Language/Haskell/Homplexity/Parse.hs b/Language/Haskell/Homplexity/Parse.hs --- a/Language/Haskell/Homplexity/Parse.hs +++ b/Language/Haskell/Homplexity/Parse.hs @@ -47,7 +47,7 @@ -- and haskell-src-exts for parsing. -- -- Catches all exceptions and wraps them as @Critical@ log messages. -parseSource :: FilePath -> IO (Either Log (Module, [CommentLink])) +parseSource :: FilePath -> IO (Either Log (Module SrcLoc, [CommentLink])) parseSource inputFilename = do parseResult <- (do input <- readFile inputFilename @@ -59,7 +59,8 @@ putStrLn $ unlines $ map show $ orderCommentsAndCommentables (commentable parsed ) (classifyComments comments) - return $ Right (parsed, classifyComments comments) + return $ Right (getPointLoc <$> parsed, + classifyComments comments) ParseFailed aLoc msg -> return $ Left $ critical aLoc msg where handleException helper (e :: SomeException) = return $ helper $ show e @@ -71,9 +72,7 @@ , ignoreLanguagePragmas = False , ignoreLinePragmas = False , fixities = Just preludeFixities -#if MIN_VERSION_haskell_src_exts(1,17,0) , ignoreFunctionArity = False -#endif } {-putStrLn "COMMENTS:" putStrLn $ unlines $ map show $ classifyComments comments diff --git a/Language/Haskell/Homplexity/TypeComplexity.hs b/Language/Haskell/Homplexity/TypeComplexity.hs --- a/Language/Haskell/Homplexity/TypeComplexity.hs +++ b/Language/Haskell/Homplexity/TypeComplexity.hs @@ -38,22 +38,22 @@ measure = ConDepth . conDepth . theType -- | Function computing constructor depth of a @Type@. -conDepth :: Type -> Int +conDepth :: (Eq a, Data a) => Type a -> Int conDepth con = deeper con + maxOf conDepth (filter (/= con) $ childrenBi con) -- | Check whether given constructor of @Type@ counts in constructor depth computation. -deeper :: Type -> Int -deeper (TyForall _bind _context _type) = 1 -deeper (TyList _aType ) = 1 -deeper (TyFun _type1 _type2) = 1 -deeper (TyApp _type1 _type2) = 1 -deeper (TyInfix _type1 _ _type2) = 1 -deeper (TyTuple _boxed _types) = 1 -deeper (TyParArray _types) = 1 -deeper _ = 0 +deeper :: Type a -> Int +deeper (TyForall _ _bind _context _type) = 1 +deeper (TyList _ _aType ) = 1 +deeper (TyFun _ _type1 _type2) = 1 +deeper (TyApp _ _type1 _type2) = 1 +deeper (TyInfix _ _type1 _ _type2) = 1 +deeper (TyTuple _ _boxed _types) = 1 +deeper (TyParArray _ _types) = 1 +deeper _ = 0 -- * Number of function arguments -newtype NumFunArgs = NumFunArgs { unNumFunArgs :: Int } +newtype NumFunArgs = NumFunArgs { _unNumFunArgs :: Int } deriving (Eq, Ord, Enum, Num, Real, Integral) numFunArgsT :: Proxy NumFunArgs @@ -67,11 +67,11 @@ measure = NumFunArgs . numFunArgs . theType -- | Function computing constructor depth of a @Type@. -numFunArgs :: Type -> Int -numFunArgs (TyParen aType) = numFunArgs aType -numFunArgs (TyKind aType _kind) = numFunArgs aType -numFunArgs (TyForall _bind _context aType) = numFunArgs aType -- NOTE: doesn't count type argument -numFunArgs (TyFun _type1 type2) = 1+numFunArgs type2 -numFunArgs (TyParArray aType) = 1+numFunArgs aType -numFunArgs _ = 1 +numFunArgs :: Type a -> Int +numFunArgs (TyParen _ aType) = numFunArgs aType +numFunArgs (TyKind _ aType _kind) = numFunArgs aType +numFunArgs (TyForall _ _bind _context aType) = numFunArgs aType -- NOTE: doesn't count type argument +numFunArgs (TyFun _ _type1 type2) = 1+numFunArgs type2 +numFunArgs (TyParArray _ aType) = 1+numFunArgs aType +numFunArgs _ = 1 diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,10 @@ Changelog ========= + 0.4.3.4 July 2016 + + * Updated for haskell-src-exts-1.18. + This release is backwards incompatible with old haskell-src-exts before 1.18. + 0.4.3.3 May 2016 * Updated bounds again. diff --git a/homplexity.cabal b/homplexity.cabal --- a/homplexity.cabal +++ b/homplexity.cabal @@ -1,5 +1,5 @@ name: homplexity -version: 0.4.3.3 +version: 0.4.3.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,7 @@ GeneralizedNewtypeDeriving, TypeFamilies build-depends: base >=4.5 && <4.10, - haskell-src-exts >=1.17 && <1.18, + haskell-src-exts >=1.18 && <1.19, directory >=1.1 && <1.3, filepath >=1.2 && <1.5, hflags >=0.3 && <0.5, @@ -77,7 +77,7 @@ Language.Haskell.Homplexity.SrcSlice type: exitcode-stdio-1.0 build-depends: base >=4.5 && <4.10, - haskell-src-exts >=1.17 && <1.18, + haskell-src-exts >=1.18 && <1.19, uniplate >=1.4 && <1.7 default-language: Haskell2010