diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +Copyright (c) 2011, Eugene Rogan Creswick +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. + +Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in the +documentation and/or other materials provided with the distribution. + +Neither the name of Eugene Rogan Creswick nor the names of his +contributors may be used to endorse or promote products derived from +this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/appsrc/Main.hs b/appsrc/Main.hs new file mode 100644 --- /dev/null +++ b/appsrc/Main.hs @@ -0,0 +1,126 @@ +{-# 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.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 + +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 + replace = replaceTable table + replacement input output = replaceFile simpleTag replace input output + + res <- runErrorT $ do + inSpec <- inputSpec $ source conf + if (list conf) + then liftIO $ printTags simpleTag inSpec + else do outSpec <- outputSpec (inplace conf) inSpec $ dest conf + liftIO $ replacement inSpec outSpec + case res of + Left err -> do putStrLn err + exitWith (ExitFailure 1) + Right _ -> return () + +tagBrackets :: Config -> (String, String) +tagBrackets conf = ( fromMaybe defaultPrefix $ prefix conf, + fromMaybe defaultSuffix $ prefix conf) + +printTags :: Tag a => a -> InputSpec -> IO () +printTags tag StandardIn = do content <- hGetContents stdin + mapM_ putStrLn $ Set.toList $ getTags tag content +printTags tag (In.TxtFile file) = do tagSet <- getTagsFile tag file + mapM_ putStrLn $ Set.toList tagSet +printTags tag (In.Directory pth) = do tagSet <- getTagsDirectory tag pth + 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 + let (key, rawValue) = splitAt idx str + return (key, tail rawValue) diff --git a/newt.cabal b/newt.cabal new file mode 100644 --- /dev/null +++ b/newt.cabal @@ -0,0 +1,121 @@ +name: newt +version: 0.0.1.0 +synopsis: A trivially simple app to create things from simple templates. +description: Instantiates text things from templates. +category: Tools +license: BSD3 +License-file: LICENSE +author: Rogan Creswick +maintainer: creswick@gmail.com +Cabal-Version: >=1.8.0.6 +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/cabalProject/LICENSE + tests/testFiles/dirTemplates/cabalProject/Setup.hs + 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/simpleTest/in.cabal.oracle.1 + tests/testFiles/simpleTest/in.cabal.oracle.2 + tests/testFiles/simpleTest/simple1.txt + +Flag tests + Description: Build the tests + Default: False + + +Library + hs-source-dirs: src + Exposed-modules: Newt.Newt, + Newt.Inputs, + Newt.Outputs, + Newt.Utilities + + 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 + if impl(ghc < 7) + Build-depends: + containers >= 0.3.0.0 && < 0.5, + directory >= 1.0.1.1 && < 1.1.1, + process >= 1.0.1.3 && < 1.0.2, + filepath >= 1.1.0.0 && < 1.1.0.5 + else + Build-depends: + containers >= 0.4.0.0 && < 0.5, + directory >= 1.1.0.0 && < 1.1.1, + process >= 1.0.1.5 && < 1.0.2, + filepath >= 1.2.0.0 && < 1.2.1 + + ghc-options: -Wall + + +Executable newt + Main-Is: Main.hs + hs-source-dirs: appsrc + + Build-depends: newt, + base >= 4 && < 6, + mtl >= 2.0.1.0 && < 2.0.2, + cmdargs >= 0.6.9 && < 0.6.10 + + if impl(ghc < 7) + Build-depends: + containers >= 0.3.0.0 && < 0.5 + else + Build-depends: + containers >= 0.4.0.0 && < 0.5 + + + ghc-options: -Wall + +Executable test-newt + if !flag(tests) + Buildable: False + + Main-is: Main.hs + + Hs-Source-Dirs: tests/src + + Build-depends: newt, + base >= 4 && < 6, + HUnit >= 1.2.2 && < 1.2.3, + test-framework >= 0.3.3 && < 0.4, + 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 + + if impl(ghc < 7) + Build-depends: + containers >= 0.3.0.0 && < 0.5, + directory >= 1.0.1.1 && < 1.1.1, + process >= 1.0.1.3 && < 1.0.2, + filepath >= 1.1.0.0 && < 1.1.0.5 + else + Build-depends: + containers >= 0.4.0.0 && < 0.5, + directory >= 1.1.0.0 && < 1.1.1, + process >= 1.0.1.5 && < 1.0.2, + filepath >= 1.2.0.0 && < 1.2.1 + + Other-modules: Integration, + ReplaceTests + + GHC-Options: -Wall + +source-repository head + type: git + location: git://github.com/creswick/Newt.git diff --git a/src/Newt/Inputs.hs b/src/Newt/Inputs.hs new file mode 100644 --- /dev/null +++ b/src/Newt/Inputs.hs @@ -0,0 +1,22 @@ +module Newt.Inputs where + +import System.Directory ( doesDirectoryExist, doesFileExist ) + +import Control.Monad.Error ( ErrorT, throwError, liftIO ) + +data InputSpec = StandardIn + | TxtFile FilePath + | Directory FilePath + -- | TarGz FilePath + -- | Zip FilePath + deriving (Show) + +inputSpec :: Maybe FilePath -> ErrorT String IO InputSpec +inputSpec Nothing = return StandardIn +inputSpec (Just pth) = do dirExists <- liftIO $ doesDirectoryExist pth + fileExists <- liftIO $ doesFileExist pth + case dirExists of + True -> return (Directory pth) + False -> case fileExists of + True -> return (TxtFile pth) + False -> throwError (pth++" Does not exist!") diff --git a/src/Newt/Newt.hs b/src/Newt/Newt.hs new file mode 100644 --- /dev/null +++ b/src/Newt/Newt.hs @@ -0,0 +1,203 @@ +module Newt.Newt where + +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 ) +import System.Exit ( exitWith, ExitCode(..) ) +import System.FilePath ( () ) +import System.FilePath.Find ( findWithHandler, always ) +import System.FilePath.Posix ( makeRelative ) +import System.IO ( hGetContents, stdin ) + + + +import Newt.Inputs +import qualified Newt.Inputs as In +import Newt.Outputs +import qualified Newt.Outputs as Out + +-- | Tag is an abstraction layer over the ways in which a given @key@ +-- 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) + +data TagSyntax = TagSyntax { tagStart :: String + , tagEnd :: String + , builtRegex :: Regex + } + +instance Tag TagSyntax where + tagRegex tag = builtRegex tag + stripTag (TagSyntax s e _) str = reverse $ drop (length e) $ reverse $ drop (length s) str + +-- | The default tag prefix. +defaultPrefix :: String +defaultPrefix = "<<<" + +-- | The default tag suffix. +defaultSuffix :: String +defaultSuffix = ">>>" + +-- | Create a simple 'tag', the pair of syntactic markers that +-- indicate where in a body of text to stick a value. For example, +-- the defaults tag is created with: +-- +-- > mkSimpleTag ("<<<", ">>>") +-- +-- 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 + + +-- | 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 +-- corner case. +-- +-- XXX: Does not check to see if dir is actually a directory. +getTagsDirectory :: Tag a => a -> FilePath -> IO (Set String) +getTagsDirectory tag dir = do fileList <- findWithHandler onFileIOErr always always dir + foldrM acc Set.empty fileList + where acc :: FilePath -> Set String -> IO (Set String) + acc file set = do cTags <- contentTags file + return $ Set.unions [ set + , getTags tag file -- get the tags from the file name. + , cTags -- the content tags. + ] + + contentTags :: FilePath -> IO (Set String) + contentTags file = do dirExists <- doesDirectoryExist file + case dirExists of + True -> return $ Set.empty -- the recursive case is covered by findWithHandler. + False -> getTagsFile tag file + +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 + +-- |A table of replacements +type Table = [(String, String)] + +-- |Compute a template replacement by looking up in a table +replaceTable :: Table -> Replace +replaceTable t = \k -> lookup k t + +-- | Replace all the defined keys in a template, writing the template +-- out to the specified destination. +-- +-- `replaceFile` performs IO as necessary to read/write templates and +-- results. It is also poorly named: it operates on any input/output +-- spec. +-- +-- XXX: return value should probably be @ErrorT String IO ()@ +replaceFile :: Tag a => a -> Replace -> InputSpec -> OutputSpec -> IO () +replaceFile tag replace StandardIn outSpec = do content <- hGetContents stdin + let result = populate tag replace content + writeTo outSpec result +replaceFile tag replace (In.TxtFile inFile) outSpec = do content <- readFile inFile + let result = populate tag replace content + writeTo outSpec result +replaceFile tag replace (In.Directory inDir) (Out.Directory outDir) = do + -- create the incomming dir. This hapens first so the initial + -- invocation doesn't do string replacement on the dir name. + createDirectoryIfMissing True outDir + -- get all the directory entries: + inPaths <- do tempPaths <- getDirectoryContents inDir + return $ map (inDir ) (filter (\x-> (x /= ".") && (x /= "..")) tempPaths) + + let outPaths = map inToOut inPaths + inToOut f = Just (outDir -- prepend the output dir to the paths. + (populate tag replace -- run substitutions on file names. + (makeRelative inDir f))) -- get the relative locations for the incoming template files/dirs + + res <- runErrorT $ do + inList <- mapM inputSpec (map Just inPaths) + outList <- zipWithM (outputSpec False) inList outPaths + liftIO $ zipWithM (replaceFile tag replace) inList outList + -- TODO replaceFile should return ErrorT String IO (), so this won't be necessary: + case res of + 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 + +-- | 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) + +-- | 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) diff --git a/src/Newt/Outputs.hs b/src/Newt/Outputs.hs new file mode 100644 --- /dev/null +++ b/src/Newt/Outputs.hs @@ -0,0 +1,44 @@ +module Newt.Outputs where + +import System.Directory ( doesDirectoryExist, doesFileExist + , copyFile ) +import System.FilePath ( () ) +import System.Unix.Directory ( withTemporaryDirectory ) +import Control.Monad ( when ) +import Control.Monad.Error ( ErrorT, throwError, liftIO ) + + + +import qualified Newt.Inputs as In + +data OutputSpec = StandardOut + | TxtFile FilePath + | Directory FilePath + deriving (Show) + +outputSpec :: Bool -> In.InputSpec -> Maybe FilePath -> ErrorT String IO OutputSpec +outputSpec True inSpec _ = fromInputSpec inSpec +outputSpec False (In.Directory _) Nothing = throwError "Can not write directory input to standard output!" +outputSpec False _ Nothing = return StandardOut -- should check for compatability +outputSpec False input (Just pth) = do dirExists <- liftIO $ doesDirectoryExist pth + fileExists <- liftIO $ doesFileExist pth + when (dirExists || fileExists) (throwError (pth++" exists!")) + case input of + In.StandardIn -> return $ TxtFile pth + In.TxtFile _ -> return $ TxtFile 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.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) diff --git a/src/Newt/Utilities.hs b/src/Newt/Utilities.hs new file mode 100644 --- /dev/null +++ b/src/Newt/Utilities.hs @@ -0,0 +1,30 @@ +module Newt.Utilities + ( copyDirectory + , cleanup + ) where + +import Prelude hiding ( catch ) +import Control.Exception ( IOException, catch, finally ) +import System.Directory ( removeFile, removeDirectory ) +import System.Process ( rawSystem ) + +-- | Currently using rawSystem +-- +-- XXX this doesn't do proper exception handling, at all. Sorry about that. +copyDirectory :: FilePath -> FilePath -> IO () +copyDirectory dir newLocation = do _ <- rawSystem "cp" ["-rf", dir, newLocation] + return () + +cleanup :: [FilePath] -> IO a -> IO a +cleanup files operation = do + finally operation $ do + mapM_ rmIfExists files + + where rmIfExists :: FilePath -> IO () + rmIfExists file = catch (removeFile file) (fileFailedHandler file) + + fileFailedHandler :: FilePath -> IOException -> IO () + fileFailedHandler file e = catch (removeDirectory file) dirFailedHandler + + dirFailedHandler :: IOException -> IO () + dirFailedHandler e = return () diff --git a/tests/src/Integration.hs b/tests/src/Integration.hs new file mode 100644 --- /dev/null +++ b/tests/src/Integration.hs @@ -0,0 +1,119 @@ +module Integration where + +import Control.Exception.Base (finally, catch, IOException ) +import System.Directory ( removeFile, removeDirectory, getTemporaryDirectory + , copyFile ) +import System.FilePath ( () ) +import System.Process ( rawSystem ) +import System.Exit ( ExitCode(..) ) +import Data.UUID.V1 ( nextUUID ) +import Data.UUID + +import Prelude hiding (catch) + +import Test.HUnit ( (@=?), assertEqual, Assertion ) +-- import Test.QuickCheck ( Property ) +-- import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.Framework.Providers.HUnit +import Test.Framework ( testGroup, Test ) + +import Newt.Utilities + +tests :: [Test] +tests = [ 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 "Inplace modification tests" [ + testCase "Inplace replacement test 1" $ + test_inplaceReplace "The Author" "in.cabal.oracle.1" + , testCase "Inplace replacement test 2" $ + test_inplaceReplace "TheAuthor" "in.cabal.oracle.2" + ] + ] + +testDir :: FilePath +testDir = "tests" "testFiles" + +newtCmd :: FilePath +newtCmd = "./cabal-dev/bin/newt" + + +test_inplaceReplace :: String -> String -> Assertion +test_inplaceReplace author oracleFile = do tmpFile <- getTmpFileName + let input = (testDir "simpleTest" "in.cabal") + source= "--source=" ++ tmpFile + oracle = (testDir "simpleTest" oracleFile) + params = [ "--inplace" + , "name=myProject" + , "author="++author] + 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 + -- 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") + dest = "--dest="++tmpFile + oracle = (testDir "simpleTest" oracleFile) + params = [ "name=myProject" + , "author="++author] + cleanup [tmpFile] $ do + exitCode <- rawSystem newtCmd ([source, dest] ++ params) + assertEqual "invocation of newt failed" ExitSuccess exitCode + -- check file content: + assertFilesEqual "Generated file doesn't match" oracle tmpFile + +assertFilesEqual :: String -> FilePath -> FilePath -> Assertion +assertFilesEqual msg oracle suspect = do oracleTxt <- readFile oracle + suspectTxt <- readFile suspect + assertEqual msg oracleTxt suspectTxt + +-- | 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 +-- generates the name. +getTmpFileName :: IO FilePath +getTmpFileName = do tempdir <- catch (getTemporaryDirectory) errHandler + Just uuid <- nextUUID -- XXX will fail if you don't have a MAC + return (tempdir toString uuid) + 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 + +-- -- 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) diff --git a/tests/src/Main.hs b/tests/src/Main.hs new file mode 100644 --- /dev/null +++ b/tests/src/Main.hs @@ -0,0 +1,14 @@ +module Main where + + +import qualified Integration as Integration +import qualified ReplaceTests as ReplaceTests + +import Test.Framework ( defaultMain ) + + + +main :: IO () +main = do replaceTests <- ReplaceTests.tests + defaultMain $ concat [ replaceTests + , Integration.tests ] diff --git a/tests/src/ReplaceTests.hs b/tests/src/ReplaceTests.hs new file mode 100644 --- /dev/null +++ b/tests/src/ReplaceTests.hs @@ -0,0 +1,91 @@ +module ReplaceTests where + +import qualified Data.Set as Set + +import Test.HUnit ( (@=?) ) +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) + +tests :: IO [Test] +tests = do 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", "<<<>>", ">>", "<<>>") + , ("key uses prefix", "<<>>", "ok") + , ("Multi-tag 1", "<<>> <<>>", "v v") + , ("Multi-tag 2", "<<>> <<>>", "v value") + , ("value uses tag markers", "<<>>", "<<>>") + ] + , [ testGroup "Random surrounding string" + [ testProperty "default tag" $ + prop_populateKeyInRandStr defaultTag defaultPrefix defaultSuffix replacements + , testProperty "dash tag" $ + prop_populateKeyInRandStr dashTag "---" "---" replacements + ] + ] + ] + , testGroup "getTags" $ + concat [ map (testGetTags defaultTag) + [ ("Empty string", "", []) + , ("Empty tag", "<<<>>>", []) + , ("Empty tag", "<<>>", ["k"]) + , ("Nested tag", "<<<<<>>>>>", ["<<>>"]) + , ("Simple confusing context", "<<<>>", ["k"]) + , ("key uses prefix", "<<>>", ["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 "---" "---" + ] + ] + ] + + +-- | 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 = + let key = (fst . head) table + value = (snd . head) table + input = pfx ++ tPrefix ++ key ++ tSuffix ++ sfx + oracle = pfx ++ value ++ 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 + in getTags tag input == oracle + +replacements :: Table +replacements = [ ( "k", "v") + , ( "key", "value") + , ( "key<<>>") + ] + +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 + +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 diff --git a/tests/testFiles/dirTemplates/cabalProject/<<>>.cabal b/tests/testFiles/dirTemplates/cabalProject/<<>>.cabal new file mode 100644 --- /dev/null +++ b/tests/testFiles/dirTemplates/cabalProject/<<>>.cabal @@ -0,0 +1,43 @@ +name: <<>> +version: 0.0.0.1 +synopsis: <<>> +description: <<>> +category: Tools +license: BSD3 +License-file: LICENSE +author: <<>> +maintainer: <<>> +Cabal-Version: >=1.8.0.6 +build-type: Simple + +Flag tests + Description: Build the tests + Default: False + +Library + hs-source-dirs: src + + Build-depends: base >= 4 && < 6 + + ghc-options: -Wall + +Executable <<>> + Main-Is: Main.hs + hs-source-dirs: appsrc + + Build-depends: <<>>, + base >= 4 && < 6 + + ghc-options: -Wall + +Executable test-<<>> + Main-Is: Main.hs + hs-source-dirs: tests/src + + if !flag(tests) + Buildable: False + + Build-depends: <<>>, + base >= 4 && < 6 + + ghc-options: -Wall diff --git a/tests/testFiles/dirTemplates/cabalProject/LICENSE b/tests/testFiles/dirTemplates/cabalProject/LICENSE new file mode 100644 --- /dev/null +++ b/tests/testFiles/dirTemplates/cabalProject/LICENSE @@ -0,0 +1,29 @@ +Copyright (c) <<>>, <<>> +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +Redistributions of source code must retain the above copyright notice, +this list of conditions and the following disclaimer. + +Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in the +documentation and/or other materials provided with the distribution. + +Neither the name of <<>> nor the names of his or her +contributors may be used to endorse or promote products derived from +this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/tests/testFiles/dirTemplates/cabalProject/Setup.hs b/tests/testFiles/dirTemplates/cabalProject/Setup.hs new file mode 100644 --- /dev/null +++ b/tests/testFiles/dirTemplates/cabalProject/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/tests/testFiles/dirTemplates/cabalProject/appsrc/Main.hs b/tests/testFiles/dirTemplates/cabalProject/appsrc/Main.hs new file mode 100644 --- /dev/null +++ b/tests/testFiles/dirTemplates/cabalProject/appsrc/Main.hs @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = putStrLn "<<>> Sample application!" diff --git a/tests/testFiles/dirTemplates/cabalProject/src/<<>>.hs b/tests/testFiles/dirTemplates/cabalProject/src/<<>>.hs new file mode 100644 --- /dev/null +++ b/tests/testFiles/dirTemplates/cabalProject/src/<<>>.hs diff --git a/tests/testFiles/dirTemplates/cabalProject/tests/src/Main.hs b/tests/testFiles/dirTemplates/cabalProject/tests/src/Main.hs new file mode 100644 --- /dev/null +++ b/tests/testFiles/dirTemplates/cabalProject/tests/src/Main.hs @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = putStrLn "<<>> Test suite." diff --git a/tests/testFiles/dirTemplates/template2/<<>>/in.cabal b/tests/testFiles/dirTemplates/template2/<<>>/in.cabal new file mode 100644 --- /dev/null +++ b/tests/testFiles/dirTemplates/template2/<<>>/in.cabal @@ -0,0 +1,15 @@ +name: <<>> +version: 0.0.0.1 +synopsis: <<>> +description: <<>> +category: Tools +license: BSD3 +License-file: LICENSE +author: <<>> +maintainer: <<>> +Cabal-Version: >=1.8.0.6 +build-type: Simple + +Executable <<>> + Main-Is: Main.hs + hs-source-dirs: src diff --git a/tests/testFiles/simpleTest/alternate1.txt b/tests/testFiles/simpleTest/alternate1.txt new file mode 100644 --- /dev/null +++ b/tests/testFiles/simpleTest/alternate1.txt @@ -0,0 +1,5 @@ +Testing zzz_letter_z_zzz brackets. +Another ***starts*** of brackets. +Another [[[squareBrackets]]] of brackets. +Another <<>> of brackets. +Another ---dashes--- of brackets. diff --git a/tests/testFiles/simpleTest/in.cabal b/tests/testFiles/simpleTest/in.cabal new file mode 100644 --- /dev/null +++ b/tests/testFiles/simpleTest/in.cabal @@ -0,0 +1,15 @@ +name: <<>> +version: 0.0.0.1 +synopsis: <<>> +description: <<>> +category: Tools +license: BSD3 +License-file: LICENSE +author: <<>> +maintainer: <<>> +Cabal-Version: >=1.8.0.6 +build-type: Simple + +Executable <<>> + Main-Is: Main.hs + hs-source-dirs: src diff --git a/tests/testFiles/simpleTest/in.cabal.oracle.1 b/tests/testFiles/simpleTest/in.cabal.oracle.1 new file mode 100644 --- /dev/null +++ b/tests/testFiles/simpleTest/in.cabal.oracle.1 @@ -0,0 +1,15 @@ +name: myProject +version: 0.0.0.1 +synopsis: <<>> +description: <<>> +category: Tools +license: BSD3 +License-file: LICENSE +author: The Author +maintainer: <<>> +Cabal-Version: >=1.8.0.6 +build-type: Simple + +Executable myProject + Main-Is: Main.hs + hs-source-dirs: src diff --git a/tests/testFiles/simpleTest/in.cabal.oracle.2 b/tests/testFiles/simpleTest/in.cabal.oracle.2 new file mode 100644 --- /dev/null +++ b/tests/testFiles/simpleTest/in.cabal.oracle.2 @@ -0,0 +1,15 @@ +name: myProject +version: 0.0.0.1 +synopsis: <<>> +description: <<>> +category: Tools +license: BSD3 +License-file: LICENSE +author: TheAuthor +maintainer: <<>> +Cabal-Version: >=1.8.0.6 +build-type: Simple + +Executable myProject + Main-Is: Main.hs + hs-source-dirs: src diff --git a/tests/testFiles/simpleTest/simple1.txt b/tests/testFiles/simpleTest/simple1.txt new file mode 100644 --- /dev/null +++ b/tests/testFiles/simpleTest/simple1.txt @@ -0,0 +1,1 @@ +Variable: <<>>