diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -2,6 +2,12 @@ ## Unreleased changes -## 0.1.0.0 +## 0.0.2.0 + +- [#4](https://github.com/parsonsmatt/glob-imports/pull/4) + - You may now pass `--search-dir`, `--pattern`, and `--excluded-prefixes` to + configure and customize where the program searches for imports to glob. + +## 0.0.1.0 - Initial Release diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,20 +1,73 @@ module Main where import GlobImports.Exe +import Options.Applicative import System.IO (readFile') -import System.Environment (getArgs) -main :: IO () -main = do - args <- getArgs - case args of - src : fileInput : dest : _ -> do - contents <- readFile' fileInput - spliceImports (Source src) (SourceContents contents) (Destination dest) - _ -> - fail . mconcat $ - [ "glob-imports: expected to be called with three arguments as an -F -pgmF preprocessor. got:" - , show args - ] +data Args = Args + { argsOriginalFile :: FilePath + , argsSourceFile :: FilePath + , argsDest :: FilePath + , argsSearchDir :: Maybe FilePath + , argsPattern :: String + , argsExcludedPrefixes :: String + , argsDebug :: Bool + } + deriving (Show) +parseArgs :: IO Args +parseArgs = + execParser $ + info + ( Args + <$> originalFileParser + <*> sourceFileParser + <*> destFileParser + <*> searchDirParser + <*> patternParser + <*> excludedPrefixesParser + <*> debugParser + ) + mempty + where + originalFileParser = argument str (metavar "ORIGINAL_FILE") + sourceFileParser = argument str (metavar "SOURCE_FILE") + destFileParser = argument str (metavar "DEST_FILE") + searchDirParser = + optional . (option str) $ + long "search-dir" + <> metavar "SEARCH_DIR" + <> help "Directory to search for files in" + patternParser = + option str $ + long "pattern" + <> metavar "PATTERN" + <> help "Pattern on which to match file paths" + <> value "**/*.hs" + excludedPrefixesParser = + option str $ + long "exclude-prefixes" + <> metavar "PREFIXES" + <> help "File path prefixes to exclude" + <> value "" + debugParser = + switch $ + long "debug" + <> help "Whether to print debug output" +main :: IO () +main = do + args <- parseArgs + contents <- readFile' $ argsSourceFile args + spliceImports + (Source $ argsSourceFile args) + (SourceContents $ contents) + (Destination $ argsDest args) + (argsSearchDir args) + (argsPattern args) + (splitOn ',' (argsExcludedPrefixes args)) + (argsDebug args) + where + splitOn _ [] = [] + splitOn sep xs = + takeWhile (/= sep) xs : splitOn sep (drop 1 $ dropWhile (/= sep) xs) diff --git a/glob-imports.cabal b/glob-imports.cabal --- a/glob-imports.cabal +++ b/glob-imports.cabal @@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.4. +-- This file has been generated from package.yaml by hpack version 0.38.1. -- -- see: https://github.com/sol/hpack name: glob-imports -version: 0.0.1.0 +version: 0.0.2.0 synopsis: Import modules for metaprogramming description: This package provides an executable for importing modules in a directory and splicing those in. Please see the README on GitHub at category: Metaprogramming diff --git a/src/GlobImports/Exe.hs b/src/GlobImports/Exe.hs --- a/src/GlobImports/Exe.hs +++ b/src/GlobImports/Exe.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + -- | This preprocessor splices in imports to the file you define it in. Haskell -- source files are discovered according to a glob relative to the file the code -- is defined in. This utility is useful when metaprogramming with a group of @@ -21,7 +23,7 @@ -- @ -- -- src/PersistentModels/All.hs -- --- {-# OPTIONS_GHC -F -pgmF persistent-discover #-} +-- {\-# OPTIONS_GHC -F -pgmF persistent-discover #-\} -- @ -- -- Then it will translate to: @@ -45,12 +47,12 @@ -- @ -- -- src/PersistentModels/All.hs -- --- {-# OPTIONS_GHC -F -pgmF glob-imports #-} +-- {\-# OPTIONS_GHC -F -pgmF glob-imports #-\} -- -- module PersistentModels.All where -- -- import Database.Persist.Sql --- {- GLOB_IMPORTS_SPLICE -} +-- {\- GLOB_IMPORTS_SPLICE -\} -- -- allEntityDefs :: [EntityDef] -- allEntityDefs = $(discoverEntities) @@ -78,36 +80,39 @@ -- @since 0.1.0.0 module GlobImports.Exe where -import System.FilePath -import Control.Monad (guard, filterM) -import Control.Monad.State -import Data.String -import Data.DList (DList(..)) -import qualified Data.DList as DList -import Data.Foldable (for_) -import System.Directory -import Data.List -import Data.Char import Control.Applicative +import Control.Exception (SomeException, catch) +import Control.Monad (guard, when) +import qualified Data.ByteString.Lazy as LBS +import Data.Char +import Data.List +import Data.List.Split (splitOn) import Data.Maybe +import qualified Data.Text as Text +import Data.Text.Encoding (encodeUtf8, decodeUtf8) +import System.FilePath +import System.Process.Typed -- | The source file location. This is the first argument passed to the -- preprocessor. -newtype Source = Source { unSource :: FilePath } +newtype Source = Source {unSource :: FilePath} -- | The source file contents. This is the 'String' contained in the file of the -- second argument passed to the preprocessor. -newtype SourceContents = SourceContents { unSourceContents :: String } +newtype SourceContents = SourceContents {unSourceContents :: String} -- | The destination file path to write the final source to. This is the third -- argument passed to the preprocessor. -newtype Destination = Destination { unDestination :: FilePath } +newtype Destination = Destination {unDestination :: FilePath} data AllModelsFile = AllModelsFile { amfModuleBase :: Module , amfModuleImports :: [Module] } +printDebug :: Bool -> String -> IO () +printDebug enabled str = when enabled $ putStrLn ("[DEBUG] " ++ str) + -- | -- -- @since 0.1.0.0 @@ -115,43 +120,76 @@ :: Source -> SourceContents -> Destination + -> Maybe FilePath + -> String + -> [String] + -> Bool -> IO () -spliceImports (Source src) (SourceContents srcContents) (Destination dest) = do - let (dir, file) = splitFileName src - files <- filter (/= file) <$> getFilesRecursive dir +spliceImports (Source src) (SourceContents srcContents) (Destination dest) msearchDir pat prefixes debug = do let + (sourceDir, _file) = splitFileName src + searchDir = fromMaybe sourceDir msearchDir + excludePrefixFilter target = not $ any (`isPrefixOf` target) prefixes + + printDebug debug $ "searching directory: " ++ searchDir + printDebug debug $ "searching with pattern: " ++ pat + printDebug debug $ "excluding file name: " ++ src + eitherFiles <- fmap (filter (essentiallyDistinct src)) <$> getFiles searchDir pat + files <- case eitherFiles of + Left e -> error e + Right f -> pure f + let + filteredFiles = filter excludePrefixFilter files + printDebug debug $ "including files:\n" ++ intercalate "\n| " filteredFiles + let input = AllModelsFile { amfModuleBase = fromJust $ pathToModule src , amfModuleImports = - mapMaybe pathToModule (fmap (dir ) files) + mapMaybe pathToModule (fmap (searchDir ) filteredFiles) } output = renderFile input srcContents writeFile dest output + where + essentiallyDistinct :: FilePath -> FilePath -> Bool + essentiallyDistinct l r = simplifyPath l /= simplifyPath r + simplifyPath :: String -> String + simplifyPath = (intercalate "/") . (filter (/= mempty)) . (splitOn "/") -- | Returns a list of relative paths to all files in the given directory. -getFilesRecursive +getFiles :: FilePath + -- ^ The glob pattern to filter with. + -> String -- ^ The directory to search. - -> IO [FilePath] -getFilesRecursive baseDir = sort <$> go [] - where - go :: FilePath -> IO [FilePath] - go dir = do - c <- map (dir ) . filter (`notElem` [".", ".."]) <$> getDirectoryContents (baseDir dir) - dirs <- filterM (doesDirectoryExist . (baseDir )) c >>= mapM go - files <- filterM (doesFileExist . (baseDir )) c - return (files ++ concat dirs) + -> IO (Either String [FilePath]) +getFiles baseDir pat = do + (exitCode, out, err) <- (readProcess $ proc "find" [baseDir, "-wholename", pat]) `catch` handler + pure $ case exitCode of + ExitSuccess -> Right . lines . Text.unpack . decodeUtf8 . LBS.toStrict $ out + ExitFailure _ -> Left . Text.unpack . decodeUtf8 . LBS.toStrict $ err + where + handler :: SomeException -> IO (ExitCode, LBS.ByteString, LBS.ByteString) + handler e = do + pure $ ( ExitFailure 1 + , "" + , mconcat [ "unable to invoke `find`. Please make sure that `find` is executable and in PATH.\n" + , "(" + , LBS.fromStrict . encodeUtf8 . Text.pack $ show e + , ")\n" + ] + ) renderFile :: AllModelsFile -> String -> String renderFile amf originalContents = - concatMap unlines + concatMap + unlines [ modulePrior , newImportLines , newModuleRest @@ -163,13 +201,14 @@ (modulePrior, moduleRest) = case break ("GLOB_IMPORTS_SPLICE" `isInfixOf`) originalLines of (_, []) -> - error $ unlines - [ "While processing the module, I was unable to find a comment with GLOB_IMPORTS_SPLICE." - , "I need this to know where to splice imports into the file. Please add a comment like " - , "this to the source file in the import section: " - , "" - , "-- GLOB_IMPORTS_SPLICE" - ] + error $ + unlines + [ "While processing the module, I was unable to find a comment with GLOB_IMPORTS_SPLICE." + , "I need this to know where to splice imports into the file. Please add a comment like " + , "this to the source file in the import section: " + , "" + , "-- GLOB_IMPORTS_SPLICE" + ] (prior, (_globImportLine : rest)) -> (prior, rest) @@ -191,65 +230,15 @@ [ "_importedModules :: [String]" , "_importedModules =" , mkFirstModuleLine firstModule - ] <> map mkRestModuleLine restModules - <> [ " ]"] + ] + <> map mkRestModuleLine restModules + <> [" ]"] in reverse (concat [remainingModule, newLines, lastImportLine]) newImportLines = map (\mod' -> "import qualified " <> moduleName mod') (amfModuleImports amf) - - - - - - --- render do --- let --- modName = --- moduleName $ amfModuleBase amf --- renderLine do --- "{-# LINE 1 " --- fromString $ show modName --- " #-}" --- "{-# LANGUAGE TemplateHaskell #-}" --- "" --- renderLine do --- "module " --- fromString $ modName --- " where" --- "" --- for_ (amfModuleImports amf) \mod' -> --- renderLine do --- "import " --- fromString $ moduleName mod' --- " ()" --- "" --- "import Database.Persist.TH (discoverEntities)" --- "import Database.Persist.Types (EntityDef)" --- "" --- "-- | All of the entity definitions, as discovered by the @glob-imports@ utility." --- "allEntityDefs :: [EntityDef]" --- "allEntityDefs = $(discoverEntities)" --- --- -- -- | Derive module name from specified path. --- -- pathToModule :: FilePath -> Module --- -- pathToModule f = --- -- Module --- -- { moduleName = --- -- intercalate "." $ mapMaybe go $ splitDirectories f --- -- , modulePath = --- -- f --- -- } --- -- where --- -- go :: String -> Maybe String --- -- go (c:cs) = --- -- Just (toUpper c : cs) --- -- fileName = last $ splitDirectories f --- -- m:ms = takeWhile (/='.') fileName - --- | data Module = Module { moduleName :: String , modulePath :: FilePath @@ -277,7 +266,7 @@ isLowerFirst :: String -> Bool isLowerFirst [] = True -isLowerFirst (c:_) = isLower c +isLowerFirst (c : _) = isLower c pathToModule :: FilePath @@ -286,18 +275,19 @@ case mkModulePieces file of [] -> empty - x : xs -> do + x : xs -> do guard $ all isValidModuleName (x : xs) - pure Module - { moduleName = intercalate "." (x:xs) - , modulePath = file - } + pure + Module + { moduleName = intercalate "." (x : xs) + , modulePath = file + } -- | Returns True if the given string is a valid task module name. -- See `Cabal.Distribution.ModuleName` (http://git.io/bj34) isValidModuleName :: String -> Bool isValidModuleName [] = False -isValidModuleName (c:cs) = isUpper c && all isValidModuleChar cs +isValidModuleName (c : cs) = isUpper c && all isValidModuleChar cs -- | Returns True if the given Char is a valid taks module character. isValidModuleChar :: Char -> Bool @@ -307,6 +297,6 @@ casify :: String -> String casify str = intercalate "_" $ groupBy (\a b -> isUpper a && isLower b) str -stripSuffix :: Eq a => [a] -> [a] -> Maybe [a] +stripSuffix :: (Eq a) => [a] -> [a] -> Maybe [a] stripSuffix suffix str = reverse <$> stripPrefix (reverse suffix) (reverse str)