diff --git a/appsrc/Main.hs b/appsrc/Main.hs --- a/appsrc/Main.hs +++ b/appsrc/Main.hs @@ -1,94 +1,33 @@ -{-# LANGUAGE DeriveDataTypeable #-} module Main where import Control.Monad.Error (runErrorT, liftIO) import Data.List ( elemIndex ) import Data.Maybe ( mapMaybe, fromMaybe ) -import Data.Version ( showVersion ) import qualified Data.Set as Set -import System.Console.CmdArgs.Implicit -import System.Environment ( getArgs, withArgs ) + import System.Exit ( exitWith, ExitCode(..) ) import System.IO ( hGetContents, stdin ) -import Paths_newt ( version ) import Newt.Newt +import Newt.CmdParsing ( getConfig, Config(..), debug ) import Newt.Inputs import qualified Newt.Inputs as In import Newt.Outputs import qualified Newt.Outputs as Out -data Config = Config { source :: Maybe FilePath - , dest :: Maybe FilePath - , rawTable :: [String] - , list :: Bool - , inplace :: Bool - , prefix :: Maybe String - , suffix :: Maybe String - } deriving (Show, Data, Typeable) - -config :: Config -config = Config { source = def &= name "s" - &= help ("Template source location. Default is to"++ - " read from stdin.") - , dest = def - &= help ("Destination location. Default is to"++ - " write to stdout, but not all inputs"++ - "can be written to stdout.") - , rawTable = def &= args -- the raw key=value pairs - , list = def - &= help ("List the set of keys in the input"++ - " template. This is mutually exclusive"++ - " with output to stdout.") - , inplace = def - &= help ("Populate the source template in-place,"++ - " making destructive changes. This is"++ - " mutually exclusive with output to stdout."++ - " inplace is not yet supported with directory "++ - " template sources.") - , prefix = def - &= help "Specify a custom prefix for the tagged keys" - &= groupname customTags &= explicit &= name "prefix" - &= typ "\"<<<\"" - , suffix = def - &= help "Specify a custom suffix for the tagged keys" - &= groupname customTags &= explicit &= name "suffix" - &= typ "\">>>\"" - } &= summary versionString &= details detailsHeader &= program "newt" - -customTags :: String -customTags = "\nCustomizing tag syntax" - -versionString :: String -versionString = "newt " ++ showVersion version +import Paths_newt ( version ) -detailsHeader :: [String] -detailsHeader = [ "For example:" - , "" - , " Transform in.cabal according to a set of key=value assignments:" - , " $ newt --source=in.cabal --dest=FooApp.cabal name=FooApp "++ - "author=\"Your Name\"" - , "" - , " List the tagged keys in in.cabal:" - , " $ newt --source=in.cabal --list" - , "" - , " List the tagged keys in in.cabal, using cat and stdin:" - , " $ cat in.cabal | newt --list" - ] main :: IO () -main = do conf <- do args <- getArgs - -- if no arguments were specified, print help and exit: - case args of - [] -> withArgs ["--help"] $ cmdArgs config - _ -> cmdArgs config - - simpleTag <- mkSimpleTag $ tagBrackets conf - let table = mapMaybe strToPair $ rawTable conf +main = do conf <- getConfig version + let simpleTag = mkSimpleTag $ tagBrackets conf + table = mapMaybe strToPair $ rawTable conf replace = replaceTable table replacement input output = replaceFile simpleTag replace input output + debug conf ("Using configuration: "++show conf) + res <- runErrorT $ do inSpec <- inputSpec $ source conf if (list conf) @@ -113,12 +52,6 @@ mapM_ putStrLn $ Set.toList tagSet printTags _ fmt = putStrLn ("Unsupported input format: " ++ show fmt) - -printHelp :: IO () -printHelp = putStrLn "Usage: newt [ [key=value]]" - -isPair :: String -> Bool -isPair str = '=' `elem` str strToPair :: String -> Maybe (String, String) strToPair str = do idx <- elemIndex '=' str diff --git a/newt.cabal b/newt.cabal --- a/newt.cabal +++ b/newt.cabal @@ -1,5 +1,5 @@ name: newt -version: 0.0.1.0 +version: 0.0.3.0 synopsis: A trivially simple app to create things from simple templates. description: Instantiates text things from templates. category: Tools @@ -11,21 +11,24 @@ build-type: Simple Extra-source-files: - tests/src/Integration.hs - tests/src/Main.hs - tests/src/ReplaceTests.hs - tests/testFiles/dirTemplates/cabalProject/<<>>.cabal + tests/testFiles/dirTemplates/templateWithImages/<<>>.txt + tests/testFiles/dirTemplates/templateWithImages/<<>>.png + tests/testFiles/dirTemplates/template2/<<>>/in.cabal + tests/testFiles/dirTemplates/template3/<<>>/.gitignore + tests/testFiles/dirTemplates/template3/<<>>/<<>>/.gitignore tests/testFiles/dirTemplates/cabalProject/LICENSE + tests/testFiles/dirTemplates/cabalProject/tests/src/Main.hs + tests/testFiles/dirTemplates/cabalProject/src/<<>>.hs tests/testFiles/dirTemplates/cabalProject/Setup.hs + tests/testFiles/dirTemplates/cabalProject/<<>>.cabal tests/testFiles/dirTemplates/cabalProject/appsrc/Main.hs - tests/testFiles/dirTemplates/cabalProject/src/<<>>.hs - tests/testFiles/dirTemplates/cabalProject/tests/src/Main.hs - tests/testFiles/dirTemplates/template2/<<>>/in.cabal - tests/testFiles/simpleTest/alternate1.txt - tests/testFiles/simpleTest/in.cabal + tests/testFiles/dirTemplates/template1/<<>>/.gitignore tests/testFiles/simpleTest/in.cabal.oracle.1 tests/testFiles/simpleTest/in.cabal.oracle.2 + tests/testFiles/simpleTest/alternate1.txt + tests/testFiles/simpleTest/in.cabal tests/testFiles/simpleTest/simple1.txt + tests/testFiles/sampleImage.png Flag tests Description: Build the tests @@ -37,15 +40,18 @@ Exposed-modules: Newt.Newt, Newt.Inputs, Newt.Outputs, - Newt.Utilities + Newt.Utilities, + Newt.CmdParsing Build-depends: base >= 4 && < 6, filemanip >= 0.3.5.2 && < 0.3.6, mtl >= 2.0.1.0 && < 2.0.2, - regex-base >= 0.93.2 && < 0.94, - regex-pcre >= 0.94.2 && < 0.95, array >= 0.3.0.0 && < 0.4.1, - Unixutils >= 1.36 && < 1.37 + Unixutils >= 1.36 && < 1.37, + safe >= 0.3 && < 0.4, + cmdargs >= 0.6.9 && < 0.6.10, + bytestring >= 0.9.1.10 && < 0.9.2, + text if impl(ghc < 7) Build-depends: containers >= 0.3.0.0 && < 0.5, @@ -96,7 +102,9 @@ test-framework-quickcheck2 >= 0.2.9 && < 0.3, test-framework-hunit >= 0.2.6 && < 0.3, QuickCheck >= 2.4.1.1 && < 2.4.2, - uuid >= 1.2.2 && < 1.2.3 + uuid >= 1.2.2 && < 1.2.3, + Unixutils >= 1.36 && < 1.37, + safe >= 0.3 && < 0.4 if impl(ghc < 7) Build-depends: diff --git a/src/Newt/CmdParsing.hs b/src/Newt/CmdParsing.hs new file mode 100644 --- /dev/null +++ b/src/Newt/CmdParsing.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE DeriveDataTypeable #-} +module Newt.CmdParsing + ( Config(..) + , getConfig + , debug + , versionString + ) where + +import Data.List ( partition ) +import Data.Version ( showVersion, Version ) +import System.Console.CmdArgs.Implicit +import System.Console.CmdArgs.Verbosity ( whenLoud, Verbosity(..), getVerbosity ) +import Safe ( headMay, tailMay ) +import System.Environment ( getArgs, withArgs ) + +import Newt.Utilities ( isValueArg ) + +getConfig :: Version -> IO Config +getConfig version = do rawConf <- do args <- getArgs + -- if no arguments were specified, print help and exit: + case args of + [] -> withArgs ["--help"] $ cmdArgs $ config version + _ -> cmdArgs (config version) + v <- getVerbosity + return $ relaxArgs rawConf { verb = v } + +data Config = Config { source :: Maybe FilePath + , dest :: Maybe FilePath + , rawTable :: [String] + , list :: Bool + , inplace :: Bool + , prefix :: Maybe String + , suffix :: Maybe String + , verb :: Verbosity + } deriving (Show, Data, Typeable) + +config :: Version -> Config +config version = + Config { source = def &= name "s" + &= help ("Template source location. Default is to"++ + " read from stdin.") + , dest = def + &= help ("Destination location. Default is to"++ + " write to stdout, but not all inputs"++ + "can be written to stdout.") + , rawTable = def &= args -- the raw key=value pairs + , list = def + &= help ("List the set of keys in the input"++ + " template. This is mutually exclusive"++ + " with output to stdout.") + , inplace = def + &= help ("Populate the source template in-place,"++ + " making destructive changes. This is"++ + " mutually exclusive with output to stdout."++ + " inplace is not yet supported with directory "++ + " template sources.") + , prefix = def + &= help "Specify a custom prefix for the tagged keys" + &= groupname customTags &= explicit &= name "prefix" + &= typ "\"<<<\"" + , suffix = def + &= help "Specify a custom suffix for the tagged keys" + &= groupname customTags &= explicit &= name "suffix" + &= typ "\">>>\"" + , verb = Normal + } &= summary (versionString version) &= details detailsHeader &= program "newt" &= verbosity + +customTags :: String +customTags = "\nCustomizing tag syntax" + +versionString :: Version -> String +versionString version = "newt " ++ showVersion version + +detailsHeader :: [String] +detailsHeader = [ "For example:" + , "" + , " Transform in.cabal according to a set of key=value assignments:" + , " $ newt --source=in.cabal --dest=FooApp.cabal name=FooApp "++ + "author=\"Your Name\"" + , "" + , " List the tagged keys in in.cabal:" + , " $ newt --source=in.cabal --list" + , "" + , " List the tagged keys in in.cabal, using cat and stdin:" + , " $ cat in.cabal | newt --list" + ] + +-- | Relax the arguments a bit so -s --sourc / etc aren't strictly +-- necessary. +-- +-- If --source is not specified, use the first non-value assignment +-- in args +-- +-- if --dest is also not specified, use the first non-value +-- assignment in args for dest. +-- +-- if neither --source or --dest is specified, use the first +-- non-value assignment for --source and the second for --dest. +relaxArgs :: Config -> Config +relaxArgs conf = let (newSrc, newDest, newTable) = findAltSourceDest (source conf) (dest conf) (partition isValueArg $ rawTable conf) + in conf { source = newSrc + , dest = newDest + , rawTable = newTable + } + +findAltSourceDest :: Maybe FilePath -> Maybe FilePath -> ([String], [String]) -> (Maybe FilePath, Maybe FilePath, [String]) +findAltSourceDest mbSrc mbDest (valueArgs, nonValueArgs) = + case (mbSrc, mbDest) of + (Nothing, Nothing) -> ( headMay nonValueArgs + , tailMay nonValueArgs >>= headMay + , valueArgs) + (Just s, Nothing) -> (Just s, headMay nonValueArgs, valueArgs) + (Nothing, Just d ) -> (headMay nonValueArgs, Just d, valueArgs) + (Just s, Just d ) -> (Just s, Just d, valueArgs) + +debug :: Config -> String -> IO () +debug conf msg = case verb conf of + Loud -> putStrLn msg + _ -> return () diff --git a/src/Newt/Inputs.hs b/src/Newt/Inputs.hs --- a/src/Newt/Inputs.hs +++ b/src/Newt/Inputs.hs @@ -2,13 +2,21 @@ import System.Directory ( doesDirectoryExist, doesFileExist ) +import Control.Exception ( catch, IOException ) import Control.Monad.Error ( ErrorT, throwError, liftIO ) +import Data.Text.Encoding ( decodeUtf8' ) +import Data.Text ( unpack ) +import Prelude hiding (catch) + +-- should be lazy? +import qualified Data.ByteString.Char8 as C8 +import Data.ByteString ( ByteString ) + data InputSpec = StandardIn | TxtFile FilePath | Directory FilePath - -- | TarGz FilePath - -- | Zip FilePath + | BinFile FilePath deriving (Show) inputSpec :: Maybe FilePath -> ErrorT String IO InputSpec @@ -18,5 +26,14 @@ case dirExists of True -> return (Directory pth) False -> case fileExists of - True -> return (TxtFile pth) False -> throwError (pth++" Does not exist!") + True -> do isT <- liftIO $ isText pth + case isT of + True -> return (TxtFile pth) + False -> return (BinFile pth) + +isText :: FilePath -> IO Bool +isText path = do content <- C8.readFile path + return $ case decodeUtf8' content of + Left _ -> False + Right _ -> True diff --git a/src/Newt/Newt.hs b/src/Newt/Newt.hs --- a/src/Newt/Newt.hs +++ b/src/Newt/Newt.hs @@ -3,18 +3,12 @@ import Control.Exception.Base ( IOException ) import Control.Monad ( zipWithM ) import Control.Monad.Error ( ErrorT, runErrorT, liftIO ) -import Data.Array ( elems ) import Data.Foldable ( foldrM ) import Data.Set ( Set ) import qualified Data.Set as Set -import Data.Maybe ( fromMaybe ) -import Text.Regex.PCRE ( Regex ) -import Text.Regex.PCRE.String ( compile, compUngreedy, execBlank, - MatchOffset ) -import Text.Regex.Base.RegexLike ( matchAllText ) import System.Directory ( doesDirectoryExist, getDirectoryContents - , createDirectoryIfMissing ) + , createDirectoryIfMissing, copyFile ) import System.Exit ( exitWith, ExitCode(..) ) import System.FilePath ( () ) import System.FilePath.Find ( findWithHandler, always ) @@ -32,17 +26,33 @@ -- could be located in a file. Currently, this does require that the -- syntax for marking keys is regular. class Tag a where - tagRegex :: a -> Regex - stripTag :: a -> (String -> String) + findTagStart :: a -> String -> Maybe (ShowS, String) + findTagEnd :: a -> String -> Maybe (ShowS, String) + mkSubstKey :: a -> String -> String data TagSyntax = TagSyntax { tagStart :: String , tagEnd :: String - , builtRegex :: Regex } +findTok :: String -> String -> Maybe (ShowS, String) +findTok t = go id + where + go _ "" = Nothing + go acc s@(c:cs) = case dropPrefix t s of + Nothing -> go (acc . (c:)) cs + Just s' -> Just (acc, s') + +dropPrefix :: String -> String -> Maybe String +dropPrefix pfx s = go pfx s + where + go (c1:cs1) (c2:cs2) | c1 == c2 = go cs1 cs2 + go [] s2 = Just s2 + go _ _ = Nothing + instance Tag TagSyntax where - tagRegex tag = builtRegex tag - stripTag (TagSyntax s e _) str = reverse $ drop (length e) $ reverse $ drop (length s) str + findTagStart = findTok . tagStart + findTagEnd = findTok . tagEnd + mkSubstKey t s = tagStart t ++ s ++ tagEnd t -- | The default tag prefix. defaultPrefix :: String @@ -61,30 +71,14 @@ -- which corresponds to tags of the form: -- -- @<<>>@ -mkSimpleTag :: (String, String) -> IO TagSyntax -mkSimpleTag (front, back) = do regex <- mkRegex front back - return $ TagSyntax front back regex - - where mkRegex :: String -> String -> IO Regex - mkRegex front back = do res <- makeRegex (front++".+"++back) - case res of - Left ( _ , err) -> error err - Right regex -> return regex - +mkSimpleTag :: (String, String) -> TagSyntax +mkSimpleTag (front, back) = TagSyntax front back -- | Retrieves the set of @key@s found in a text file. getTagsFile :: Tag a => a -> FilePath -> IO (Set String) getTagsFile tag file = do content <- readFile file return $ getTags tag content --- filesIn :: FilePath -> IO [FilePath] --- filesIn dir = findWithHandler onErr always always dir --- where onErr :: FilePath -> IOException -> IO [FilePath] --- onErr file e = do --- putStrLn ("Error folding over files on: "++file++"\n error:"++show e) --- return [file] - - -- | Collect the key names for every tag in the contents of the -- specified directory. This does currently return tags in the -- directory name itself. That could be confusing, but I think it's a @@ -105,20 +99,18 @@ contentTags file = do dirExists <- doesDirectoryExist file case dirExists of True -> return $ Set.empty -- the recursive case is covered by findWithHandler. - False -> getTagsFile tag file + False -> do isT <- liftIO $ isText file + case isT of + True -> getTagsFile tag file + False -> return $ Set.empty + + onFileIOErr :: FilePath -> IOException -> IO [FilePath] onFileIOErr file e = do putStrLn ("Error folding over files on: "++file++"\n error:"++show e) return [file] --- | Retrieve the set of @key@s found in a given string. -getTags :: Tag a => a -> String -> Set String -getTags tag content = let regexp = tagRegex tag - matches = map (head . elems) (matchAllText regexp content) - toStr (s, _) = (stripTag tag) s - in Set.fromList $ map toStr matches - -- |Compute a replacement for a token type Replace = String -> Maybe String @@ -138,6 +130,10 @@ -- -- XXX: return value should probably be @ErrorT String IO ()@ replaceFile :: Tag a => a -> Replace -> InputSpec -> OutputSpec -> IO () +replaceFile _ _ (BinFile binFile) outSpec = case outSpec of + StandardOut -> putStrLn ("Not copying bin file to stdout: "++binFile) + File file -> copyFile binFile file + Out.Directory _ -> putStrLn ("Inconsistent in/output formats: BinFile -> Dir: " ++ binFile) replaceFile tag replace StandardIn outSpec = do content <- hGetContents stdin let result = populate tag replace content writeTo outSpec result @@ -166,38 +162,33 @@ Left err -> do putStrLn err exitWith (ExitFailure 1) Right _ -> return () - - - replaceFile _ _ _ _ = putStrLn "Unsupported input/output pairing" --- | Replace all the defined keys in a string, returning the populated string. -populate :: Tag a => a -> Replace -> String -> String -populate tag replace template = regexReplace (tagRegex tag) replaceFn template - where stripTags = stripTag tag - replaceFn str = fromMaybe str $ replace $ stripTags str - --- | Helper function for compiling a non-greedy regular expression. --- Might be better written as a result of @ErrorT String IO Regex@ to --- match the other error types in Newt. -makeRegex :: String -> IO (Either (MatchOffset, String) Regex) -makeRegex str = compile compUngreedy execBlank str +findNextTag :: Tag a => a -> String -> Maybe (ShowS, String, String) +findNextTag t s = do + (before, atTagStart) <- findTagStart t s + (substKeyS, atTagEnd) <- findTagEnd t atTagStart + return (before, substKeyS "", atTagEnd) --- | Apply @fn@ to every matched instance of @regexp@ in @input@, --- returning the result. -regexReplace :: Regex -> (String -> String) -> String -> String -regexReplace regexp fn input = - -- matches :: [(String, (Int, Int))] - let matches = map (head . elems) (matchAllText regexp input) - in case matches of - [] -> input - _ -> let (prefix, offset) = foldl (builder input fn) ("", 0) matches - in prefix ++ (drop offset input) +-- |Replace tags in the input string +populate :: Tag a => a -> Replace -> String -> String +populate t subst s = go s "" + where + go here = + case findNextTag t here of + Nothing -> showString here + Just (before, substKey, atTagEnd) -> + let substitution = case subst substKey of + Nothing -> mkSubstKey t substKey + Just newValue -> newValue + in before . showString substitution . go atTagEnd --- | Helper to assemble the replaced strings with the content between --- regular expression matches. -builder :: String -> (String -> String) -> (String, Int) -> (String, (Int, Int)) -> (String, Int) -builder input fn (acc, loc) (str, (offset, len)) = - let filler = take (offset - loc) (drop loc input) - newLoc = offset + len - in (acc ++ filler ++ fn str, newLoc) +-- | Retrieve the set of @key@s found in a given string. +-- empty strings are not valid. +getTags :: Tag a => a -> String -> Set String +getTags tag str = Set.filter (/="") $ go Set.empty str + where + go found s = + case findNextTag tag s of + Nothing -> found + Just (_, k, rest) -> go (Set.insert k found) rest diff --git a/src/Newt/Outputs.hs b/src/Newt/Outputs.hs --- a/src/Newt/Outputs.hs +++ b/src/Newt/Outputs.hs @@ -12,7 +12,8 @@ import qualified Newt.Inputs as In data OutputSpec = StandardOut - | TxtFile FilePath + | File FilePath -- ^ output doesn't distinguish between + -- binary and text files. | Directory FilePath deriving (Show) @@ -24,21 +25,21 @@ fileExists <- liftIO $ doesFileExist pth when (dirExists || fileExists) (throwError (pth++" exists!")) case input of - In.StandardIn -> return $ TxtFile pth - In.TxtFile _ -> return $ TxtFile pth + In.StandardIn -> return $ File pth + In.TxtFile _ -> return $ File pth In.Directory _ -> return $ Directory pth -- | Convert an inputspec into an output spec that represents the same -- source. used for inplace modifications. fromInputSpec :: In.InputSpec -> ErrorT String IO OutputSpec -fromInputSpec (In.TxtFile file) = return $ TxtFile file +fromInputSpec (In.TxtFile file) = return $ File file fromInputSpec (In.Directory dir) = return $ Directory dir fromInputSpec In.StandardIn = throwError "Can not modife stdin inplace." writeTo :: OutputSpec -> String -> IO () -writeTo (TxtFile outFile) str = withTemporaryDirectory "newt-XXXXXX" $ \dir -> do - let tempOut = dir "tempOut" - writeFile tempOut str - copyFile tempOut outFile -writeTo StandardOut str = putStr str -writeTo outSpec _ = error ("Could not write to outspec: "++show outSpec) +writeTo (File outFile) str = withTemporaryDirectory "newt-XXXXXX" $ \dir -> do + let tempOut = dir "tempOut" + writeFile tempOut str + copyFile tempOut outFile +writeTo StandardOut str = putStr str +writeTo outSpec _ = error ("Could not write to outspec: "++show outSpec) diff --git a/src/Newt/Utilities.hs b/src/Newt/Utilities.hs --- a/src/Newt/Utilities.hs +++ b/src/Newt/Utilities.hs @@ -1,13 +1,22 @@ module Newt.Utilities ( copyDirectory , cleanup + , trim + , isValueArg ) where import Prelude hiding ( catch ) import Control.Exception ( IOException, catch, finally ) + +import Data.Char (isSpace) import System.Directory ( removeFile, removeDirectory ) import System.Process ( rawSystem ) + +isValueArg :: String -> Bool +isValueArg str = '=' `elem` str + + -- | Currently using rawSystem -- -- XXX this doesn't do proper exception handling, at all. Sorry about that. @@ -24,7 +33,13 @@ rmIfExists file = catch (removeFile file) (fileFailedHandler file) fileFailedHandler :: FilePath -> IOException -> IO () - fileFailedHandler file e = catch (removeDirectory file) dirFailedHandler + fileFailedHandler file _e = catch (removeDirectory file) dirFailedHandler dirFailedHandler :: IOException -> IO () - dirFailedHandler e = return () + dirFailedHandler _e = return () + + +-- | remove leading / trailing whitespace. +trim :: String -> String +trim = reverse . dropSpaces . reverse . dropSpaces + where dropSpaces = dropWhile isSpace diff --git a/tests/src/Integration.hs b/tests/src/Integration.hs --- a/tests/src/Integration.hs +++ b/tests/src/Integration.hs @@ -8,6 +8,7 @@ import System.Exit ( ExitCode(..) ) import Data.UUID.V1 ( nextUUID ) import Data.UUID +import System.Unix.Directory ( withTemporaryDirectory ) import Prelude hiding (catch) @@ -17,15 +18,29 @@ import Test.Framework.Providers.HUnit import Test.Framework ( testGroup, Test ) +import Data.Version ( showVersion, Version ) +import System.Process ( readProcess ) + import Newt.Utilities +import Newt.CmdParsing ( versionString ) +import Paths_newt ( version ) + tests :: [Test] -tests = [ testGroup "Simple File tests" [ +tests = [ testGroup "sanity tests" [ + testCase "Check the invoked version of Newt against the cabal file" + verifyVersion + ] + , testGroup "Simple File tests" [ testCase "Simple replacement test 1" $ test_simpleReplace "The Author" "in.cabal.oracle.1" , testCase "Simple replacement test 2" $ test_simpleReplace "TheAuthor" "in.cabal.oracle.2" ] + , testGroup "Simple directory tests" [ + testCase "Cabal project generation" $ + test_dirReplace projectTable "cabalProject" "cabalProjectOracle" + ] , testGroup "Inplace modification tests" [ testCase "Inplace replacement test 1" $ test_inplaceReplace "The Author" "in.cabal.oracle.1" @@ -34,6 +49,14 @@ ] ] +-- | Make sure we're actually invoking the version of newt that was just built. +verifyVersion :: Assertion +verifyVersion = do res <- readProcess newtCmd ["--version"] "" + assertEqual "Invoking the wrong version of newt" (trim $ versionString version) (trim res) + +projectTable :: [(String, String)] +projectTable = [ ("projName", "testProj")] + testDir :: FilePath testDir = "tests" "testFiles" @@ -52,21 +75,19 @@ cleanup [tmpFile] $ do -- don't modify the original test input file: copyFile input tmpFile - exitCode <- rawSystem newtCmd ([source] ++ params) - assertEqual "invocation of newt failed" ExitSuccess exitCode + _ <- runNewt ([source] ++ params) -- check file content: assertFilesEqual "Generated file doesn't match" oracle tmpFile test_simpleReplace :: String -> String -> Assertion test_simpleReplace author oracleFile = do tmpFile <- getTmpFileName - let source= "--source=" ++ (testDir "simpleTest" "in.cabal") + let source= "--source="++(testDir "simpleTest" "in.cabal") dest = "--dest="++tmpFile oracle = (testDir "simpleTest" oracleFile) - params = [ "name=myProject" - , "author="++author] + table = [ "name=myProject" + , "author=" ++ author ] cleanup [tmpFile] $ do - exitCode <- rawSystem newtCmd ([source, dest] ++ params) - assertEqual "invocation of newt failed" ExitSuccess exitCode + _ <- runNewt (table ++ [source, dest]) -- check file content: assertFilesEqual "Generated file doesn't match" oracle tmpFile @@ -75,6 +96,12 @@ suspectTxt <- readFile suspect assertEqual msg oracleTxt suspectTxt +-- assertFilePathEqual :: String -> FilePath -> FilePath +-- assertFilePathEqual msg oracle suspect = + +assertDirsEqual :: String -> FilePath -> FilePath -> Assertion +assertDirsEqual msg oracle suspect = assertEqual msg False True + -- | Generates a filename with a uuid in either the system temp -- directory or the current directory (if the system temp dir can't be -- found). Does not create the file, or verify uniqueness, just @@ -86,34 +113,15 @@ where errHandler :: IOException -> IO FilePath errHandler _ = return "." --- {- This function takes two parameters: a filename pattern and another --- function. It will create a temporary file, and pass the name and Handle --- of that file to the given function. - --- The temporary file is created with openTempFile. The directory is the one --- indicated by getTemporaryDirectory, or, if the system has no notion of --- a temporary directory, "." is used. The given pattern is passed to --- openTempFile. - --- After the given function terminates, even if it terminates due to an --- exception, the Handle is closed and the file is deleted. -} --- withTempFile :: String -> (FilePath -> Handle -> IO a) -> IO a --- withTempFile pattern func = --- do -- The library ref says that getTemporaryDirectory may raise on --- -- exception on systems that have no notion of a temporary directory. --- -- So, we run getTemporaryDirectory under catch. catch takes --- -- two functions: one to run, and a different one to run if the --- -- first raised an exception. If getTemporaryDirectory raised an --- -- exception, just use "." (the current working directory). --- tempdir <- catch (getTemporaryDirectory) (\_ -> return ".") --- (tempfile, temph) <- openTempFile tempdir pattern +runNewt :: [String] -> IO ExitCode +runNewt params = do -- putStrLn ("Invoking newt: "++show params) + exitCode <- rawSystem newtCmd params + assertEqual "invocation of newt failed" ExitSuccess exitCode + return exitCode --- -- Call (func tempfile temph) to perform the action on the temporary --- -- file. finally takes two actions. The first is the action to run. --- -- The second is an action to run after the first, regardless of --- -- whether the first action raised an exception. This way, we ensure --- -- the temporary file is always deleted. The return value from finally --- -- is the first action's return value. --- finally (func tempfile temph) --- (do hClose temph --- removeFile tempfile) +test_dirReplace :: [(String, String)] -> FilePath -> FilePath -> Assertion +test_dirReplace table inDir oracle = withTemporaryDirectory "newt-XXXXXX" $ \dir -> do + let outDir = dir oracle + params = map (\(k,v)->k++"="++v) table + _ <- runNewt (params ++ ["--source="++inDir, "--dest="++outDir]) + assertDirsEqual "Directory replacement failed." oracle outDir diff --git a/tests/src/Main.hs b/tests/src/Main.hs --- a/tests/src/Main.hs +++ b/tests/src/Main.hs @@ -3,6 +3,7 @@ import qualified Integration as Integration import qualified ReplaceTests as ReplaceTests +import qualified UtilityTests as UtilityTests import Test.Framework ( defaultMain ) @@ -10,5 +11,6 @@ main :: IO () main = do replaceTests <- ReplaceTests.tests - defaultMain $ concat [ replaceTests + defaultMain $ concat [ UtilityTests.tests + , replaceTests , Integration.tests ] diff --git a/tests/src/ReplaceTests.hs b/tests/src/ReplaceTests.hs --- a/tests/src/ReplaceTests.hs +++ b/tests/src/ReplaceTests.hs @@ -2,26 +2,31 @@ import qualified Data.Set as Set +import Safe + import Test.HUnit ( (@=?) ) -import Test.QuickCheck ( Property ) +import Test.QuickCheck ( Property, (==>) ) +import Test.QuickCheck.Property () import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.Framework.Providers.HUnit import Test.Framework ( testGroup, Test ) import Newt.Newt ( populate, Replace, Table, replaceTable, Tag , defaultPrefix, defaultSuffix, mkSimpleTag - , getTags) + , getTags, getTagsDirectory ) +import TestUtilities + tests :: IO [Test] -tests = do defaultTag <- mkSimpleTag (defaultPrefix, defaultSuffix) - dashTag <- mkSimpleTag ("---", "---") +tests = do let defaultTag = mkSimpleTag (defaultPrefix, defaultSuffix) + dashTag = mkSimpleTag ("---", "---") return $ [ testGroup "populate" $ concat [map (testPopulate defaultTag $ replaceTable replacements) [ ("Empty string", "", "") , ("Empty tag", "<<<>>>", "<<<>>>") , ("Empty tag", "<<>>", "v") - , ("Nested tag", "<<<<<>>>>>", "<<>>") - , ("Simple confusing context", "<<<>>", ">>>>>", "<<<<<>>>>>") + , ("Simple confusing context", "<<<>>", "<<<>>") , ("Unknown key", "<<>>", "<<>>") , ("key uses prefix", "<<>>", "ok") , ("Multi-tag 1", "<<>> <<>>", "v v") @@ -41,36 +46,49 @@ [ ("Empty string", "", []) , ("Empty tag", "<<<>>>", []) , ("Empty tag", "<<>>", ["k"]) - , ("Nested tag", "<<<<<>>>>>", ["<<>>"]) - , ("Simple confusing context", "<<<>>", ["k"]) + , ("Nested tag", "<<<<<>>>>>", ["<<>>", [">>", ["key<<>> <<>>", ["k"]) , ("Multi-tag 2", "<<>> <<>>", ["k", "key"]) , ("Multi-tag 3", "<<>><<>> <<>>", ["k", "key"]) ] - , [ testProperty "random content, default tag" $ - prop_getTags defaultTag defaultPrefix defaultSuffix - , testProperty "random content, dash tag" $ - prop_getTags dashTag "---" "---" - ] + -- , [ testProperty "random content, default tag" $ + -- prop_getTags defaultTag defaultPrefix defaultSuffix + -- , testProperty "random content, dash tag" $ + -- prop_getTags dashTag "---" "---" + -- ] ] + , testGroup "getTagsDirectory" $ map (testGetTagsDirectory defaultTag) [ + ("Cabal Project", "tests/testFiles/dirTemplates/cabalProject", + ["author", "authoremail", "description", "projName", "synopsis", "year"]) + , ("Sample Image Proj", "tests/testFiles/dirTemplates/templateWithImages", + ["name", "inner"]) + ] ] -- | Generate random strings, slap a key between them, and see if newt -- can do the replacement: -prop_populateKeyInRandStr :: Tag a => a -> String -> String -> Table -> String -> String -> Bool -prop_populateKeyInRandStr tag tPrefix tSuffix table pfx sfx = +prop_populateKeyInRandStr :: Tag a => a -> String -> String -> Table -> String -> Char -> String -> Char -> Property +prop_populateKeyInRandStr tag tPrefix tSuffix table pfx pCh sfx sCh = (Just pCh) /= headMay tPrefix && + (Just sCh) /= lastMay tSuffix ==> let key = (fst . head) table value = (snd . head) table - input = pfx ++ tPrefix ++ key ++ tSuffix ++ sfx - oracle = pfx ++ value ++ sfx + input = pfx ++ [pCh] ++ tPrefix ++ key ++ tSuffix ++ [sCh] ++ sfx + oracle = pfx ++ [pCh] ++ value ++ [sCh] ++ sfx in populate tag (replaceTable table) input == oracle -prop_getTags :: Tag a => a -> String -> String -> [(String, String)] -> String -> Bool -prop_getTags tag tPrefix tSuffix keys end = - let input = foldr (\(filler, key) front -> front ++ filler ++ tPrefix ++ key ++ tSuffix) end keys - oracle = Set.fromList $ map snd keys +emptyKorV :: (String, String) -> Bool +emptyKorV ("", _ ) = True +emptyKorV (_ , "") = True +emptyKorV (_ , _ ) = False + +prop_getTags :: Tag a => a -> String -> String -> [(String, String)] -> String -> Property +prop_getTags tag tPrefix tSuffix keys end = filter (not . emptyKorV) keys /= [] ==> + let filteredTable = filter (not . emptyKorV) keys + input = foldr (\(filler, key) front -> front ++ filler ++ tPrefix ++ key ++ tSuffix) end filteredTable + oracle = Set.fromList $ map snd filteredTable in getTags tag input == oracle replacements :: Table @@ -81,11 +99,15 @@ ] testPopulate :: Tag a => a -> Replace -> (String, String, String) -> Test -testPopulate tag fn (descr, input, oracle) = - testCase (descr++" input: "++show input) assert - where assert = oracle @=? populate tag fn input +testPopulate tag fn = genTest (populate tag fn) testGetTags :: Tag a => a -> (String, String, [String]) -> Test testGetTags tag (descr, input, oracle) = testCase (descr++" input: "++show input) assert where assert = Set.fromList oracle @=? getTags tag input + +testGetTagsDirectory :: Tag a => a -> (String, String, [String]) -> Test +testGetTagsDirectory tag (descr, input, oracle) = + testCase (descr++" input: "++show input) assert + where assert = do tags <- getTagsDirectory tag input + Set.fromList oracle @=? tags diff --git a/tests/testFiles/dirTemplates/template1/<<>>/.gitignore b/tests/testFiles/dirTemplates/template1/<<>>/.gitignore new file mode 100644 --- /dev/null +++ b/tests/testFiles/dirTemplates/template1/<<>>/.gitignore diff --git a/tests/testFiles/dirTemplates/template3/<<>>/.gitignore b/tests/testFiles/dirTemplates/template3/<<>>/.gitignore new file mode 100644 --- /dev/null +++ b/tests/testFiles/dirTemplates/template3/<<>>/.gitignore diff --git a/tests/testFiles/dirTemplates/template3/<<>>/<<>>/.gitignore b/tests/testFiles/dirTemplates/template3/<<>>/<<>>/.gitignore new file mode 100644 --- /dev/null +++ b/tests/testFiles/dirTemplates/template3/<<>>/<<>>/.gitignore diff --git a/tests/testFiles/dirTemplates/templateWithImages/<<>>.png b/tests/testFiles/dirTemplates/templateWithImages/<<>>.png new file mode 100644 Binary files /dev/null and b/tests/testFiles/dirTemplates/templateWithImages/<<>>.png differ diff --git a/tests/testFiles/dirTemplates/templateWithImages/<<>>.txt b/tests/testFiles/dirTemplates/templateWithImages/<<>>.txt new file mode 100644 --- /dev/null +++ b/tests/testFiles/dirTemplates/templateWithImages/<<>>.txt @@ -0,0 +1,1 @@ +test with <<>> content. diff --git a/tests/testFiles/sampleImage.png b/tests/testFiles/sampleImage.png new file mode 100644 Binary files /dev/null and b/tests/testFiles/sampleImage.png differ