diff --git a/src/Import.hs b/src/Import.hs --- a/src/Import.hs +++ b/src/Import.hs @@ -2,7 +2,7 @@ ( module X ) where -import Prelude as X hiding (readFile, appendFile, writeFile, putStr, putStrLn) +import Prelude as X hiding (appendFile) import Control.Arrow as X import Data.Maybe as X @@ -10,7 +10,6 @@ import System.Exit as X import Text.Read as X (readEither) -import Data.IOString as X import Path as X import Path.IO as X diff --git a/src/SuperUserSpark/Bake.hs b/src/SuperUserSpark/Bake.hs --- a/src/SuperUserSpark/Bake.hs +++ b/src/SuperUserSpark/Bake.hs @@ -17,6 +17,7 @@ import Import import qualified Data.Aeson.Encode.Pretty as JSON +import qualified Data.ByteString.Lazy.Char8 as LB import System.Environment (getEnvironment) import System.FilePath (takeExtension) @@ -57,9 +58,7 @@ parseStrongCardFileReference f) _ -> pure $ Left $ unwords ["Could not parse card reference from:", s] -deriveBakeSettings :: BakeCardReference - -> BakeFlags - -> IO (Either String BakeSettings) +deriveBakeSettings :: BakeCardReference -> BakeFlags -> IO (Either String BakeSettings) deriveBakeSettings bcr BakeFlags {..} = BakeSettings (rootOf bcr) <$$> (Right <$> getEnvironment) <**> deriveCompileSettings bakeCompileFlags @@ -87,7 +86,7 @@ bakeByCardRef bakeCardReference = do deps <- compileBakeCardRef bakeCardReference bdeps <- bakeDeployments deps - putStrLn $ JSON.encodePretty bdeps + liftIO . LB.putStrLn $ JSON.encodePretty bdeps compileBakeCardRef :: BakeCardReference -> SparkBaker [RawDeployment] compileBakeCardRef (BakeCardCompiled fp) = bakerCompile $ inputCompiled fp diff --git a/src/SuperUserSpark/Bake/Internal.hs b/src/SuperUserSpark/Bake/Internal.hs --- a/src/SuperUserSpark/Bake/Internal.hs +++ b/src/SuperUserSpark/Bake/Internal.hs @@ -5,8 +5,7 @@ import Import import Control.Exception (try) -import System.FilePath - (isAbsolute, replaceDirectory, takeDirectory) +import System.FilePath (isAbsolute, replaceDirectory, takeDirectory) import SuperUserSpark.Bake.Types import SuperUserSpark.Compiler.Types @@ -17,11 +16,10 @@ bakeDeployment :: RawDeployment -> SparkBaker BakedDeployment bakeDeployment Deployment {..} = do d <- bakeDirections deploymentDirections - pure $ - Deployment {deploymentDirections = d, deploymentKind = deploymentKind} + pure Deployment {deploymentDirections = d, deploymentKind = deploymentKind} -bakeDirections :: DeploymentDirections FilePath - -> SparkBaker (DeploymentDirections AbsP) +bakeDirections :: + DeploymentDirections FilePath -> SparkBaker (DeploymentDirections AbsP) bakeDirections (Directions srcs dst) = Directions <$> mapM bakeFilePath srcs <*> bakeFilePath dst @@ -37,9 +35,8 @@ env <- asks bakeEnvironment root <- asks bakeRoot case complete env fp of - Left err -> throwError $ BakeError $ err - Right cp -> do - if isAbsolute cp + Left err -> throwError $ BakeError err + Right cp -> if isAbsolute cp then case parseAbsFile cp of Left err -> throwError $ BakeError $ show err Right af -> pure $ AbsP af @@ -72,17 +69,17 @@ where go :: FilePath -> [ID] go [] = [] - go ('$':'(':rest) = (Var id_) : (go next) + go ('$':'(':rest) = Var id_ : go next where - (id_, (')':next)) = break (\c -> c == ')') rest + (id_, ')':next) = break (== ')') rest go (s:ss) = case go ss of - (Plain str):r -> (Plain (s : str)) : r - r -> (Plain [s]) : r + Plain str:r -> Plain (s : str) : r + r -> Plain [s] : r replaceId :: Environment -> ID -> Either String FilePath replaceId _ (Plain str) = return str -replaceId e (Var str) = do +replaceId e (Var str) = case lookup str e of Nothing -> Left $ diff --git a/src/SuperUserSpark/Check.hs b/src/SuperUserSpark/Check.hs --- a/src/SuperUserSpark/Check.hs +++ b/src/SuperUserSpark/Check.hs @@ -10,7 +10,7 @@ , checkDeployments ) where -import Import +import Import hiding (check) import SuperUserSpark.Bake import SuperUserSpark.Bake.Internal diff --git a/src/SuperUserSpark/Check/Internal.hs b/src/SuperUserSpark/Check/Internal.hs --- a/src/SuperUserSpark/Check/Internal.hs +++ b/src/SuperUserSpark/Check/Internal.hs @@ -7,7 +7,6 @@ import SuperUserSpark.Bake.Types import SuperUserSpark.Check.Types import SuperUserSpark.Compiler.Types -import SuperUserSpark.Constants import SuperUserSpark.CoreTypes import SuperUserSpark.Diagnose.Types @@ -39,7 +38,7 @@ impossibleDeployment _ = False dirtyDeployment :: DeploymentCheckResult -> Bool -dirtyDeployment (DirtySituation _ _ _) = True +dirtyDeployment DirtySituation{} = True dirtyDeployment _ = False deploymentReadyToDeploy :: DeploymentCheckResult -> Bool @@ -227,11 +226,11 @@ then "Deployment is impossible." else "Deployment is possible." where - output = catMaybes $ map formatDeploymentCheck dss + output = mapMaybe formatDeploymentCheck dss formatDeploymentCheck :: (DiagnosedDeployment, DeploymentCheckResult) -> Maybe String -formatDeploymentCheck (_, (ReadyToDeploy is)) = +formatDeploymentCheck (_, ReadyToDeploy is) = Just $ "READY: " ++ formatInstruction is formatDeploymentCheck (_, DeploymentDone) = Nothing formatDeploymentCheck (d, ImpossibleDeployment ds) = @@ -244,7 +243,7 @@ , unlines ds , "\n" ] -formatDeploymentCheck (d, (DirtySituation str is c)) = +formatDeploymentCheck (d, DirtySituation str is c) = Just $ concat [ "DIRTY: " @@ -262,13 +261,13 @@ formatInstruction :: Instruction -> String formatInstruction (CopyFile from to) = - unwords $ [toFilePath from, "c->", toFilePath to] + unwords [toFilePath from, "c->", toFilePath to] formatInstruction (CopyDir from to) = - unwords $ [toFilePath from, "c->", toFilePath to] + unwords [toFilePath from, "c->", toFilePath to] formatInstruction (LinkFile from to) = - unwords $ [toFilePath from, "l->", toFilePath to] + unwords [toFilePath from, "l->", toFilePath to] formatInstruction (LinkDir from to) = - unwords $ [toFilePath from, "l->", toFilePath to] + unwords [toFilePath from, "l->", toFilePath to] formatCleanupInstruction :: CleanupInstruction -> String formatCleanupInstruction (CleanFile fp) = "remove file " ++ toFilePath fp diff --git a/src/SuperUserSpark/Check/Types.hs b/src/SuperUserSpark/Check/Types.hs --- a/src/SuperUserSpark/Check/Types.hs +++ b/src/SuperUserSpark/Check/Types.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE RecordWildCards #-} module SuperUserSpark.Check.Types where @@ -15,7 +14,7 @@ instance Validity CheckAssignment -data CheckSettings = CheckSettings +newtype CheckSettings = CheckSettings { checkDiagnoseSettings :: DiagnoseSettings } deriving (Show, Eq, Generic) diff --git a/src/SuperUserSpark/Compiler.hs b/src/SuperUserSpark/Compiler.hs --- a/src/SuperUserSpark/Compiler.hs +++ b/src/SuperUserSpark/Compiler.hs @@ -20,6 +20,7 @@ import Control.Exception (try) import Data.Aeson (eitherDecode) import Data.Aeson.Encode.Pretty (encodePretty) +import qualified Data.ByteString.Lazy.Char8 as LB import Data.List (find) import SuperUserSpark.Compiler.Internal @@ -187,12 +188,12 @@ liftIO $ do let bs = encodePretty deps case out of - Nothing -> putStrLn bs - Just fp -> writeFile fp bs + Nothing -> LB.putStrLn bs + Just fp -> LB.writeFile (toFilePath fp) bs inputCompiled :: Path Abs File -> ImpureCompiler [RawDeployment] inputCompiled fp = do - bs <- readFile fp + bs <- liftIO . LB.readFile $ toFilePath fp case eitherDecode bs of Left err -> throwError $ diff --git a/src/SuperUserSpark/Compiler/Internal.hs b/src/SuperUserSpark/Compiler/Internal.hs --- a/src/SuperUserSpark/Compiler/Internal.hs +++ b/src/SuperUserSpark/Compiler/Internal.hs @@ -20,11 +20,9 @@ defaultKind <- asks compileDefaultKind localOverride <- gets stateDeploymentKindLocalOverride superOverride <- asks compileKindOverride - let resultKind = - case msum [superOverride, localOverride, kind] of - Nothing -> defaultKind - Just k -> k - outof <- gets stateOutof_prefix + let resultKind = fromMaybe defaultKind + $ msum [superOverride, localOverride, kind] + outof <- gets stateOutofPrefix into <- gets stateInto let directions = Directions @@ -39,14 +37,14 @@ then modify (\s -> s {stateInto = dir}) else modify (\s -> s {stateInto = ip dir}) compileDec (OutofDir dir) = do - op <- gets stateOutof_prefix - modify (\s -> s {stateOutof_prefix = op ++ [Literal dir]}) -compileDec (DeployKindOverride kind) = do + op <- gets stateOutofPrefix + modify (\s -> s {stateOutofPrefix = op ++ [Literal dir]}) +compileDec (DeployKindOverride kind) = modify (\s -> s {stateDeploymentKindLocalOverride = Just kind}) compileDec (Block ds) = do before <- get compileDecs ds put before compileDec (Alternatives ds) = do - op <- gets stateOutof_prefix - modify (\s -> s {stateOutof_prefix = op ++ [Alts ds]}) + op <- gets stateOutofPrefix + modify (\s -> s {stateOutofPrefix = op ++ [Alts ds]}) diff --git a/src/SuperUserSpark/Compiler/Types.hs b/src/SuperUserSpark/Compiler/Types.hs --- a/src/SuperUserSpark/Compiler/Types.hs +++ b/src/SuperUserSpark/Compiler/Types.hs @@ -108,7 +108,7 @@ data CompilerState = CompilerState { stateDeploymentKindLocalOverride :: Maybe DeploymentKind , stateInto :: Directory - , stateOutof_prefix :: CompilerPrefix + , stateOutofPrefix :: CompilerPrefix } deriving (Show, Eq, Generic) instance Validity CompilerState diff --git a/src/SuperUserSpark/Compiler/Utils.hs b/src/SuperUserSpark/Compiler/Utils.hs --- a/src/SuperUserSpark/Compiler/Utils.hs +++ b/src/SuperUserSpark/Compiler/Utils.hs @@ -11,7 +11,7 @@ CompilerState { stateDeploymentKindLocalOverride = Nothing , stateInto = "" - , stateOutof_prefix = [] + , stateOutofPrefix = [] } addDeployment :: RawDeployment -> InternalCompiler () @@ -28,10 +28,10 @@ resolvePrefix [] = [] resolvePrefix [Literal s] = [s] resolvePrefix [Alts ds] = ds -resolvePrefix ((Literal s):ps) = do +resolvePrefix (Literal s:ps) = do rest <- resolvePrefix ps return $ s rest -resolvePrefix ((Alts as):ps) = do +resolvePrefix (Alts as:ps) = do a <- as rest <- resolvePrefix ps return $ a rest diff --git a/src/SuperUserSpark/Deployer/Internal.hs b/src/SuperUserSpark/Deployer/Internal.hs --- a/src/SuperUserSpark/Deployer/Internal.hs +++ b/src/SuperUserSpark/Deployer/Internal.hs @@ -1,15 +1,11 @@ module SuperUserSpark.Deployer.Internal where -import Import hiding (()) +import Import -import Data.Text (pack) -import System.FilePath.Posix - (dropFileName, dropTrailingPathSeparator) +import System.FilePath.Posix (dropTrailingPathSeparator) import System.Posix.Files (createSymbolicLink, removeLink) -import SuperUserSpark.Bake.Types import SuperUserSpark.Check.Types -import SuperUserSpark.CoreTypes import SuperUserSpark.Deployer.Types import SuperUserSpark.Utils diff --git a/src/SuperUserSpark/Diagnose.hs b/src/SuperUserSpark/Diagnose.hs --- a/src/SuperUserSpark/Diagnose.hs +++ b/src/SuperUserSpark/Diagnose.hs @@ -18,6 +18,7 @@ import Import import qualified Data.Aeson.Encode.Pretty as JSON +import qualified Data.ByteString.Lazy.Char8 as LB import SuperUserSpark.Bake import SuperUserSpark.Bake.Internal @@ -69,7 +70,7 @@ diagnoserBake $ compileBakeCardRef checkCardReference >>= bakeDeployments ddeps <- liftIO $ diagnoseDeployments deps - putStrLn $ JSON.encodePretty ddeps + liftIO . LB.putStrLn $ JSON.encodePretty ddeps diagnoserBake :: SparkBaker a -> SparkDiagnoser a diagnoserBake = diff --git a/src/SuperUserSpark/Diagnose/Internal.hs b/src/SuperUserSpark/Diagnose/Internal.hs --- a/src/SuperUserSpark/Diagnose/Internal.hs +++ b/src/SuperUserSpark/Diagnose/Internal.hs @@ -35,23 +35,19 @@ ms <- forgivingAbsence $ getSymbolicLinkStatus fp case ms of Nothing -> pure Nonexistent - Just s -> - if isBlockDevice s || - isCharacterDevice s || isSocket s || isNamedPipe s - then return IsWeird - else do - if isSymbolicLink s - then do - point <- readSymbolicLink fp - -- TODO check what happens with relative links. - apoint <- AbsP <$> parseAbsFile point - return $ IsLinkTo apoint - else pure $ - if isDirectory s - then IsDirectory - else if isRegularFile s - then IsFile - else IsWeird + Just s | isBlockDevice s || isCharacterDevice s || isSocket s || isNamedPipe s + -> return IsWeird + | isSymbolicLink s -> do + point <- readSymbolicLink fp + -- TODO check what happens with relative links. + apoint <- AbsP <$> parseAbsFile point + return $ IsLinkTo apoint + | otherwise -> pure $ + if isDirectory s + then IsDirectory + else if isRegularFile s + then IsFile + else IsWeird -- | Hash a filepath so that two filepaths with the same contents have the same hash hashFilePath :: AbsP -> IO HashDigest @@ -65,7 +61,7 @@ Nonexistent -> return $ HashDigest $ hash () hashFile :: AbsP -> IO HashDigest -hashFile fp = (HashDigest . hash) <$> SB.readFile (toPath fp) +hashFile fp = HashDigest . hash <$> SB.readFile (toPath fp) hashDirectory :: AbsP -> IO HashDigest hashDirectory fp = do diff --git a/src/SuperUserSpark/Diagnose/Types.hs b/src/SuperUserSpark/Diagnose/Types.hs --- a/src/SuperUserSpark/Diagnose/Types.hs +++ b/src/SuperUserSpark/Diagnose/Types.hs @@ -1,10 +1,11 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module SuperUserSpark.Diagnose.Types where -import Import +import Import hiding ((<>)) import Data.Aeson import Data.Hashable @@ -13,6 +14,10 @@ import SuperUserSpark.Bake.Types import SuperUserSpark.Compiler.Types +#if __GLASGOW_HASKELL__ < 840 +import Data.Semigroup (Semigroup, (<>)) +#endif + data DiagnoseAssignment = DiagnoseAssignment { diagnoseCardReference :: BakeCardReference , diagnoseSettings :: DiagnoseSettings @@ -20,7 +25,7 @@ instance Validity DiagnoseAssignment -data DiagnoseSettings = DiagnoseSettings +newtype DiagnoseSettings = DiagnoseSettings { diagnoseBakeSettings :: BakeSettings } deriving (Show, Eq, Generic) @@ -45,14 +50,17 @@ instance Validity HashDigest +instance Semigroup HashDigest where + HashDigest h1 <> HashDigest h2 = HashDigest $ h1 * 31 + h2 + instance Monoid HashDigest where mempty = HashDigest (hash ()) - (HashDigest h1) `mappend` (HashDigest h2) = HashDigest $ h1 * 31 + h2 + mappend = (<>) instance Hashable HashDigest instance ToJSON HashDigest where - toJSON (HashDigest i) = toJSON $ (printf "%016x" i :: String) + toJSON (HashDigest i) = toJSON (printf "%016x" i :: String) data Diagnostics = Nonexistent diff --git a/src/SuperUserSpark/OptParse/Types.hs b/src/SuperUserSpark/OptParse/Types.hs --- a/src/SuperUserSpark/OptParse/Types.hs +++ b/src/SuperUserSpark/OptParse/Types.hs @@ -15,7 +15,7 @@ instance Validity Dispatch -data ParseArgs = ParseArgs +newtype ParseArgs = ParseArgs { parseFilePath :: FilePath } deriving (Show, Eq, Generic) @@ -43,7 +43,7 @@ instance Validity BakeArgs -data BakeFlags = BakeFlags +newtype BakeFlags = BakeFlags { bakeCompileFlags :: CompileFlags } deriving (Show, Eq, Generic) @@ -56,7 +56,7 @@ instance Validity DiagnoseArgs -data DiagnoseFlags = DiagnoseFlags +newtype DiagnoseFlags = DiagnoseFlags { diagnoseBakeFlags :: BakeFlags } deriving (Show, Eq, Generic) @@ -69,7 +69,7 @@ instance Validity CheckArgs -data CheckFlags = CheckFlags +newtype CheckFlags = CheckFlags { checkDiagnoseFlags ::DiagnoseFlags } deriving (Show, Eq, Generic) diff --git a/src/SuperUserSpark/Parser.hs b/src/SuperUserSpark/Parser.hs --- a/src/SuperUserSpark/Parser.hs +++ b/src/SuperUserSpark/Parser.hs @@ -39,4 +39,4 @@ formatParseError (ParseError pe) = show pe parseFile :: Path Abs File -> IO (Either ParseError SparkFile) -parseFile file = (left ParseError . parseCardFile file) <$> readFile file +parseFile file = (left ParseError . parseCardFile file) <$> readFile (toFilePath file) diff --git a/src/SuperUserSpark/Parser/Internal.hs b/src/SuperUserSpark/Parser/Internal.hs --- a/src/SuperUserSpark/Parser/Internal.hs +++ b/src/SuperUserSpark/Parser/Internal.hs @@ -10,9 +10,7 @@ import Text.Parsec.String parseCardFile :: Path Abs File -> String -> Either ParseError SparkFile -parseCardFile f s = do - cs <- parseFromSource sparkFile f s - return $ SparkFile f cs +parseCardFile f s = SparkFile f <$> parseFromSource sparkFile f s parseFromSource :: Parser a -> Path Abs File -> String -> Either ParseError a parseFromSource parser file = parse parser $ toFilePath file @@ -36,7 +34,7 @@ card :: Parser Card card = do whitespace - skip $ string keywordCard + void $ string keywordCard whitespace name <- cardNameP whitespace @@ -45,7 +43,7 @@ return $ Card name b declarations :: Parser [Declaration] -declarations = (inLineSpace declaration) `sepEndBy` delim +declarations = inLineSpace declaration `sepEndBy` delim declaration :: Parser Declaration declaration = @@ -69,7 +67,7 @@ sparkOff :: Parser Declaration sparkOff = - do skip $ string keywordSpark + do void $ string keywordSpark linespace ref <- cardReference return $ SparkOff ref @@ -80,19 +78,19 @@ compiledCardReference :: Parser FilePath compiledCardReference = do - skip $ string "compiled" - skip linespace + void $ string "compiled" + void linespace filepath cardReference :: Parser CardReference cardReference = try goName <|> try goFile "card reference" where - goName = cardNameReference >>= return . CardName - goFile = cardFileReference >>= return . CardFile + goName = CardName <$> cardNameReference + goFile = CardFile <$> cardFileReference cardNameReference :: Parser CardNameReference cardNameReference = - do skip $ string keywordCard + do void $ string keywordCard linespace name <- cardNameP return $ CardNameReference name @@ -103,8 +101,8 @@ cardFileReference :: Parser CardFileReference cardFileReference = do - skip $ string keywordFile - skip linespace + void $ string keywordFile + void linespace unprefixedCardFileReference unprefixedCardFileReference :: Parser CardFileReference @@ -120,7 +118,7 @@ intoDir :: Parser Declaration intoDir = - do skip $ string keywordInto + do void $ string keywordInto linespace dir <- directory return $ IntoDir dir @@ -128,7 +126,7 @@ outOfDir :: Parser Declaration outOfDir = - do skip $ string keywordOutof + do void $ string keywordOutof linespace dir <- directory return $ OutofDir dir @@ -136,7 +134,7 @@ deploymentKindOverride :: Parser Declaration deploymentKindOverride = - do skip $ string keywordKindOverride + do void $ string keywordKindOverride linespace kind <- try copy <|> link return $ DeployKindOverride kind @@ -171,7 +169,7 @@ alternatives :: Parser Declaration alternatives = do - skip $ string keywordAlternatives + void $ string keywordAlternatives linespace ds <- directory `sepBy1` linespace return $ Alternatives ds @@ -194,19 +192,19 @@ lineComment :: Parser String lineComment = ( "Line comment") $ do - skip $ try $ string lineCommentStr + void $ try $ string lineCommentStr anyChar `manyTill` eol blockComment :: Parser String blockComment = ( "Block comment") $ do - skip $ try $ string start - anyChar `manyTill` (try $ string stop) + void $ try $ string start + anyChar `manyTill` try (string stop) where (start, stop) = blockCommentStrs notComment :: Parser String -notComment = manyTill anyChar (lookAhead ((skip comment) <|> eof)) +notComment = manyTill anyChar (lookAhead (void comment <|> eof)) eatComments :: Parser String eatComments = do @@ -236,7 +234,7 @@ inQuotes = between (char quotesChar) (char quotesChar) delim :: Parser () -delim = try (skip $ string lineDelimiter) <|> go +delim = try (void $ string lineDelimiter) <|> go where go = do eol @@ -250,18 +248,14 @@ inWhiteSpace = between whitespace whitespace linespace :: Parser () -linespace = skip $ many $ oneOf linespaceChars +linespace = void $ many $ oneOf linespaceChars whitespace :: Parser () -whitespace = skip $ many $ oneOf whitespaceChars +whitespace = void $ many $ oneOf whitespaceChars eol :: Parser () -eol = skip newline_ +eol = void newline_ where newline_ = try (string "\r\n") <|> try (string "\n") <|> string "\r" "end of line" - ---[ Utils ]-- -skip :: Parser a -> Parser () -skip p = p >> return () diff --git a/src/SuperUserSpark/Parser/Types.hs b/src/SuperUserSpark/Parser/Types.hs --- a/src/SuperUserSpark/Parser/Types.hs +++ b/src/SuperUserSpark/Parser/Types.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveGeneric #-} module SuperUserSpark.Parser.Types where @@ -7,7 +6,7 @@ import qualified Text.Parsec as Parsec -data ParseAssignment = ParseAssignment +newtype ParseAssignment = ParseAssignment { fileToParse :: Path Abs File } deriving (Show, Eq, Generic) @@ -24,4 +23,4 @@ deriving (Show, Eq, Generic) instance Validity ParseError where - isValid (ParseError _) = True + validate = trivialValidation diff --git a/src/SuperUserSpark/Utils.hs b/src/SuperUserSpark/Utils.hs --- a/src/SuperUserSpark/Utils.hs +++ b/src/SuperUserSpark/Utils.hs @@ -6,7 +6,6 @@ import Import import Data.List (isInfixOf) -import qualified System.Directory as D (createDirectoryIfMissing) incase :: MonadReader c m diff --git a/super-user-spark.cabal b/super-user-spark.cabal --- a/super-user-spark.cabal +++ b/super-user-spark.cabal @@ -1,5 +1,5 @@ name: super-user-spark -version: 0.4.0.0 +version: 0.4.0.1 license: MIT license-file: LICENSE description: Configure your dotfile deployment with a DSL. @@ -54,23 +54,22 @@ build-depends: base >= 4.9 && < 5 - , aeson >= 0.11 && < 1.2 - , aeson-pretty >= 0.8 && < 0.9 - , bytestring >= 0.10 && < 0.11 - , directory >= 1.3 && < 1.4 - , filepath >= 1.4 && < 1.5 - , mtl >= 2.2 && < 2.3 - , optparse-applicative >= 0.13 && < 0.14 - , parsec >= 3.1.9 && < 3.2 - , process >= 1.4 && < 1.6 - , hashable >= 1.2 && < 1.3 - , text >= 1.2 && < 1.3 - , unix >= 2.7 && < 2.8 - , validity >= 0.3.2 && < 0.4 - , validity-path >= 0.1 && < 0.2 - , path >= 0.5 && < 0.6 - , path-io >= 1.2 && < 1.3 - , iostring >= 0.0 && < 0.1 + , aeson + , aeson-pretty + , bytestring + , directory + , filepath + , mtl + , optparse-applicative + , parsec + , process + , hashable + , text + , unix + , validity >= 0.6.0.0 + , validity-path + , path + , path-io default-language: Haskell2010 default-extensions: NoImplicitPrelude @@ -122,8 +121,7 @@ , super-user-spark , hspec >= 2.2 && < 2.5 , hspec-core >= 2.2 && < 2.5 - , HUnit >= 1.2 && < 1.6 - , QuickCheck >= 2.8 && < 2.10 + , QuickCheck , aeson , aeson-pretty , bytestring @@ -136,15 +134,14 @@ , text , transformers , unix - , genvalidity >= 0.3.1 && < 0.4 - , genvalidity-path >= 0.1 && < 0.2 - , genvalidity-hspec >= 0.3.1 && < 0.4 - , genvalidity-hspec-aeson >= 0.0 && < 0.1 + , genvalidity + , genvalidity-path + , genvalidity-hspec + , genvalidity-hspec-aeson , validity , validity-path , path , path-io - , iostring , hashable default-language: Haskell2010 default-extensions: NoImplicitPrelude diff --git a/test/SuperUserSpark/BakeSpec.hs b/test/SuperUserSpark/BakeSpec.hs --- a/test/SuperUserSpark/BakeSpec.hs +++ b/test/SuperUserSpark/BakeSpec.hs @@ -84,7 +84,7 @@ let to = $(mkRelDir "to") file withCurrentDir sandbox $ do ensureDir $ parent $ sandbox from - writeFile (sandbox from) "contents" + writeFile (toFilePath $ sandbox from) "contents" ensureDir $ parent $ sandbox to createSymbolicLink (toFilePath $ sandbox from) @@ -93,7 +93,9 @@ runReaderT (runExceptT f) (defaultBakeSettings - {bakeRoot = sandbox, bakeEnvironment = []}) + { bakeRoot = sandbox + , bakeEnvironment = [] + }) runBake (bakeFilePath (toFilePath to)) `shouldReturn` (Right $ AbsP $ sandbox to) runBake (bakeFilePath (toFilePath from)) `shouldReturn` @@ -107,19 +109,25 @@ let to = todir file withCurrentDir sandbox $ do ensureDir $ parent $ sandbox from - writeFile (sandbox from) "from contents" + writeFile + (toFilePath $ sandbox from) + "from contents" ensureDir $ parent $ sandbox todir createSymbolicLink (FP.dropTrailingPathSeparator $ toFilePath $ sandbox fromdir) (FP.dropTrailingPathSeparator $ toFilePath $ sandbox todir) - writeFile (sandbox to) "to contents" + writeFile + (toFilePath $ sandbox to) + "to contents" let runBake f = runReaderT (runExceptT f) (defaultBakeSettings - {bakeRoot = sandbox, bakeEnvironment = []}) + { bakeRoot = sandbox + , bakeEnvironment = [] + }) runBake (bakeFilePath (toFilePath to)) `shouldReturn` (Right $ AbsP $ sandbox from) runBake (bakeFilePath (toFilePath from)) `shouldReturn` diff --git a/test/SuperUserSpark/Check/TestUtils.hs b/test/SuperUserSpark/Check/TestUtils.hs --- a/test/SuperUserSpark/Check/TestUtils.hs +++ b/test/SuperUserSpark/Check/TestUtils.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE TemplateHaskell #-} - module SuperUserSpark.Check.TestUtils where import TestImport @@ -22,7 +20,7 @@ -- * Test utils for checkSingle isDirty :: CheckResult -> Bool -isDirty (Dirty _ _ _) = True +isDirty Dirty{} = True isDirty _ = False isReady :: CheckResult -> Bool @@ -48,23 +46,15 @@ Dirty _ ins ci -> do ci `shouldBe` eci let tp = dropTrailingPathSeparator . toFilePath - case ins of - CopyFile isrc idst -> do - tp isrc `shouldBe` toPath (diagnosedFilePath src) - tp idst `shouldBe` toPath (diagnosedFilePath dst) - CopyDeployment `shouldBe` kind - CopyDir isrc idst -> do - tp isrc `shouldBe` toPath (diagnosedFilePath src) - tp idst `shouldBe` toPath (diagnosedFilePath dst) - CopyDeployment `shouldBe` kind - LinkFile isrc idst -> do - tp isrc `shouldBe` toPath (diagnosedFilePath src) - tp idst `shouldBe` toPath (diagnosedFilePath dst) - LinkDeployment `shouldBe` kind - LinkDir isrc idst -> do + let checkCopyDeployment isrc idst expectation = do tp isrc `shouldBe` toPath (diagnosedFilePath src) tp idst `shouldBe` toPath (diagnosedFilePath dst) - LinkDeployment `shouldBe` kind + expectation `shouldBe` kind + case ins of + CopyFile isrc idst -> checkCopyDeployment isrc idst CopyDeployment + CopyDir isrc idst -> checkCopyDeployment isrc idst CopyDeployment + LinkFile isrc idst -> checkCopyDeployment isrc idst LinkDeployment + LinkDir isrc idst -> checkCopyDeployment isrc idst LinkDeployment t -> expectationFailure $ unlines diff --git a/test/SuperUserSpark/Compiler/Gen.hs b/test/SuperUserSpark/Compiler/Gen.hs --- a/test/SuperUserSpark/Compiler/Gen.hs +++ b/test/SuperUserSpark/Compiler/Gen.hs @@ -13,18 +13,15 @@ instance GenValid CompileAssignment where genValid = CompileAssignment <$> genValid <*> genValid <*> genValid - instance GenUnchecked StrongCardFileReference instance GenValid StrongCardFileReference - instance GenUnchecked CompileSettings instance GenValid CompileSettings where genValid = CompileSettings <$> genValid <*> genValid - instance GenUnchecked a => GenUnchecked (Deployment a) where genUnchecked = Deployment <$> genUnchecked <*> genUnchecked @@ -44,7 +41,6 @@ instance GenValid PrefixPart - instance GenUnchecked CompilerState instance GenValid CompilerState @@ -55,6 +51,6 @@ [ PreCompileErrors <$> genUnchecked , DuringCompilationError <$> genUnchecked ] + shrinkUnchecked _ = [] instance GenValid CompileError - diff --git a/test/SuperUserSpark/Compiler/TestUtils.hs b/test/SuperUserSpark/Compiler/TestUtils.hs --- a/test/SuperUserSpark/Compiler/TestUtils.hs +++ b/test/SuperUserSpark/Compiler/TestUtils.hs @@ -92,4 +92,4 @@ -- Filepath utils containsNewlineCharacter :: String -> Bool -containsNewlineCharacter f = any (\c -> elem c f) ['\n', '\r'] +containsNewlineCharacter f = any (`elem` f) ['\n', '\r'] diff --git a/test/SuperUserSpark/CompilerSpec.hs b/test/SuperUserSpark/CompilerSpec.hs --- a/test/SuperUserSpark/CompilerSpec.hs +++ b/test/SuperUserSpark/CompilerSpec.hs @@ -3,7 +3,7 @@ module SuperUserSpark.CompilerSpec where -import TestImport +import TestImport hiding ((<.>)) import Data.Either (isLeft, isRight) import Data.List (isPrefixOf) @@ -192,7 +192,7 @@ CompilerState { stateDeploymentKindLocalOverride = Nothing , stateInto = "" - , stateOutof_prefix = [] + , stateOutofPrefix = [] } instanceSpec :: Spec @@ -270,7 +270,7 @@ it "adds the given directory to the outof state" $ do forAll validFp $ \fp -> shouldState (OutofDir fp) $ - s {stateOutof_prefix = [Literal fp]} + s {stateOutofPrefix = [Literal fp]} pend describe "DeployKindOverride" $ do it "modifies the internal deployment kind override" $ do @@ -287,7 +287,7 @@ "adds an alternatives prefix to the outof prefix in the compiler state" $ do forAll (listOf validFilePath) $ \fps -> shouldState (Alternatives fps) $ - s {stateOutof_prefix = [Alts fps]} + s {stateOutofPrefix = [Alts fps]} pend runDefaultImpureCompiler :: ImpureCompiler a -> IO (Either CompileError a) diff --git a/test/SuperUserSpark/DeployerSpec.hs b/test/SuperUserSpark/DeployerSpec.hs --- a/test/SuperUserSpark/DeployerSpec.hs +++ b/test/SuperUserSpark/DeployerSpec.hs @@ -67,7 +67,7 @@ withCurrentDir sandbox $ do let file = sandbox $(mkRelFile "test.txt") let fp = AbsP file - writeFile file "This is a test" + writeFile (toFilePath file) "This is a test" diagnoseFp fp `shouldReturn` IsFile clean c $ CleanFile file diagnoseFp fp `shouldReturn` IsFile @@ -80,7 +80,7 @@ withCurrentDir sandbox $ do let file = sandbox $(mkRelFile "test.txt") let fp = AbsP file - writeFile file "This is a test" + writeFile (toFilePath file) "This is a test" diagnoseFp fp `shouldReturn` IsFile clean c $ CleanFile file diagnoseFp fp `shouldReturn` Nonexistent @@ -119,7 +119,7 @@ let link_' = AbsP link_ let file_ = sandbox $(mkRelFile "testfile") let file_' = AbsP file_ - writeFile file_ "This is a test" + writeFile (toFilePath file_) "This is a test" createSymbolicLink (toFilePath file_) (toFilePath link_) diagnoseFp link_' `shouldReturn` IsLinkTo file_' clean c $ CleanLink link_ @@ -138,7 +138,7 @@ let link_' = AbsP link_ let file_ = sandbox $(mkRelFile "testfile") let file_' = AbsP file_ - writeFile file_ "This is a test" + writeFile (toFilePath file_) "This is a test" createSymbolicLink (toFilePath file_) (toFilePath link_) diagnoseFp link_' `shouldReturn` IsLinkTo file_' clean c $ CleanLink link_ @@ -178,7 +178,7 @@ let src' = AbsP src let dst = sandbox $(mkRelFile "testcopy") let dst' = AbsP dst - writeFile src "This is a file." + writeFile (toFilePath src) "This is a file." diagnoseFp src' `shouldReturn` IsFile diagnoseFp dst' `shouldReturn` Nonexistent -- Under test @@ -224,7 +224,7 @@ let dst' = AbsP dst diagnoseFp src' `shouldReturn` Nonexistent diagnoseFp dst' `shouldReturn` Nonexistent - writeFile src "This is a test." + writeFile (toFilePath src) "This is a test." diagnoseFp src' `shouldReturn` IsFile diagnoseFp dst' `shouldReturn` Nonexistent -- Under test diff --git a/test/SuperUserSpark/Diagnose/TestUtils.hs b/test/SuperUserSpark/Diagnose/TestUtils.hs --- a/test/SuperUserSpark/Diagnose/TestUtils.hs +++ b/test/SuperUserSpark/Diagnose/TestUtils.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE TemplateHaskell #-} - module SuperUserSpark.Diagnose.TestUtils where import TestImport diff --git a/test/SuperUserSpark/DiagnoseSpec.hs b/test/SuperUserSpark/DiagnoseSpec.hs --- a/test/SuperUserSpark/DiagnoseSpec.hs +++ b/test/SuperUserSpark/DiagnoseSpec.hs @@ -99,7 +99,7 @@ let link = sandbox $(mkRelFile "link") let link' = AbsP link expect "before" [(file', Nonexistent), (link', Nonexistent)] - writeFile file "This is a test" + writeFile (toFilePath file) "This is a test" expect "after file creation" [(file', IsFile), (link', Nonexistent)] @@ -137,7 +137,7 @@ forAll (absFileIn sandbox) $ \(file, file') -> do diagnoseFp file' `shouldReturn` Nonexistent ensureDir $ parent file - writeFile file "This is a test" + writeFile (toFilePath file) "This is a test" diagnoseFp file' `shouldReturn` IsFile removeFile file diagnoseFp file' `shouldReturn` Nonexistent @@ -154,7 +154,7 @@ expect "before" [(file', Nonexistent), (link', Nonexistent)] - writeFile file "This is a test" + writeFile (toFilePath file) "This is a test" expect "after file creation" [(file', IsFile), (link', Nonexistent)] @@ -257,7 +257,8 @@ let setupALotOfFiles = do forM_ [1 .. aLot] $ \i -> do f <- parseRelFile $ "file" ++ show i - writeFile (sandbox f) $ "This is file " ++ show i ++ ".\n" + writeFile (toFilePath $ sandbox f) $ + "This is file " ++ show i ++ ".\n" beforeAll_ setup $ afterAll_ teardown $ do describe "hashFilePath" $ do diff --git a/test/SuperUserSpark/EndToEnd/RegressionSpec.hs b/test/SuperUserSpark/EndToEnd/RegressionSpec.hs --- a/test/SuperUserSpark/EndToEnd/RegressionSpec.hs +++ b/test/SuperUserSpark/EndToEnd/RegressionSpec.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE LambdaCase #-} module SuperUserSpark.EndToEnd.RegressionSpec ( spec @@ -15,8 +16,7 @@ import SuperUserSpark.Utils spec :: Spec -spec = do - linkThenCopySpec +spec = linkThenCopySpec linkThenCopySpec :: Spec linkThenCopySpec = do @@ -25,40 +25,39 @@ let setup = ensureDir sandbox let teardown = removeDirRecur sandbox beforeAll_ setup $ - afterAll_ teardown $ do - describe "link then copy regression" $ do - let runSpark args = do - putStrLn $ unwords $ "spark" : args - withArgs args spark - it - "ensures that deploy fails when there is already a link that points to the file that is being copied." $ - withCurrentDir sandbox $ do - let cf = sandbox $(mkRelFile "cardfile.sus") - let file = $(mkRelFile "file") - let from = sandbox $(mkRelDir "from") file - let to = sandbox $(mkRelDir "to") file + afterAll_ teardown $ + describe "link then copy regression" $ do + let runSpark args = do + putStrLn . unwords $ "spark" : args + withArgs args spark + it + "ensures that deploy fails when there is already a link that points to the file that is being copied." $ + withCurrentDir sandbox $ do + let cf = sandbox $(mkRelFile "cardfile.sus") + let file = $(mkRelFile "file") + let from = sandbox $(mkRelDir "from") file + let to = sandbox $(mkRelDir "to") file -- Set up the file - ensureDir (parent from) - writeFile from "contents" + ensureDir (parent from) + writeFile (toFilePath from) "contents" + let setUpCardFile cf = do + runSpark ["parse", toFilePath cf] + runSpark ["compile", toFilePath cf] + runSpark ["bake", toFilePath cf] + runSpark ["check", toFilePath cf] + writeFile (toFilePath from) "contents" -- Set up the first card file - writeFile - cf - "card link { kind link; into to; outof from; file }" - runSpark ["parse", toFilePath cf] - runSpark ["compile", toFilePath cf] - runSpark ["bake", toFilePath cf] - runSpark ["check", toFilePath cf] - runSpark ["deploy", toFilePath cf] + writeFile + (toFilePath cf) + "card link { kind link; into to; outof from; file }" + setUpCardFile cf + runSpark ["deploy", toFilePath cf] -- Set up the second card file - writeFile - cf - "card link { kind copy; into to; outof from; file }" - runSpark ["parse", toFilePath cf] - runSpark ["compile", toFilePath cf] - runSpark ["bake", toFilePath cf] - runSpark ["check", toFilePath cf] - runSpark ["deploy", toFilePath cf] `shouldThrow` - (\e -> - case e of - ExitFailure _ -> True - _ -> False) + writeFile + (toFilePath cf) + "card link { kind copy; into to; outof from; file }" + setUpCardFile cf + runSpark ["deploy", toFilePath cf] `shouldThrow` + (\case + ExitFailure _ -> True + _ -> False) diff --git a/test/SuperUserSpark/EndToEndSpec.hs b/test/SuperUserSpark/EndToEndSpec.hs --- a/test/SuperUserSpark/EndToEndSpec.hs +++ b/test/SuperUserSpark/EndToEndSpec.hs @@ -33,7 +33,7 @@ let teardown = removeDirectoryRecursive sandbox let rsc = here "test_resources" "end-to-end" beforeAll_ setup $ - afterAll_ teardown $ do + afterAll_ teardown $ describe "standard bash card test" $ do let bashrsc = rsc "bash.sus" let bashrscres = rsc "bash.sus.res" @@ -48,11 +48,11 @@ P.writeFile "bash_profile" "bash_profile" let down = do removeFile cardfile - withCurrentDirectory sandbox $ do + withCurrentDirectory sandbox $ removeDirectoryRecursive "bash" beforeAll_ up $ afterAll_ down $ do - it "parses correcty" $ do + it "parses correcty" $ withCurrentDirectory sandbox $ withArgs ["parse", cardfile] spark `shouldReturn` () @@ -66,7 +66,7 @@ actual <- P.readFile outfile expected <- P.readFile bashrscres unless (actual == expected) $ expectationFailure $ unlines ["Expected and actual differ:", expected, actual] - it "checks without exceptions" $ do + it "checks without exceptions" $ withCurrentDirectory sandbox $ withArgs ["check", cardfile] spark `shouldReturn` () diff --git a/test/SuperUserSpark/Parser/Gen.hs b/test/SuperUserSpark/Parser/Gen.hs --- a/test/SuperUserSpark/Parser/Gen.hs +++ b/test/SuperUserSpark/Parser/Gen.hs @@ -32,7 +32,7 @@ oneof [generateTab, generateSpace, generateLineFeed, generateCarriageReturn] generateWords :: Gen String -generateWords = fmap unwords $ listOf1 generateWord +generateWords = unwords <$> listOf1 generateWord generateEol :: Gen String generateEol = elements ["\n", "\r", "\r\n"] @@ -52,12 +52,12 @@ generateQuotedIdentifier :: Gen (String, String) generateQuotedIdentifier = do w <- generateWord - return $ ("\"" ++ w ++ "\"", w) + return ("\"" ++ w ++ "\"", w) generatePlainIdentifier :: Gen (String, String) generatePlainIdentifier = do w <- generateWord - return $ (w, w) + return (w, w) generateFilePath :: Gen (FilePath, FilePath) generateFilePath = diff --git a/test/SuperUserSpark/Parser/TestUtils.hs b/test/SuperUserSpark/Parser/TestUtils.hs --- a/test/SuperUserSpark/Parser/TestUtils.hs +++ b/test/SuperUserSpark/Parser/TestUtils.hs @@ -26,7 +26,7 @@ succeedsWithLeftover parser input = isRight $ parseWithoutSource parser input succeedsAnywhere :: Parser a -> String -> Bool -succeedsAnywhere p s = or $ map (succeedsWithLeftover p) (tails s) +succeedsAnywhere p s = any (succeedsWithLeftover p) $ tails s where tails :: [a] -> [[a]] tails [] = [[]] @@ -51,4 +51,4 @@ parseFromSource parser testInputSource input `shouldBe` result parseWithoutSource :: Parser a -> String -> Either ParseError a -parseWithoutSource parser input = parseFromSource parser testInputSource input +parseWithoutSource parser = parseFromSource parser testInputSource diff --git a/test/SuperUserSpark/ParserSpec.hs b/test/SuperUserSpark/ParserSpec.hs --- a/test/SuperUserSpark/ParserSpec.hs +++ b/test/SuperUserSpark/ParserSpec.hs @@ -288,30 +288,30 @@ let pc = parseShouldSucceedAs card it "succeeds on this card with an empty name correctly" $ do pc "card \"\" {}" $ Card "" (Block []) - it "succeeds on this compressed empty cards" $ do + it "succeeds on this compressed empty cards" $ forAll generateCardName $ \(a, e) -> parseShouldSucceedAs card ("card" ++ a ++ "{}") $ Card e (Block []) - it "succeeds on empty cards with whitespace around the name" $ do + it "succeeds on empty cards with whitespace around the name" $ forAll generateCardName $ \(a, e) -> forAll (twice generateWhiteSpace) $ \(ws1, ws2) -> parseShouldSucceedAs card ("card" ++ ws1 ++ a ++ ws2 ++ "{}") $ Card e (Block []) - it "succeeds on empty cards with whitespace between the brackets" $ do + it "succeeds on empty cards with whitespace between the brackets" $ forAll generateCardName $ \(a, e) -> forAll generateWhiteSpace $ \ws -> parseShouldSucceedAs card ("card" ++ a ++ "{" ++ ws ++ "}") $ Card e (Block []) - it "fails on any card with an empty body" $ do + it "fails on any card with an empty body" $ forAll generateCardName $ \(a, _) -> forAll generateWhiteSpace $ \ws -> shouldFail card ("card" ++ a ++ ws) - it "succeeds on this complicated example" $ do + it "succeeds on this complicated example" $ parseShouldSucceedAs card - ("card complicated {\n alternatives $(HOST) shared\n hello l-> goodbye\n into $(HOME)\n outof depot\n spark card othercard\n kind link\n {\n one c-> more\n source -> destination\n file\n }\n}") $ + "card complicated {\n alternatives $(HOST) shared\n hello l-> goodbye\n into $(HOME)\n outof depot\n spark card othercard\n kind link\n {\n one c-> more\n source -> destination\n file\n }\n}" $ Card "complicated" $ Block [ Alternatives ["$(HOST)", "shared"] @@ -327,12 +327,12 @@ ] ] describe "declarations" $ do - it "succeeds for generated declarations'" $ do pending + it "succeeds for generated declarations'" pending let s = parseShouldSucceedAs declarations - it "succeeds for these cases" $ do + it "succeeds for these cases" $ s "into dir;outof dir" [IntoDir "dir", OutofDir "dir"] describe "declaration" $ do - it "succeeds for generated declarations" $ do pending + it "succeeds for generated declarations" pending let s = parseShouldSucceedAs declaration it "succeeds for these cases" $ do s "into directory" (IntoDir "directory") @@ -346,11 +346,11 @@ "iamthedestination" (Just CopyDeployment)) describe "block" $ do - it "succeeds for empty blocks" $ do + it "succeeds for empty blocks" $ parseShouldSucceedAs block "{}" (Block []) - it "succeeds for a doubly nested empty block" $ do + it "succeeds for a doubly nested empty block" $ parseShouldSucceedAs block "{{}}" (Block [Block []]) - it "succeeds for a triply nested empty block" $ do + it "succeeds for a triply nested empty block" $ parseShouldSucceedAs block "{{{}}}" (Block [Block [Block []]]) let s = parseShouldSucceedAs block it "succeeds for these cases" $ do @@ -361,7 +361,7 @@ "{\n into \"~\"\n \"xmonad\" -> \".xmonad\"\n}" (Block [IntoDir "~", Deploy "xmonad" ".xmonad" Nothing]) describe "sparkOff" $ do - it "succeeds for generated sparkOff declarations" $ do pending + it "succeeds for generated sparkOff declarations" pending let s f g = parseShouldSucceedAs sparkOff @@ -372,7 +372,7 @@ s "sparkcardname" "name" s "spark card \"name with spaces\"" "name with spaces" describe "intoDir" $ do - it "succeeds for generated into declarations" $ do + it "succeeds for generated into declarations" $ forAll generateLineSpace $ \ls -> forAll generateDirectory $ \(d, da) -> parseShouldSucceedAs @@ -385,7 +385,7 @@ s "into\t.xmonad" ".xmonad" s "into ~" "~" describe "outOfDir" $ do - it "succeeds for generated outof declarations" $ do + it "succeeds for generated outof declarations" $ forAll generateLineSpace $ \ls -> forAll generateDirectory $ \(d, da) -> parseShouldSucceedAs @@ -396,30 +396,28 @@ it "succeeds for these cases" $ do s "outof bash" "bash" s "outof\t.xmonad" ".xmonad" - describe "alternatives" $ do - it "succeeds for generated alternatives declarations with single spaces" $ do + describe "alternatives" $ + it "succeeds for generated alternatives declarations with single spaces" $ forAll (listOf1 generateDirectory) $ \ds -> let (des, das) = unzip ds in parseShouldSucceedAs alternatives - ("alternatives" ++ " " ++ intercalate " " des) + ("alternatives" ++ " " ++ unwords des) (Alternatives das) describe "deployment" $ do it "succeeds for short deployments" pending it "succeeds for long deployments" pending describe "shortDeployment" $ do - it "succeeds for any filepath with an identity deployment" $ do - property $ \f -> - succeeds filepath f ==> + it "succeeds for any filepath with an identity deployment" $ + property $ \f -> succeeds filepath f ==> parseShouldSucceedAs shortDeployment f (Deploy f f Nothing) - it "succeeds for generated filepaths with an identity deployment" $ do + it "succeeds for generated filepaths with an identity deployment" $ forAll generateFilePath $ \(f, g) -> parseShouldSucceedAs shortDeployment f (Deploy g g Nothing) - it "succeeds for any directory with an identity deployment" $ do - property $ \f -> - succeeds directory f ==> + it "succeeds for any directory with an identity deployment" $ + property $ \f -> succeeds directory f ==> parseShouldSucceedAs shortDeployment f (Deploy f f Nothing) - it "succeeds for generated directories with an identity deployment" $ do + it "succeeds for generated directories with an identity deployment" $ forAll generateDirectory $ \(f, g) -> parseShouldSucceedAs shortDeployment f (Deploy g g Nothing) let s f = parseShouldSucceedAs shortDeployment f (Deploy f f Nothing) @@ -428,7 +426,7 @@ s "xmonad.hs" s "/home/user/.bashrc" describe "longDeployment" $ do - it "succeeds for generated long deployments with quoted identifiers" $ do + it "succeeds for generated long deployments with quoted identifiers" $ forAll generateDeploymentKindSymbol $ \dks -> forAll generateLineSpace $ \ls1 -> forAll generateLineSpace $ \ls2 -> @@ -444,7 +442,7 @@ (fp1 ++ ls1 ++ dks ++ ls2 ++ fp2) (Deploy fp1a fp2a dk) it - "succeeds for single-space-separated long deployments with gerenated plain identifiers" $ do + "succeeds for single-space-separated long deployments with gerenated plain identifiers" $ pendingWith "This would go wrong with plain identifiers they can end with \'l\' or \'c\'. Make sure to document this behaviour and write another test with plain identifiers." let s f g h i = parseShouldSucceedAs longDeployment f (Deploy g h i) @@ -466,22 +464,21 @@ Nothing describe "deploymentKind" $ do let (-=>) = parseShouldSucceedAs deploymentKind - it "succeeds for the link deployment kind" $ do + it "succeeds for the link deployment kind" $ "l->" -=> Just LinkDeployment - it "succeeds for the copy deployment kind" $ do + it "succeeds for the copy deployment kind" $ "c->" -=> Just CopyDeployment - it "succeeds for the default deployment kind" $ do "->" -=> Nothing - it "fails for anything else" $ do - property $ \s -> - (not $ any (== s) ["l->", "c->", "->"]) ==> + it "succeeds for the default deployment kind" $ "->" -=> Nothing + it "fails for anything else" $ property $ \s -> + notElem s ["l->", "c->", "->"] ==> shouldFail deploymentKind s cardReferenceParserTests :: Spec cardReferenceParserTests = do - describe "compilerCardReference" $ do pend - describe "deployerCardReference" $ do pend - describe "compiledCardReference" $ do pend - describe "cardReference" $ do pend + describe "compilerCardReference" pend + describe "deployerCardReference" pend + describe "compiledCardReference" pend + describe "cardReference" pend describe "cardNameReference" $ do pend let s f g = @@ -498,7 +495,7 @@ s "file card.sus name" (CardFileReference "card.sus" $ Just $ CardNameReference "name") - describe "unprefixedCardFileReference" $ do pend + describe "unprefixedCardFileReference" pend parserBlackBoxTests :: Spec parserBlackBoxTests = do @@ -509,15 +506,13 @@ (testRecoursesDir ) [shouldParseDir, shouldCompileDir, shouldNotCompileDir] forFileInDirss dirs $ - concerningContents $ \f contents -> do - it (toFilePath f) $ - parseCardFile f contents `shouldSatisfy` isRight + concerningContents $ \f contents -> it (toFilePath f) $ + parseCardFile f contents `shouldSatisfy` isRight describe "Correct unsuccesfull parse examples" $ do let dirs = map (testRecoursesDir ) [shouldNotParseDir] - forFileInDirss dirs $ - concerningContents $ \f contents -> do + forFileInDirss dirs $ concerningContents $ \f contents -> it (toFilePath f) $ - parseCardFile f contents `shouldSatisfy` isLeft + parseCardFile f contents `shouldSatisfy` isLeft toplevelParserTests :: Spec toplevelParserTests = do @@ -525,4 +520,4 @@ it "Only ever produces valid SparkFile's" $ validIfSucceeds2 parseCardFile pend - describe "resetPosition" $ do pend + describe "resetPosition" pend diff --git a/test/TestImport.hs b/test/TestImport.hs --- a/test/TestImport.hs +++ b/test/TestImport.hs @@ -2,7 +2,7 @@ ( module X ) where -import Prelude as X hiding (writeFile, readFile, putStr,putStrLn, appendFile) +import Prelude as X import Path as X import Path.IO as X @@ -16,8 +16,6 @@ import Control.Monad.Writer as X import Debug.Trace as X - -import Data.IOString as X import Test.Hspec as X import Test.QuickCheck as X diff --git a/test/TestUtils.hs b/test/TestUtils.hs --- a/test/TestUtils.hs +++ b/test/TestUtils.hs @@ -18,7 +18,7 @@ concerningContents :: (Path Abs File -> String -> SpecWith a) -> (Path Abs File -> SpecWith a) -concerningContents func file = (runIO $ readFile file) >>= func file +concerningContents func file = (runIO . readFile $ toFilePath file) >>= func file forFileInDirss :: [Path Abs Dir] -> (Path Abs File -> SpecWith a) -> SpecWith a forFileInDirss [] _ = return ()