diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,19 @@ This package uses [Semantic Versioning][1]. +## v0.3.2.0 + +- Fix error in CPP processing: #14 +- Include updated `everythingStaged` code (by @alanz): #20 + +## v0.3.1.2 + +- Add `stack-7.8.yaml` to sdist. It's then possible to run tests from sdist. + +## v0.3.1.1 + +- Add test data to sdist: fpco/stackage#932 + ## v0.3.1.0 - Add compatibility with GHC 7.8: #6 diff --git a/USAGE.txt b/USAGE.txt --- a/USAGE.txt +++ b/USAGE.txt @@ -1,6 +1,5 @@ Usage: - argon [-h] [--no-color] [--json] [-m=] ... - argon [-h] [--no-color] [--m=] [--json] ... + argon [options] ... Options: -h --help show this help diff --git a/argon.cabal b/argon.cabal --- a/argon.cabal +++ b/argon.cabal @@ -1,5 +1,5 @@ name: argon -version: 0.3.1.2 +version: 0.3.2.0 synopsis: Measure your code's complexity homepage: http://github.com/rubik/argon bug-reports: http://github.com/rubik/argon/issues @@ -25,7 +25,7 @@ CHANGELOG.md USAGE.txt test/data/*.hs -tested-with: GHC >= 7.8 +tested-with: GHC >= 7.8 && < 8 library hs-source-dirs: src @@ -37,6 +37,7 @@ Argon.Types Argon.Preprocess Argon.Loc + Argon.SYB.Utils build-depends: base >=4.7 && <5 , ansi-terminal >=0.6 , aeson >=0.8 @@ -82,7 +83,6 @@ , hspec >=2.1 , QuickCheck -any , filepath >=1.3 - , argon -any ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N if impl(ghc < 7.8) buildable: False @@ -96,6 +96,7 @@ Argon.Types Argon.Preprocess Argon.Loc + Argon.SYB.Utils test-suite style type: exitcode-stdio-1.0 diff --git a/src/Argon/Parser.hs b/src/Argon/Parser.hs --- a/src/Argon/Parser.hs +++ b/src/Argon/Parser.hs @@ -55,12 +55,14 @@ GHC.runGhc (Just libdir) $ do dflags <- initDynFlags file let useCpp = GHC.xopt GHC.Opt_Cpp dflags - fileContents <- + (fileContents, dflags1) <- if useCpp then getPreprocessedSrcDirect cppOptions file - else GHC.liftIO $ readFile file + else do + contents <- GHC.liftIO $ readFile file + return (contents, dflags) return $ - case parseCode dflags file fileContents of + case parseCode dflags1 file fileContents of GHC.PFailed ss m -> Left $ tagMsg (srcSpanToLoc ss) (GHC.showSDoc dflags m) GHC.POk _ pmod -> Right pmod diff --git a/src/Argon/Preprocess.hs b/src/Argon/Preprocess.hs --- a/src/Argon/Preprocess.hs +++ b/src/Argon/Preprocess.hs @@ -1,5 +1,6 @@ --- The following code is taken from ghc-exactprint, because adding a dependency --- for just one module seemed excessive. +-- The following code is taken and modified from ghc-exactprint, because adding +-- a dependency for just one module and then adding wrappers for that module +-- seemed excessive. {-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} -- | This module provides support for CPP and interpreter directives. @@ -17,6 +18,7 @@ import qualified DynFlags as GHC import qualified MonadUtils as GHC import qualified StringBuffer as GHC +import qualified DriverPhases as GHC import qualified DriverPipeline as GHC data CppOptions = CppOptions @@ -29,9 +31,12 @@ defaultCppOptions :: CppOptions defaultCppOptions = CppOptions [] [] [] -getPreprocessedSrcDirect :: (GHC.GhcMonad m) => CppOptions -> FilePath -> m String +getPreprocessedSrcDirect :: (GHC.GhcMonad m) + => CppOptions + -> FilePath + -> m (String, GHC.DynFlags) getPreprocessedSrcDirect cppOptions src = - (\(a,_,_) -> a) <$> getPreprocessedSrcDirectPrim cppOptions src + (\(s, _, d) -> (s, d)) <$> getPreprocessedSrcDirectPrim cppOptions src getPreprocessedSrcDirectPrim :: (GHC.GhcMonad m) => CppOptions @@ -41,7 +46,8 @@ hscEnv <- GHC.getSession let dfs = GHC.extractDynFlags hscEnv newEnv = GHC.replaceDynFlags hscEnv (injectCppOptions cppOptions dfs) - (dflags', hspp_fn) <- GHC.liftIO $ GHC.preprocess newEnv (file, Nothing) + (dflags', hspp_fn) <- + GHC.liftIO $ GHC.preprocess newEnv (file, Just (GHC.Cpp GHC.HsSrcFile)) buf <- GHC.liftIO $ GHC.hGetStringBuffer hspp_fn txt <- GHC.liftIO $ readFile hspp_fn return (txt, buf, dflags') diff --git a/src/Argon/SYB/Utils.hs b/src/Argon/SYB/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Argon/SYB/Utils.hs @@ -0,0 +1,40 @@ +-- The following code is temporarily taken from @alanz's fork of +-- nominolo/ghc-syb. Argon will use the original ghc-syb when a new version +-- is released on Hackage with @alanz's fixes. +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} +module Argon.SYB.Utils (Stage(..), everythingStaged) + where + +import GHC +import NameSet (NameSet) +import Data.Generics +#if __GLASGOW_HASKELL__ <= 708 +import Coercion +#endif + + +-- | Ghc Ast types tend to have undefined holes, to be filled +-- by later compiler phases. We tag Asts with their source, +-- so that we can avoid such holes based on who generated the Asts. +data Stage = Parser | Renamer | TypeChecker deriving (Eq, Ord, Show) + +-- | Like 'everything', but avoid known potholes, based on the 'Stage' that +-- generated the Ast. +everythingStaged :: Stage -> (r -> r -> r) -> r -> GenericQ r -> GenericQ r +everythingStaged stage k z f x + | (const False +#if __GLASGOW_HASKELL__ <= 708 + `extQ` postTcType + `extQ` nameList + `extQ` coercion +#endif + `extQ` fixity `extQ` nameSet) x = z + | otherwise = foldl k (f x) (gmapQ (everythingStaged stage k z f) x) + where nameSet = const (stage `elem` [Parser,TypeChecker]) :: NameSet -> Bool +#if __GLASGOW_HASKELL__ <= 708 + postTcType = const (stage < TypeChecker) :: PostTcType -> Bool + nameList = const (stage < TypeChecker) :: [Name] -> Bool + coercion = const (stage < TypeChecker) :: Coercion -> Bool +#endif + fixity = const (stage < Renamer) :: GHC.Fixity -> Bool diff --git a/src/Argon/Visitor.hs b/src/Argon/Visitor.hs --- a/src/Argon/Visitor.hs +++ b/src/Argon/Visitor.hs @@ -2,7 +2,7 @@ where import Data.Generics (Data, Typeable, mkQ) -import GHC.SYB.Utils (Stage(..), everythingStaged) +import Argon.SYB.Utils (Stage(..), everythingStaged) import Control.Arrow ((&&&)) import qualified GHC diff --git a/test/ArgonSpec.hs b/test/ArgonSpec.hs --- a/test/ArgonSpec.hs +++ b/test/ArgonSpec.hs @@ -1,6 +1,5 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE StandaloneDeriving #-} module ArgonSpec (spec) where @@ -114,13 +113,34 @@ , CC ((94, 17), "idents", 1) , CC ((103, 21), "m", 1) ] - it "applies CPP when needed" $ - "cpp.hs" `shouldAnalyze` Right [CC (lo 5, "f", 4)] - it "catches syntax errors" $ - "syntaxerror.hs" `shouldAnalyze` - Left "2:1 parse error (possibly incorrect indentation or mismatched brackets)" - it "catches CPP parsing errors" $ - unsafePerformIO (analyze (path "cpp-error.hs")) `shouldSatisfy` - \(_, res) -> - isLeft res && ("2:0 error: unterminated #else" - `isPrefixOf` head (lefts [res])) + describe "extensions" $ do +-- Not even GHC 7.8.4 is able to run the file below, so it's not an Argon bug +#if __GLASGOW_HASKELL__ >= 710 + it "correctly applies CPP" $ + "cpp-psyn.hs" `shouldAnalyze` Right [] +#endif + it "applies CPP when needed" $ + "cpp.hs" `shouldAnalyze` Right [CC (lo 5, "f", 4)] + it "works with TemplateHaskell" $ + "th.hs" `shouldAnalyze` Right [CC (lo 7, "foo", 1)] + it "works with DataKinds, GADTs, KindSignatures" $ + "datakinds.hs" `shouldAnalyze` + Right [ CC (lo 16, "taskOneWorker", 1) + , CC (lo 20, "main", 1)] + it "works with ScopedTypeVariables" $ + "scopedtypevariables.hs" `shouldAnalyze` + Right [CC (lo 9, "catchNonAsync", 1)] + it "works with TypeFamilies" $ + "typefamilies.hs" `shouldAnalyze` Right [] + it "works with ForeignImport" $ + "foreignimports.hs" `shouldAnalyze` Right [] + describe "errors" $ do + it "catches syntax errors" $ + "syntaxerror.hs" `shouldAnalyze` + Left ("2:1 parse error (possibly incorrect indentation" ++ + " or mismatched brackets)") + it "catches CPP parsing errors" $ + unsafePerformIO (analyze (path "cpp-error.hs")) `shouldSatisfy` + \(_, res) -> + isLeft res && ("2:0 error: unterminated #else" + `isPrefixOf` head (lefts [res])) diff --git a/test/data/cpp-psyn.hs b/test/data/cpp-psyn.hs new file mode 100644 --- /dev/null +++ b/test/data/cpp-psyn.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE CPP #-} +#ifndef HLINT +{-# LANGUAGE ViewPatterns #-} +#endif +{-# LANGUAGE PatternSynonyms #-} + +data Counted a = Counted Int [a] deriving (Eq, Ord, Read, Show) + +pattern (:+) :: () => () => a -> Counted a -> Counted a +pattern a :+ as <- Counted (subtract 1 -> i) (a : (Counted i -> as)) where + a :+ Counted i as = Counted (i+1) (a:as) diff --git a/test/data/datakinds.hs b/test/data/datakinds.hs new file mode 100644 --- /dev/null +++ b/test/data/datakinds.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE GADTs #-} + +data JobDescription = JobOne + | JobTwo + | JobThree + deriving (Show, Eq) + +data SJobDescription :: JobDescription -> * where + SJobOne :: { jobOneN :: Int } -> SJobDescription JobOne + SJobTwo :: SJobDescription JobTwo + SJobThree :: { jobThreeN :: Int } -> SJobDescription JobThree + +taskOneWorker :: SJobDescription JobOne -> IO () +taskOneWorker t = do + putStrLn $ "Job: " ++ (show $ jobOneN t) + +main :: IO () +main = taskOneWorker (SJobOne 10) diff --git a/test/data/foreignimports.hs b/test/data/foreignimports.hs new file mode 100644 --- /dev/null +++ b/test/data/foreignimports.hs @@ -0,0 +1,10 @@ +module Internal.Sparse where + +import Foreign.C.Types(CInt(..)) +import Foreign(Ptr) + +foreign import ccall unsafe "smXv" + c_smXv :: SMxV + +foreign import ccall unsafe "smTXv" + c_smTXv :: SMxV diff --git a/test/data/scopedtypevariables.hs b/test/data/scopedtypevariables.hs new file mode 100644 --- /dev/null +++ b/test/data/scopedtypevariables.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Utility.Exception where + +import Control.Monad.Catch as X hiding (Handler) +import qualified Control.Monad.Catch as M + +catchNonAsync :: MonadCatch m => m a -> (SomeException -> m a) -> m a +catchNonAsync a onerr = a catches + [ M.Handler ( (e :: SomeException) -> onerr e) + ] diff --git a/test/data/th.hs b/test/data/th.hs new file mode 100644 --- /dev/null +++ b/test/data/th.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TemplateHaskell #-} +module Blow where + +import Language.Haskell.TH + +foo :: Q Exp +foo = [| \f -> f 2 |] diff --git a/test/data/typefamilies.hs b/test/data/typefamilies.hs new file mode 100644 --- /dev/null +++ b/test/data/typefamilies.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +import Control.Lens.Lens +import Data.Functor.Identity +import Data.Functor.Product +import Data.Proxy (Proxy (Proxy)) +import GHC.Generics (Generic (..), (:*:) (..), K1 (..), M1 (..), U1 (..)) +import Control.Applicative + +type family GSize (f :: * -> *) +type instance GSize U1 = Z +type instance GSize (K1 i c) = S Z +type instance GSize (M1 i c f) = GSize f +type instance GSize (a :*: b) = Add (GSize a) (GSize b)