diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,10 +2,16 @@ This package uses [Semantic Versioning][1]. +## v0.4.0.0 + +- Add streaming capabilities (haskell-pipes) for lower memory usage: #18. +- Add `--cabal-macros` and `--include-dir` options: #17. +- Add `--cabal-file` to read default extensions: #19. + ## v0.3.2.0 -- Fix error in CPP processing: #14 -- Include updated `everythingStaged` code (by @alanz): #20 +- Fix error in CPP processing: #14. +- Include updated `everythingStaged` code (by @alanz): #20. ## v0.3.1.2 @@ -13,20 +19,20 @@ ## v0.3.1.1 -- Add test data to sdist: fpco/stackage#932 +- Add test data to sdist: fpco/stackage#932. ## v0.3.1.0 -- Add compatibility with GHC 7.8: #6 +- Add compatibility with GHC 7.8: #6. ## v0.3.0.0 -- Major: replace Haskell-Src-Exts with GHC API: #5 -- Add basic tests: #7 +- Major: replace Haskell-Src-Exts with GHC API: #5. +- Add basic tests: #7. ## v0.2.0.0 -- Add `USAGE.txt` to tarball: #2 +- Add `USAGE.txt` to tarball: #2. ## v0.1.0.0 diff --git a/USAGE.txt b/USAGE.txt --- a/USAGE.txt +++ b/USAGE.txt @@ -2,7 +2,10 @@ argon [options] ... Options: - -h --help show this help - -m --min= the minimum complexity to show in results - --no-color results are not colored - -j --json results are serialized to JSON + -h --help show this help + -m --min= the minimum complexity to show in results + --cabal-file= path to Cabal main file + --cabal-macros= Cabal header file with versions macros + -I --include-dir= additional directory with header files + --no-color results are not colored + -j --json results are serialized to JSON diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -2,18 +2,9 @@ {-# LANGUAGE QuasiQuotes #-} module Main where -import Data.List (foldl1', isSuffixOf) -import Data.Sequence (Seq) -import qualified Data.Sequence as S -import Data.Foldable (toList) -#if __GLASGOW_HASKELL__ < 710 -import Data.Monoid (mappend) -import Control.Applicative ((<$>)) -#endif +import Pipes +import qualified Pipes.Prelude as P import System.Environment (getArgs) -import System.FilePath (()) -import System.Directory -import System.Directory.PathWalk import System.Console.Docopt import Argon @@ -28,38 +19,28 @@ getOpt :: Arguments -> String -> String -> String getOpt args def opt = getArgWithDefault args def $ longOption opt -haskellFiles :: Seq FilePath -> Seq FilePath -haskellFiles = S.filter (".hs" `isSuffixOf`) - -findSourceFiles :: FilePath -> IO (Seq FilePath) -findSourceFiles path = - pathWalkAccumulate path $ \dir _ files -> - return $ fmap (dir ) $ haskellFiles $ S.fromList files - -descend :: FilePath -> IO (Seq FilePath) -descend path = do - isFile <- doesFileExist path - if isFile then return $ haskellFiles $ S.singleton path - else findSourceFiles path - -allFiles :: [FilePath] -> IO (Seq FilePath) -allFiles paths = foldl1' mappend <$> mapM descend paths - -readConfig :: Arguments -> Config -readConfig args = - Config { - minCC = read $ getOpt args "1" "min" - , outputMode = if args `isPresent` longOption "json" - then JSON - else if args `isPresent` longOption "no-color" - then BareText - else Colored +readConfig :: Arguments -> IO Config +readConfig args = do + xFlags <- maybe (return []) parseExts $ getArg args $ longOption "cabal-file" + return Config { + minCC = read $ getOpt args "1" "min" + , exts = xFlags + , headers = args `getAllArgs` longOption "cabal-macros" + , includeDirs = args `getAllArgs` longOption "include-dir" + , outputMode = if args `isPresent` longOption "json" + then JSON + else if args `isPresent` longOption "no-color" + then BareText + else Colored } main :: IO () main = do args <- parseArgsOrExit patterns =<< getArgs ins <- allFiles $ args `getAllArgs` argument "paths" - res <- mapM analyze $ toList ins - let conf = readConfig args - putStr $ export conf $ map (filterResults conf) res + conf <- readConfig args + let source = each ins + >-> P.mapM (analyze conf) + >-> P.map (filterResults conf) + >-> P.filter filterNulls + runEffect $ exportStream conf source diff --git a/argon.cabal b/argon.cabal --- a/argon.cabal +++ b/argon.cabal @@ -1,5 +1,5 @@ name: argon -version: 0.3.2.0 +version: 0.4.0.0 synopsis: Measure your code's complexity homepage: http://github.com/rubik/argon bug-reports: http://github.com/rubik/argon/issues @@ -25,6 +25,10 @@ CHANGELOG.md USAGE.txt test/data/*.hs + test/tree/*.hs + test/tree/*.txt + test/tree/sub/*.hs + test/tree/sub2/*.hs tested-with: GHC >= 7.8 && < 8 library @@ -37,15 +41,25 @@ Argon.Types Argon.Preprocess Argon.Loc + Argon.Cabal Argon.SYB.Utils + Argon.Walker build-depends: base >=4.7 && <5 , ansi-terminal >=0.6 , aeson >=0.8 , bytestring >=0.10 + , pipes >=4.1 + , pipes-group >=1.0 + , lens-simple >=0.1 , ghc >=7.8 && <8 , ghc-paths >=0.1 , ghc-syb-utils >=0.2 , syb >=0.4 + , Cabal >=1.18 + , containers >=0.5 + , pathwalk >=0.3 + , filepath >=1.3 + , directory >=1.2 default-language: Haskell2010 ghc-options: -Wall if impl(ghc < 7.8) @@ -57,10 +71,7 @@ ghc-options: -Wall build-depends: base >=4.7 && <5 , docopt >=0.7 - , pathwalk >=0.3 - , filepath >=1.3 - , directory >=1.2 - , containers >=0.5 + , pipes >=4.1 , argon -any if impl(ghc < 7.10) build-depends: pathwalk >=0.3.1.2 @@ -76,13 +87,21 @@ , ansi-terminal >=0.6 , aeson >=0.8 , bytestring >=0.10 + , pipes >=4.1 + , pipes-group >=1.0 + , lens-simple >=0.1 , ghc >=7.8 && <8 , ghc-paths >=0.1 , ghc-syb-utils >=0.2 , syb >=0.4 + , Cabal >=1.18 + , containers >=0.5 , hspec >=2.1 , QuickCheck -any , filepath >=1.3 + , docopt >=0.7 + , pathwalk >=0.3 + , directory >=1.2 ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N if impl(ghc < 7.8) buildable: False @@ -96,7 +115,9 @@ Argon.Types Argon.Preprocess Argon.Loc + Argon.Cabal Argon.SYB.Utils + Argon.Walker test-suite style type: exitcode-stdio-1.0 diff --git a/src/Argon.hs b/src/Argon.hs --- a/src/Argon.hs +++ b/src/Argon.hs @@ -14,18 +14,26 @@ , ComplexityBlock(CC) , OutputMode(..) , Config(..) + , defaultConfig , Loc , LModule + -- * Gathering source files + , allFiles -- * Parsing , analyze , parseModule + , parseExts + , flagsMap -- * Manipulating results , order , filterResults - , export + , filterNulls + , exportStream ) where import Argon.Parser (LModule, analyze, parseModule) -import Argon.Results (order, export, filterResults) +import Argon.Results (order, filterResults, filterNulls, exportStream) +import Argon.Cabal (flagsMap, parseExts) import Argon.Types import Argon.Loc +import Argon.Walker (allFiles) diff --git a/src/Argon/Cabal.hs b/src/Argon/Cabal.hs new file mode 100644 --- /dev/null +++ b/src/Argon/Cabal.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE CPP #-} +module Argon.Cabal (flagsMap, parseExts) + where + +import Data.Maybe (mapMaybe) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative ((<$>)) +#else +import Control.Arrow ((&&&)) +#endif + +import qualified DynFlags as GHC +import qualified Language.Haskell.Extension as Dist +import qualified Distribution.Verbosity as Dist +import qualified Distribution.PackageDescription as Dist +import qualified Distribution.PackageDescription.Parse as Dist + + +-- | A 'Map' from extensions names to extensions flags +flagsMap :: Map String GHC.ExtensionFlag +flagsMap = M.fromList $ map specToPair GHC.xFlags + +-- | Parse the given Cabal file generate a list of GHC extension flags. The +-- extension names are read from the default-extensions field in the library +-- section. +parseExts :: FilePath -> IO [GHC.ExtensionFlag] +parseExts path = extract <$> Dist.readPackageDescription Dist.silent path + where extract pkg = maybe [] extFromBI $ + (Dist.libBuildInfo . Dist.condTreeData) <$> Dist.condLibrary pkg + +extFromBI :: Dist.BuildInfo -> [GHC.ExtensionFlag] +extFromBI = mapMaybe (get . toString) . Dist.defaultExtensions + where get = flip M.lookup flagsMap + toString (Dist.UnknownExtension ext) = ext + toString (Dist.EnableExtension ext) = show ext + toString (Dist.DisableExtension ext) = show ext + +#if __GLASGOW_HASKELL__ < 710 +specToPair :: (String, GHC.ExtensionFlag, a) -> (String, GHC.ExtensionFlag) +specToPair (a, b, _) = (a, b) +#else +specToPair :: GHC.FlagSpec GHC.ExtensionFlag -> (String, GHC.ExtensionFlag) +specToPair = GHC.flagSpecName &&& GHC.flagSpecFlag +#endif diff --git a/src/Argon/Formatters.hs b/src/Argon/Formatters.hs --- a/src/Argon/Formatters.hs +++ b/src/Argon/Formatters.hs @@ -1,33 +1,30 @@ -module Argon.Formatters (bareTextFormatter, coloredTextFormatter - , jsonFormatter) +{-# LANGUAGE LambdaCase #-} +module Argon.Formatters (bareTextFormatter, coloredTextFormatter) where -import Data.Aeson (encode) -import qualified Data.ByteString.Lazy.Char8 as B -import Data.List (intercalate) import Text.Printf (printf) import System.Console.ANSI +import Pipes +import qualified Pipes.Prelude as P + import Argon.Types import Argon.Loc -bareTextFormatter :: [(FilePath, AnalysisResult)] -> String -bareTextFormatter = formatSingle $ formatResult - (printf "%s\n\t%s") - (\e -> "error:" ++ e) - (\(CC (l, func, cc)) -> printf "%s %s - %d" (locToString l) func cc) - -coloredTextFormatter :: [(FilePath, AnalysisResult)] -> String -coloredTextFormatter = formatSingle $ formatResult - (\name rest -> printf "%s%s%s\n\t%s%s" open name reset rest reset) - (\e -> printf "%serror%s: %s%s" (fore Red) reset e reset) - (\(CC (l, func, cc)) -> printf "%s %s - %s%s" (locToString l) - (coloredFunc func l) - (coloredRank cc) reset) +bareTextFormatter :: Pipe (FilePath, AnalysisResult) String IO () +bareTextFormatter = formatResult + id + ("\terror:" ++) + (\(CC (l, func, cc)) -> printf "\t%s %s - %d" (locToString l) func cc) -jsonFormatter :: [(FilePath, AnalysisResult)] -> String -jsonFormatter = B.unpack . encode +coloredTextFormatter :: Pipe (FilePath, AnalysisResult) String IO () +coloredTextFormatter = formatResult + (\name -> open ++ name ++ reset) + (printf "\t%serror%s: %s" (fore Red) reset) + (\(CC (l, func, cc)) -> printf "\t%s %s - %s%s" (locToString l) + (coloredFunc func l) + (coloredRank cc) reset) open :: String open = setSGRCode [SetConsoleIntensity BoldIntensity] @@ -49,17 +46,14 @@ | c <= 10 = (Yellow, "B") | otherwise = (Red, "C") -formatSingle :: ((FilePath, AnalysisResult) -> String) - -> [(FilePath, AnalysisResult)] - -> String -formatSingle f = unlines . filter (not . null) . map f - -formatResult :: (String -> String -> String) -- ^ The block formatter +formatResult :: (String -> String) -- ^ The header formatter -> (String -> String) -- ^ The error formatter -> (ComplexityBlock -> String) -- ^ The single line formatter - -> (FilePath, AnalysisResult) -> String -formatResult resultBlock errorF _ (name, Left err) = - resultBlock name $ errorF err -formatResult _ _ _ (_, Right []) = "" -formatResult resultBlock _ singleF (name, Right rs) = - resultBlock name $ intercalate "\n\t" $ map singleF rs + -> Pipe (FilePath, AnalysisResult) String IO () +formatResult header errorF singleF = for cat $ \case + (path, Left err) -> do + yield $ header path + yield $ errorF err + (path, Right rs) -> do + yield $ header path + each rs >-> P.map singleF diff --git a/src/Argon/Parser.hs b/src/Argon/Parser.hs --- a/src/Argon/Parser.hs +++ b/src/Argon/Parser.hs @@ -2,6 +2,7 @@ module Argon.Parser (LModule, analyze, parseModule) where +import Data.List (foldl') import Control.Monad (void) import qualified Control.Exception as E @@ -29,11 +30,12 @@ -- | Parse the code in the given filename and compute cyclomatic complexity for -- every function binding. -analyze :: FilePath -- ^ The filename corresponding to the source code +analyze :: Config -- ^ Configuration options + -> FilePath -- ^ The filename corresponding to the source code -> IO (FilePath, AnalysisResult) -analyze file = do +analyze conf file = do parseResult <- (do - result <- parseModule file + result <- parseModule conf file E.evaluate result) `E.catch` handleExc let analysis = case parseResult of Left err -> Left err @@ -44,16 +46,21 @@ handleExc = return . Left . show -- | Parse a module with the default instructions for the C pre-processor -parseModule :: FilePath -> IO (Either String LModule) -parseModule = parseModuleWithCpp defaultCppOptions +-- Only the includes directory is taken from the config +parseModule :: Config -> FilePath -> IO (Either String LModule) +parseModule conf = parseModuleWithCpp conf $ + defaultCppOptions { cppInclude = includeDirs conf + , cppFile = headers conf + } -- | Parse a module with specific instructions for the C pre-processor. -parseModuleWithCpp :: CppOptions +parseModuleWithCpp :: Config + -> CppOptions -> FilePath -> IO (Either String LModule) -parseModuleWithCpp cppOptions file = +parseModuleWithCpp conf cppOptions file = GHC.runGhc (Just libdir) $ do - dflags <- initDynFlags file + dflags <- initDynFlags conf file let useCpp = GHC.xopt GHC.Opt_Cpp dflags (fileContents, dflags1) <- if useCpp @@ -76,12 +83,13 @@ buffer = GHC.stringToStringBuffer str parseState = GHC.mkPState flags buffer location -initDynFlags :: GHC.GhcMonad m => FilePath -> m GHC.DynFlags -initDynFlags file = do +initDynFlags :: GHC.GhcMonad m => Config -> FilePath -> m GHC.DynFlags +initDynFlags conf file = do dflags0 <- GHC.getSessionDynFlags src_opts <- GHC.liftIO $ GHC.getOptionsFromFile dflags0 file (dflags1, _, _) <- GHC.parseDynamicFilePragma dflags0 src_opts - let dflags2 = dflags1 { GHC.log_action = customLogAction } + let cabalized = foldl' GHC.xopt_set dflags1 $ exts conf + let dflags2 = cabalized { GHC.log_action = customLogAction } void $ GHC.setSessionDynFlags dflags2 return dflags2 diff --git a/src/Argon/Results.hs b/src/Argon/Results.hs --- a/src/Argon/Results.hs +++ b/src/Argon/Results.hs @@ -1,8 +1,22 @@ -module Argon.Results (order, filterResults, export) +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +module Argon.Results (order, filterResults, filterNulls, exportStream) where import Data.Ord (comparing) import Data.List (sortBy) +import Data.String (IsString) +import qualified Data.ByteString.Lazy as B +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative ((<*), (*>)) +#endif + +import Data.Aeson (encode) +import Pipes +import Pipes.Group +import qualified Pipes.Prelude as P +import Lens.Simple ((^.)) + import Argon.Formatters import Argon.Types @@ -20,6 +34,14 @@ order :: [ComplexityBlock] -> [ComplexityBlock] order = sortOn (\(CC ((l, _), f, cc)) -> (-cc, l, f)) +-- | A result is discarded if it correspond to a successful analysis and there +-- are no blocks to show +filterNulls :: (FilePath, AnalysisResult) -> Bool +filterNulls (_, r) = case r of + Left _ -> True + Right [] -> False + _ -> True + -- | Filter the results of the analysis, with respect to the given -- 'Config'. filterResults :: Config @@ -31,9 +53,19 @@ -- | Export analysis' results. How to export the data is defined by the -- 'Config' parameter. -export :: Config -> [(FilePath, AnalysisResult)] -> String -export opts rs = - case outputMode opts of - BareText -> bareTextFormatter rs - Colored -> coloredTextFormatter rs - JSON -> jsonFormatter rs +exportStream :: Config + -> Producer (FilePath, AnalysisResult) IO () + -> Effect IO () +exportStream conf source = + case outputMode conf of + BareText -> source >-> bareTextFormatter >-> P.stdoutLn + Colored -> source >-> coloredTextFormatter >-> P.stdoutLn + JSON -> jsonStream (source >-> P.map encode) >-> P.mapM_ B.putStr + +jsonStream :: IsString a + => Producer a IO () + -> Producer a IO () +jsonStream source = yield "[" *> intersperse' "," source <* yield "]\n" + +intersperse' :: Monad m => a -> Producer a m r -> Producer a m r +intersperse' a producer = intercalates (yield a) (producer ^. chunksOf 1) diff --git a/src/Argon/SYB/Utils.hs b/src/Argon/SYB/Utils.hs --- a/src/Argon/SYB/Utils.hs +++ b/src/Argon/SYB/Utils.hs @@ -28,6 +28,7 @@ `extQ` postTcType `extQ` nameList `extQ` coercion + `extQ` cmdTable #endif `extQ` fixity `extQ` nameSet) x = z | otherwise = foldl k (f x) (gmapQ (everythingStaged stage k z f) x) @@ -36,5 +37,6 @@ postTcType = const (stage < TypeChecker) :: PostTcType -> Bool nameList = const (stage < TypeChecker) :: [Name] -> Bool coercion = const (stage < TypeChecker) :: Coercion -> Bool + cmdTable = const (stage < TypeChecker) :: CmdSyntaxTable RdrName -> Bool #endif fixity = const (stage < Renamer) :: GHC.Fixity -> Bool diff --git a/src/Argon/Types.hs b/src/Argon/Types.hs --- a/src/Argon/Types.hs +++ b/src/Argon/Types.hs @@ -7,7 +7,7 @@ #endif module Argon.Types (ComplexityBlock(CC), AnalysisResult, Config(..) - , OutputMode(..), GhcParseError(..)) + , OutputMode(..), GhcParseError(..), defaultConfig) where import Data.List (intercalate) @@ -15,6 +15,7 @@ import Data.Typeable import Control.Exception (Exception) +import qualified DynFlags as GHC import Argon.Loc @@ -36,9 +37,15 @@ -- | Type holding all the options passed from the command line. data Config = Config { -- | Minimum complexity a block has to have to be shown in results. - minCC :: Int + minCC :: Int + -- | Path to the main Cabal file + , exts :: [GHC.ExtensionFlag] + -- | Header files to be automatically included before preprocessing + , headers :: [FilePath] + -- | Additional include directories for the C preprocessor + , includeDirs :: [FilePath] -- | Describe how the results should be exported. - , outputMode :: OutputMode + , outputMode :: OutputMode } -- | Type describing how the results should be exported. @@ -46,6 +53,17 @@ | Colored -- ^ Text-only output, with colors. | JSON -- ^ Data is serialized to JSON. deriving (Show, Eq) + +-- | Default configuration options. +-- +-- __Warning__: These are not Argon's default options. +defaultConfig :: Config +defaultConfig = Config { minCC = 1 + , exts = [] + , headers = [] + , includeDirs = [] + , outputMode = JSON + } instance Exception GhcParseError diff --git a/src/Argon/Walker.hs b/src/Argon/Walker.hs new file mode 100644 --- /dev/null +++ b/src/Argon/Walker.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE CPP #-} +module Argon.Walker (allFiles) + where + +import Data.Sequence (Seq) +import qualified Data.Sequence as S +import Data.List (foldl1', isSuffixOf) +#if __GLASGOW_HASKELL__ < 710 +import Data.Monoid (mappend) +import Control.Applicative ((<$>)) +#endif +import System.FilePath (()) +import System.Directory +import System.Directory.PathWalk + + +-- | Starting from a list of paths, generate a sequence of paths corresponding +-- to Haskell files. The fileystem is traversed in a manner similar to +-- reversed DFS. +allFiles :: [FilePath] -> IO (Seq FilePath) +allFiles paths = foldl1' mappend <$> mapM descend paths + +descend :: FilePath -> IO (Seq FilePath) +descend path = do + isFile <- doesFileExist path + if isFile then return $ haskellFiles $ S.singleton path + else findSourceFiles path + +haskellFiles :: Seq FilePath -> Seq FilePath +haskellFiles = S.filter (".hs" `isSuffixOf`) + +findSourceFiles :: FilePath -> IO (Seq FilePath) +findSourceFiles path = + pathWalkAccumulate path $ \dir _ files -> + return $ fmap (dir ) $ haskellFiles $ S.fromList files diff --git a/stack-7.8.yaml b/stack-7.8.yaml --- a/stack-7.8.yaml +++ b/stack-7.8.yaml @@ -7,4 +7,6 @@ - pathwalk-0.3.1.2 - syb-0.4.4 - ghc-7.8.4 +- lens-simple-0.1.0.8 +- lens-family-1.2.0 resolver: lts-2.22 diff --git a/test/ArgonSpec.hs b/test/ArgonSpec.hs --- a/test/ArgonSpec.hs +++ b/test/ArgonSpec.hs @@ -4,8 +4,10 @@ module ArgonSpec (spec) where +import Data.Foldable (toList) import Data.List (sort, isPrefixOf) import Data.Either (isLeft, lefts) +import qualified Data.Sequence as S #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>), (<*>)) #endif @@ -15,6 +17,7 @@ import System.IO.Unsafe (unsafePerformIO) import qualified SrcLoc as GHC import qualified FastString as GHC + import Argon import Argon.Loc @@ -41,9 +44,12 @@ path f = "test" "data" f shouldAnalyze :: String -> AnalysisResult -> Expectation -shouldAnalyze f r = analyze p `shouldReturn` (p, r) +shouldAnalyze f r = analyze defaultConfig p `shouldReturn` (p, r) where p = path f +shouldReturnS :: IO (S.Seq FilePath) -> [FilePath] -> Expectation +shouldReturnS action res = action >>= ((`shouldBe` (sort res)) . sort . toList) + spec :: Spec spec = do describe "Argon.Loc" $ do @@ -77,7 +83,7 @@ property $ \xs -> order xs == order (order xs) describe "filterResults" $ do it "discards results with too low complexity" $ - filterResults (Config { minCC = 3, outputMode = BareText }) + filterResults (Config 3 [] [] [] BareText ) ("p", Right [ CC (ones, "f", 3) , CC (lo 2, "g", 2) , CC (lo 4, "h", 10) @@ -86,7 +92,7 @@ ("p", Right [ CC (lo 4, "h", 10) , CC (ones, "f", 3)]) it "does nothing on Left" $ - property $ \m o p err -> filterResults (Config m o) + property $ \m o p err -> filterResults (Config m [] [] [] o) (p, Left err) == (p, Left err) describe "analyze" $ do @@ -134,13 +140,29 @@ "typefamilies.hs" `shouldAnalyze` Right [] it "works with ForeignImport" $ "foreignimports.hs" `shouldAnalyze` Right [] + it "works with Arrows" $ + "arrows.hs" `shouldAnalyze` Right [CC (lo 7, "getAnchor", 1)] 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` + unsafePerformIO (analyze defaultConfig (path "cpp-error.hs")) + `shouldSatisfy` \(_, res) -> isLeft res && ("2:0 error: unterminated #else" `isPrefixOf` head (lefts [res])) + describe "Argon.Walker" $ + describe "allFiles" $ do + it "traverses the filesystem with reversed DFS" $ + allFiles ["test" "tree"] `shouldReturnS` + [ "test" "tree" "a.hs" + , "test" "tree" "sub2" "e.hs" + , "test" "tree" "sub2" "a.hs" + , "test" "tree" "sub" "c.hs" + , "test" "tree" "sub" "b.hs" + ] + it "includes starting files in the result" $ + allFiles ["test" "tree" "a.hs"] `shouldReturnS` + ["test" "tree" "a.hs"] diff --git a/test/data/arrows.hs b/test/data/arrows.hs new file mode 100644 --- /dev/null +++ b/test/data/arrows.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE Arrows #-} + +-- | First argument: basis for a new "pretty" anchor if none exists yet +-- Second argument: a key ("ugly" anchor) +-- Returns: saved "pretty" anchor or created new one +getAnchor :: OdtReaderSafe (AnchorPrefix, Anchor) Anchor +getAnchor = proc (baseIdent, uglyAnchor) -> do + state <- getExtraState -< () + returnA -< prettyAnchor diff --git a/test/tree/a.hs b/test/tree/a.hs new file mode 100644 --- /dev/null +++ b/test/tree/a.hs diff --git a/test/tree/a.txt b/test/tree/a.txt new file mode 100644 --- /dev/null +++ b/test/tree/a.txt diff --git a/test/tree/b.txt b/test/tree/b.txt new file mode 100644 --- /dev/null +++ b/test/tree/b.txt diff --git a/test/tree/sub/b.hs b/test/tree/sub/b.hs new file mode 100644 --- /dev/null +++ b/test/tree/sub/b.hs diff --git a/test/tree/sub/c.hs b/test/tree/sub/c.hs new file mode 100644 --- /dev/null +++ b/test/tree/sub/c.hs diff --git a/test/tree/sub2/a.hs b/test/tree/sub2/a.hs new file mode 100644 --- /dev/null +++ b/test/tree/sub2/a.hs diff --git a/test/tree/sub2/e.hs b/test/tree/sub2/e.hs new file mode 100644 --- /dev/null +++ b/test/tree/sub2/e.hs