packages feed

super-user-spark 0.3.2.0 → 0.4.0.0

raw patch · 87 files changed

+5493/−3240 lines, 87 filesdep +genvaliditydep +genvalidity-hspecdep +genvalidity-hspec-aesondep −pureMD5dep −shellydep ~aesondep ~aeson-prettydep ~basenew-component:exe:super-user-spark

Dependencies added: genvalidity, genvalidity-hspec, genvalidity-hspec-aeson, genvalidity-path, hashable, iostring, path, path-io, validity, validity-path

Dependencies removed: pureMD5, shelly

Dependency ranges changed: aeson, aeson-pretty, base, directory, hspec, hspec-core, optparse-applicative, process, transformers

Files

app/Main.hs view
@@ -1,6 +1,6 @@ module Main (main) where -import           Spark+import           SuperUserSpark  main :: IO () main = spark
− src/Arguments.hs 
@@ -1,144 +0,0 @@-{-# LANGUAGE CPP #-}-module Arguments where--#if (MIN_VERSION_base(4,9,0))-import           Data.Monoid-#endif--import           Options.Applicative-import           System.Environment  (getArgs)--import           Config-import           Dispatch.Types-import           Types-import           Utils---getInstructions :: IO Instructions-getInstructions = do-    mins <- fmap transformOptions getOptions-    case mins of-        Right ins -> return ins-        Left err  -> die $ "Failed to parse instructions\n" ++ err--transformOptions :: Options -> Either String Instructions-transformOptions (dispatch, go) = (,) <$> pure dispatch <*> configFromOptions go--configFromOptions :: GlobalOptions -> Either String SparkConfig-configFromOptions go = Right conf-  where-    conf = defaultConfig-          { conf_compile_output             = opt_output go-          , conf_compile_kind               = opt_kind go-          , conf_compile_override           = opt_overrride go-          , conf_deploy_replace_links       = opt_replace_links go       || opt_replace go-          , conf_deploy_replace_files       = opt_replace_files go       || opt_replace go-          , conf_deploy_replace_directories = opt_replace_directories go || opt_replace go-          , conf_debug                      = opt_debug go-          }--getOptions :: IO Options-getOptions = do-    args <- getArgs-    let result = runOptionsParser args-    handleParseResult result--runOptionsParser :: [String] -> ParserResult Options-runOptionsParser strs = execParserPure prefs optionsParser strs-  where-    prefs = ParserPrefs-      { prefMultiSuffix = "SPARK"  -- metavar suffix for multiple options-      , prefDisambiguate = True    -- automatically disambiguate abbreviations (default: False)-      , prefShowHelpOnError = True -- always show help text on parse errors (default: False)-      , prefBacktrack = True       -- backtrack to parent parser when a subcommand fails (default: True)-      , prefColumns = 80           -- number of columns in the terminal, used to format the help page (default: 80)-      }--optionsParser :: ParserInfo Options-optionsParser = info (helper <*> parseOptions) help-  where-    help = fullDesc <> progDesc description-    description = "Super User Spark, author: Tom Sydney Kerckhove"--parseOptions :: Parser Options-parseOptions = (,) <$> parseCommand <*> parseGlobalOptions--parseCommand :: Parser Dispatch-parseCommand = hsubparser $ mconcat-    [ command "parse"   parseParse-    , command "compile" parseCompile-    , command "check"   parseCheck-    , command "deploy"  parseDeploy-    ]--parseParse :: ParserInfo Dispatch-parseParse = info parser modifier-  where-    parser = DispatchParse <$> strArgument (metavar "FILE" <> help "the file to parse")-    modifier = fullDesc-            <> progDesc "Parse a spark file and check for syntactic errors."--parseCompile :: ParserInfo Dispatch-parseCompile = info parser modifier-  where-    parser = DispatchCompile-      <$> argument auto-        (metavar "CARD" <> help "the card file to compile")-    modifier = fullDesc-            <> progDesc "Compile a spark card."--parseCheck :: ParserInfo Dispatch-parseCheck = info parser modifier-  where-    parser = DispatchCheck-      <$> argument auto-         (metavar "CARD" <> help "the card to check")-    modifier = fullDesc-            <> progDesc "Check the deployment of a spark card."--parseDeploy :: ParserInfo Dispatch-parseDeploy = info parser modifier-  where-    parser = DispatchDeploy-      <$> argument auto-        (metavar "CARD" <> help "the card to deploy") -- TODO more help-    modifier = fullDesc-            <> progDesc "Deploy a spark card."---parseGlobalOptions :: Parser GlobalOptions-parseGlobalOptions = GlobalOptions-    <$> option (Just <$> str)-      ( long "output"-        <> short 'o'-        <> value Nothing-        <> metavar "FILE"-        <> help "The output file for compilation" )-    <*> option (Just <$> auto)-      ( long "kind"-        <> short 'k'-        <> value Nothing-        <> metavar "KIND"-        <> help "The kind specification for unspecified deployments (default: link)" )-    <*> option (Just <$> auto)-      ( long "override"-        <> short 'O'-        <> value Nothing-        <> metavar "KIND"-        <> help "Override every deployment to be of the given kind" )-    <*> switch-      ( long "replace-links"-        <> help "Replace links at deploy destinations." )-    <*> switch-      ( long "replace-files"-        <> help "Replace existing files at deploy destinations." )-    <*> switch-      ( long "replace-Directories"-        <> help "Replace existing directories at deploy destinations." )-    <*> switch-      ( long "replace-all"-        <> short 'r'-        <> help "Equivalent to --replace-files --replace-directories --replace-links" )-    <*> switch-      ( long "debug"-        <> help "Show al debug information." )
− src/Check.hs 
@@ -1,17 +0,0 @@-module Check (-      check-    , formatDeploymentChecks-    ) where--import           Check.Internal-import           Check.Types-import           Compiler.Types-import           Deployer.Internal--check :: [Deployment] -> IO [DeploymentCheckResult]-check ds = do-    completed <- completeDeployments ds-    diagnosed <- mapM diagnoseDeployment completed-    return $ map checkDeployment diagnosed--
− src/Check/Internal.hs 
@@ -1,244 +0,0 @@-module Check.Internal where--import           Check.Types-import           Compiler.Types-import           Constants-import           CoreTypes-import qualified Data.ByteString       as SB-import qualified Data.ByteString.Char8 as SBC-import qualified Data.ByteString.Lazy  as LB-import qualified Data.Digest.Pure.MD5  as H (md5)-import           Data.Maybe            (catMaybes)-import           System.Directory      (getDirectoryContents)-import           System.Exit           (ExitCode (..))-import           System.FilePath       ((</>))-import           System.Posix.Files    (fileExist, getSymbolicLinkStatus,-                                        isBlockDevice, isCharacterDevice,-                                        isDirectory, isNamedPipe, isRegularFile,-                                        isSocket, isSymbolicLink,-                                        readSymbolicLink)-import           System.Process        (readProcess, system)--checkDeployment :: DiagnosedDeployment -> DeploymentCheckResult-checkDeployment (Diagnosed [] (D dst _ _) _)-    = ImpossibleDeployment [unwords ["No source for deployment with destination", dst]]-checkDeployment (Diagnosed srcs dst kind)-    = bestResult $ map (\src -> checkSingle src dst kind) srcs--bestResult :: [CheckResult] -> DeploymentCheckResult-bestResult cs-    | all impossible cs = ImpossibleDeployment $ map (\(Impossible s) -> s) cs-    | otherwise-        -- Will not be empty as per line above-        = case head $ dropWhile impossible cs of-            AlreadyDone  -> DeploymentDone-            Ready i      -> ReadyToDeploy i-            Dirty s i c  -> DirtySituation s i c-            Impossible _ -> error "Cannot be the case"--impossible :: CheckResult -> Bool-impossible (Impossible _) = True-impossible _ = False--impossibleDeployment :: DeploymentCheckResult -> Bool-impossibleDeployment (ImpossibleDeployment _) = True-impossibleDeployment _ = False--dirtyDeployment :: DeploymentCheckResult -> Bool-dirtyDeployment (DirtySituation _ _ _) = True-dirtyDeployment _ = False--deploymentReadyToDeploy :: DeploymentCheckResult -> Bool-deploymentReadyToDeploy (ReadyToDeploy _) = True-deploymentReadyToDeploy _ = False--deploymentIsDone :: DeploymentCheckResult -> Bool-deploymentIsDone DeploymentDone = True-deploymentIsDone _ = False----- | Check a single (@source@, @destination@, @kind@) triple.-checkSingle :: DiagnosedFp -> DiagnosedFp -> DeploymentKind -> CheckResult-checkSingle (D src srcd srch) (D dst dstd dsth) kind =-    case (srcd, dstd, kind) of-        (IsFile     , Nonexistent   , _             ) -> ready--        (IsFile     , IsFile        , LinkDeployment)-            -> e ["Both the source:", src, "and the destination:", dst, "are files for a link deployment."]--        (IsFile     , IsFile        , CopyDeployment)-            -> if srch == dsth-                then AlreadyDone-                else e ["Both the source:", src, "and the destination:", dst, "are files for a copy deployment, but they are not equal."]--        (IsFile     , IsDirectory   , _)-            -> e ["The source: ", src, "is a file but the destination:", dst, "is a directory."]--        (IsFile     , IsLinkTo l    , LinkDeployment)-            -> if l == src-                then AlreadyDone-                else e ["The source:", src, "is a file and the destination:", dst, "is a link for a link deployment but the destination does not point to the source. Instead it points to:", l ++ "."]--        (IsFile     , IsLinkTo _    , CopyDeployment)-            -> e ["The source:", src, "is a file and the destination:", dst, "is a link for a copy deployment."]--        (IsDirectory, Nonexistent   , _             ) -> ready--        (IsDirectory, IsFile        , _             )-            -> e ["The source:", src, "is a directory and the destination:", dst, "is a file."]--        (IsDirectory, IsDirectory   , CopyDeployment)-            -> if srch == dsth-                then AlreadyDone-                else e ["The source:", src, "and destination:", dst, "are directories for a copy deployment, but they are not equal."]--        (IsDirectory, IsDirectory   , LinkDeployment)-            -> e ["The source:", src, "and the destination:", dst, "are directories for a link deployment."]--        (IsDirectory, IsLinkTo l    , LinkDeployment)-            -> if l == src-                then AlreadyDone-                else e ["The source:", src, "is a directory and the destination:", dst, "is a link for a link deployment but the destination does not point to the source. Instead it points to:", l ++ "."]--        (IsDirectory, IsLinkTo _    , CopyDeployment)-            -> e ["The source:", src, "is a directory and the destination:", dst, "is a link for a copy deployment."]--        (Nonexistent, _             , _             )-            -> i ["The source:", src, "does not exist."]--        (IsLinkTo _ , _             , _             )-            -> i ["The source:", src, "is a link."]--        (IsWeird    , IsWeird       , _             )-            -> i ["Both the source:", src, "and the destination:", dst, "are weird."]--        (IsWeird    , _             , _             )-            -> i ["The source:", src, "is weird."]--        (_          , IsWeird       , _             )-            -> i ["The destination:", dst, "is weird."]-  where-    ins = Instruction src dst kind-    ready = Ready ins-    i = Impossible . unlines-    e s = Dirty (unlines s) ins cins-    cins = case dstd of-            IsFile -> CleanFile dst-            IsLinkTo _ -> CleanLink dst-            IsDirectory -> CleanDirectory dst-            _ -> error "should not occur"--diagnoseDeployment :: Deployment -> IO DiagnosedDeployment-diagnoseDeployment (Put srcs dst kind) = do-    dsrcs <- mapM diagnose srcs-    ddst <- diagnose dst-    return $ Diagnosed dsrcs ddst kind--diagnose :: FilePath -> IO DiagnosedFp-diagnose fp = do-    d <- diagnoseFp fp-    hash <- hashFilePath fp-    return $ D fp d hash--diagnoseFp :: FilePath -> IO Diagnostics-diagnoseFp fp = do-    e <- fileExist fp-    if e-    then do-        s <- getSymbolicLinkStatus fp-        if isBlockDevice s || isCharacterDevice s || isSocket s || isNamedPipe s-        then return IsWeird-        else do-            if isSymbolicLink s-            then do-                point <- readSymbolicLink fp-                return $ IsLinkTo point-            else if isDirectory s-                then return IsDirectory-                else if isRegularFile s-                    then return IsFile-                    else error $ "File " ++ fp ++ " was neither a block device, a character device, a socket, a named pipe, a symbolic link, a directory or a regular file"-    else do-        -- If a link exists, but it points to something that doesn't exist, it is considered as non-existent by `fileExist`-        es <- system $ unwords ["test", "-L", fp]-        case es of-            ExitSuccess -> do-                -- Need to do a manual call because readSymbolicLink fails for nonexistent destinations-                point <- readProcess "readlink" [fp] ""-                return $ IsLinkTo $ init point -- remove newline-            ExitFailure _ -> return Nonexistent---md5 :: SB.ByteString -> HashDigest-md5 bs = H.md5 $ LB.fromStrict bs---- | Hash a filepath so that two filepaths with the same contents have the same hash-hashFilePath :: FilePath -> IO HashDigest-hashFilePath fp = do-    d <- diagnoseFp fp-    case d of-        IsFile -> hashFile fp-        IsDirectory -> hashDirectory fp-        IsLinkTo _ -> return $ md5 SB.empty-        IsWeird -> return $ md5 SB.empty-        Nonexistent -> return $ md5 SB.empty--hashFile :: FilePath -> IO HashDigest-hashFile fp = md5 <$> SB.readFile fp--hashDirectory :: FilePath -> IO HashDigest-hashDirectory fp = do-    rawContents <- getDirectoryContents fp-    let contents = map (fp </>) . filter (\f -> not $ f == "." || f == "..") $ rawContents-    hashes <- mapM hashFilePath contents-    let hashbs = map (SBC.pack . show) hashes-    return $ md5 $ SB.concat hashbs---formatDeploymentChecks :: [(Deployment, DeploymentCheckResult)] -> String-formatDeploymentChecks dss-    = if null output-        then "Deployment is done already."-        else unlines output ++-            if all (impossibleDeployment . snd) dss-             then "Deployment is impossible."-             else "Deployment is possible."-    where output = catMaybes $ map formatDeploymentCheck dss---formatDeploymentCheck :: (Deployment, DeploymentCheckResult) -> Maybe String-formatDeploymentCheck (_, (ReadyToDeploy is))         = Just $ "READY: " ++ formatInstruction is-formatDeploymentCheck (_, DeploymentDone)             = Nothing-formatDeploymentCheck (d, ImpossibleDeployment ds)-    = Just $ "IMPOSSIBLE: "-    ++ deployment_dst d-    ++ " cannot be deployed:\n"-    ++ unlines ds ++ "\n"-formatDeploymentCheck (d, (DirtySituation str is c))-    = Just $ "DIRTY: "-    ++ deployment_dst d-    ++ "\n"-    ++ str-    ++ "planned: "-    ++ formatInstruction is-    ++ "\n"-    ++ "cleanup needed:\n"-    ++ formatCleanupInstruction c-    ++ "\n"--formatInstruction :: Instruction -> String-formatInstruction (Instruction src dst k) = unwords $-    [ src-    , kindSymbol k-    , dst-    ]-  where-    kindSymbol LinkDeployment = linkKindSymbol-    kindSymbol CopyDeployment = copyKindSymbol--formatCleanupInstruction :: CleanupInstruction -> String-formatCleanupInstruction (CleanFile fp)         = "remove file " ++ fp-formatCleanupInstruction (CleanDirectory dir)   = "remove directory " ++ dir-formatCleanupInstruction (CleanLink link)       = "remove link " ++ link--
− src/Check/Types.hs 
@@ -1,50 +0,0 @@-module Check.Types where--import           CoreTypes-import           Data.Digest.Pure.MD5 (MD5Digest)--type HashDigest = MD5Digest--data Diagnostics-    = Nonexistent-    | IsFile-    | IsDirectory-    | IsLinkTo FilePath-    | IsWeird-    deriving (Show, Eq)--data DiagnosedFp = D-    { diagnosedFilePath    :: FilePath-    , diagnosedDiagnostics :: Diagnostics-    , diagnosedHashDigest  :: HashDigest-    } deriving (Show, Eq)--data Instruction = Instruction FilePath FilePath DeploymentKind-    deriving (Show, Eq)--data CleanupInstruction-    = CleanFile FilePath-    | CleanDirectory FilePath-    | CleanLink FilePath-    deriving (Show, Eq)--data DeploymentCheckResult-    = DeploymentDone                                        -- ^ Done already-    | ReadyToDeploy Instruction                             -- ^ Immediately possible-    | DirtySituation String Instruction CleanupInstruction  -- ^ Possible after cleanup of destination-    | ImpossibleDeployment [String]                         -- ^ Entirely impossible-    deriving (Show, Eq)--data CheckResult-    = AlreadyDone                                   -- ^ Done already-    | Ready Instruction                             -- ^ Immediately possible-    | Dirty String Instruction CleanupInstruction   -- ^ Possible after cleanup-    | Impossible String                             -- ^ Entirely impossible-    deriving (Show, Eq)--data DiagnosedDeployment = Diagnosed-    { diagnosedSrcs :: [DiagnosedFp]-    , diagnosedDst  :: DiagnosedFp-    , diagnosedKind :: DeploymentKind-    } deriving (Show, Eq)-
− src/Compiler.hs 
@@ -1,95 +0,0 @@-module Compiler where--import           Compiler.Internal-import           Compiler.Types-import           Control.Monad              (when)-import           Data.Aeson                 (eitherDecode)-import           Data.Aeson.Encode.Pretty   (encodePretty)-import qualified Data.ByteString.Lazy.Char8 as BS-import           Data.List                  (find, stripPrefix)-import           Language.Types-import           Parser-import           PreCompiler-import           System.FilePath            (takeDirectory, (</>))-import           Types--compileJob :: CardFileReference -> Sparker [Deployment]-compileJob cr@(CardFileReference root _) = go "" cr-  where-    go :: FilePath -> CardFileReference -> Sparker [Deployment]-    go base (CardFileReference fp mcn) = do-        sf <- parseFile fp-        let scope = sparkFileCards sf-        unit <- case mcn of-                Nothing -> case scope of-                    [] -> throwError $ CompileError $ "No cards found for compilation in file:" ++ fp-                    (first:_) -> return first-                Just (CardNameReference name) -> do-                    case find (\c -> cardName c == name) scope of-                            Nothing   -> throwError $ CompileError $ unwords ["Card", name, "not found for compilation."]-                            Just cu -> return cu--        -- Inject base outofDir-        let injected = injectBase unit--        -- Precompile checks-        let pces = preCompileChecks injected-        when (not . null $ pces) $ throwError $ PreCompileError pces--        -- Compile this unit-        (deps, crfs) <- embedPureCompiler $ compileUnit injected--        -- Compile the rest of the units-        restDeps <- fmap concat-                    $ mapM compileCardReference-                    $ map (resolveCardReferenceRelativeTo fp) crfs--        return $ deps ++ restDeps-      where--        injectBase :: Card -> Card-        injectBase c@(Card name s) | null base = c-                                   | otherwise = Card name $ Block [OutofDir base, s]--        stripRoot :: FilePath -> FilePath-        stripRoot orig = case stripPrefix (takeDirectory root) orig of-            Nothing -> orig-            Just ('/':new) -> new-            Just new -> new--        composeBases :: FilePath -> FilePath -> FilePath-        composeBases base [] = base-        composeBases _ base2 = takeDirectory (stripRoot base2)---        compileCardReference :: CardReference -> Sparker [Deployment]-        compileCardReference (CardFile cfr@(CardFileReference base2 _)) = go (composeBases base base2) cfr-        compileCardReference (CardName cnr) = go base (CardFileReference fp $ Just cnr)--resolveCardReferenceRelativeTo :: FilePath -> CardReference -> CardReference-resolveCardReferenceRelativeTo fp (CardFile (CardFileReference cfp mcn)) = CardFile $ CardFileReference (takeDirectory fp </> cfp) mcn-resolveCardReferenceRelativeTo _ cn = cn--embedPureCompiler :: PureCompiler a -> Sparker a-embedPureCompiler func = withExceptT CompileError $ mapExceptT (mapReaderT idToIO) func-  where-    idToIO :: Identity a -> IO a-    idToIO = return . runIdentity--outputCompiled :: [Deployment] -> Sparker ()-outputCompiled deps = do-    out <- asks conf_compile_output-    liftIO $ do-        let bs = encodePretty deps-        case out of-            Nothing -> BS.putStrLn bs-            Just fp -> BS.writeFile fp bs--inputCompiled :: FilePath -> Sparker [Deployment]-inputCompiled fp = do-    bs <- liftIO $ BS.readFile fp-    case eitherDecode bs of-        Left err        -> throwError $ CompileError $ "Something went wrong while deserialising json data: " ++ err-        Right ds        -> return ds--
− src/Compiler/Internal.hs 
@@ -1,64 +0,0 @@-module Compiler.Internal where--import           Compiler.Types-import           Compiler.Utils-import           Language.Types-import           System.FilePath ((</>))-import           Types--compileUnit :: Card -> PureCompiler ([Deployment], [CardReference])-compileUnit card = do-    initSt <- initialState-    execWriterT $ evalStateT (compileDecs [cardContent card]) initSt--compileDecs :: [Declaration] -> InternalCompiler ()-compileDecs = mapM_ compileDec--compileDec :: Declaration -> InternalCompiler ()-compileDec (Deploy src dst kind) = do-    override <- gets state_deployment_kind_override-    superOverride <- asks conf_compile_override-    let resultKind-            = case (superOverride, override, kind) of-                (Nothing, Nothing, Nothing) -> LinkDeployment-                (Nothing, Nothing, Just k ) -> k-                (Nothing, Just o , _      ) -> o-                (Just o , _      , _      ) -> o-    outof <- gets state_outof_prefix-    into <- gets state_into--    let alternates = resolvePrefix $ outof ++ [sources src]-    let destination = into </> dst--    addDeployment $ Put alternates destination resultKind---compileDec (SparkOff cr) = addCardRef cr---compileDec (IntoDir dir) = do-    ip <- gets state_into-    if null ip-    then modify (\s -> s {state_into = dir} )-    else modify (\s -> s {state_into = ip </> dir} )---compileDec (OutofDir dir) = do-    op <- gets state_outof_prefix-    modify (\s -> s {state_outof_prefix = op ++ [Literal dir]})---compileDec (DeployKindOverride kind) = do-    modify (\s -> s { state_deployment_kind_override = Just kind })---compileDec (Block ds) = do-    before <- get-    compileDecs ds-    put before---compileDec (Alternatives ds) = do-    op <- gets state_outof_prefix-    modify (\s -> s { state_outof_prefix = op ++ [Alts ds] })-
− src/Compiler/Types.hs 
@@ -1,63 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Compiler.Types where--import           Constants-import           Control.Monad  (mzero)-import           CoreTypes-import           Data.Aeson     (FromJSON (..), ToJSON (..), Value (..), object,-                                 (.:), (.=))-import           Language.Types-import           Monad-import           Types--data Deployment = Put-    { deployment_srcs :: [FilePath]-    , deployment_dst  :: FilePath-    , deployment_kind :: DeploymentKind-    } deriving Eq--instance Show Deployment where-    show dep = unwords $ srcs ++ [k,dst]-      where-        srcs = map quote $ deployment_srcs dep-        k = case deployment_kind dep of-                LinkDeployment -> linkKindSymbol-                CopyDeployment -> copyKindSymbol-        dst = quote $ deployment_dst dep-        quote = (\s -> "\"" ++ s ++ "\"")--instance FromJSON Deployment where-    parseJSON (Object o)-        = Put <$> o .: "sources"-              <*> o .: "destination"-              <*> o .: "deployment kind"-    parseJSON _ = mzero--instance ToJSON Deployment where-    toJSON depl-        = object-        [ "sources" .= deployment_srcs depl-        , "destination" .= deployment_dst depl-        , "deployment kind" .= deployment_kind depl-        ]--type CompilerPrefix = [PrefixPart]--data PrefixPart-    = Literal String-    | Alts [String]-    deriving (Show, Eq)--data CompilerState = CompilerState-    { state_deployment_kind_override :: Maybe DeploymentKind-    , state_into                     :: Directory-    , state_outof_prefix             :: CompilerPrefix-    } deriving (Show, Eq)--type PrecompileError = String--type ImpureCompiler = ExceptT CompileError (ReaderT SparkConfig IO)-type PureCompiler = ExceptT CompileError (ReaderT SparkConfig Identity)-type Precompiler = WriterT [PrecompileError] Identity-type InternalCompiler = StateT CompilerState (WriterT ([Deployment], [CardReference]) PureCompiler)-
− src/Compiler/Utils.hs 
@@ -1,39 +0,0 @@-module Compiler.Utils where--import           Compiler.Types-import           Language.Types-import           System.FilePath ((</>))-import           Types---initialState :: PureCompiler CompilerState-initialState = do-    override <- asks conf_compile_kind-    return $ CompilerState-        { state_deployment_kind_override = override-        , state_into = ""-        , state_outof_prefix = []-        }--addDeployment :: Deployment -> InternalCompiler ()-addDeployment d = tell ([d], [])--addCardRef :: CardReference -> InternalCompiler ()-addCardRef c = tell ([], [c])--sources :: FilePath -> PrefixPart-sources fp@('.':f) = Alts [fp, f]-sources fp = Literal fp--resolvePrefix :: CompilerPrefix -> [FilePath]-resolvePrefix [] = []-resolvePrefix [Literal s] = [s]-resolvePrefix [Alts ds] = ds-resolvePrefix ((Literal s):ps) = do-    rest <- resolvePrefix ps-    return $ s </> rest-resolvePrefix ((Alts as):ps) = do-    a <- as-    rest <- resolvePrefix ps-    return $ a </> rest-
− src/Config.hs 
@@ -1,14 +0,0 @@-module Config where--import           Config.Types--defaultConfig :: SparkConfig-defaultConfig = Config-    { conf_compile_output             = Nothing-    , conf_compile_kind               = Nothing-    , conf_compile_override           = Nothing-    , conf_deploy_replace_links       = False-    , conf_deploy_replace_files       = False-    , conf_deploy_replace_directories = False-    , conf_debug                      = False-    }
− src/Config/Types.hs 
@@ -1,13 +0,0 @@-module Config.Types where--import           CoreTypes--data SparkConfig = Config-    { conf_compile_output             :: Maybe FilePath-    , conf_compile_kind               :: Maybe DeploymentKind-    , conf_compile_override           :: Maybe DeploymentKind-    , conf_deploy_replace_links       :: Bool-    , conf_deploy_replace_files       :: Bool-    , conf_deploy_replace_directories :: Bool-    , conf_debug                      :: Bool-    } deriving (Show, Eq)
− src/Constants.hs 
@@ -1,67 +0,0 @@-module Constants where--keywordCard :: String-keywordCard = "card"--keywordSpark :: String-keywordSpark = "spark"--keywordFile :: String-keywordFile = "file"--keywordInto :: String-keywordInto = "into"--keywordOutof :: String-keywordOutof = "outof"--keywordKindOverride :: String-keywordKindOverride = "kind"--keywordLink :: String-keywordLink = "link"--keywordCopy :: String-keywordCopy = "copy"--keywordAlternatives :: String-keywordAlternatives = "alternatives"--linkKindSymbol :: String-linkKindSymbol = "l->"--copyKindSymbol :: String-copyKindSymbol = "c->"--unspecifiedKindSymbol :: String-unspecifiedKindSymbol = "->"--bracesChars :: [Char]-bracesChars = ['{','}']--linespaceChars :: [Char]-linespaceChars = [' ', '\t']--endOfLineChars :: [Char]-endOfLineChars = ['\n','\r']--whitespaceChars :: [Char]-whitespaceChars = linespaceChars ++ endOfLineChars--lineDelimiter :: String-lineDelimiter = ";"--branchDelimiter :: String-branchDelimiter = ":"--quotesChar :: Char-quotesChar = '"'--lineCommentStr :: String-lineCommentStr = "#"--blockCommentStrs :: (String, String)-blockCommentStrs = ("[[", "]]")--sparkExtension :: String-sparkExtension = "sus"
− src/CoreTypes.hs 
@@ -1,27 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module CoreTypes where--import           Control.Monad (mzero)-import           Data.Aeson    (FromJSON (..), ToJSON (..), Value (..))--type Directory = FilePath---- | The kind of a deployment-data DeploymentKind = LinkDeployment-                    | CopyDeployment-    deriving (Show, Eq)--instance Read DeploymentKind where-    readsPrec _ "link" = [(LinkDeployment,"")]-    readsPrec _ "copy" = [(CopyDeployment,"")]-    readsPrec _ _ = []--instance FromJSON DeploymentKind where-    parseJSON (String "link") = return LinkDeployment-    parseJSON (String "copy") = return CopyDeployment-    parseJSON _ = mzero--instance ToJSON DeploymentKind where-    toJSON LinkDeployment = String "link"-    toJSON CopyDeployment = String "copy"-
− src/Deployer.hs 
@@ -1,48 +0,0 @@-module Deployer where--import           Check-import           Check.Internal-import           Check.Types-import           Compiler.Types-import           Control.Monad     (forM_, when)-import           Deployer.Internal-import           Monad-import           Types-import           Utils---deploy :: [(Deployment, DeploymentCheckResult)] -> Sparker ()-deploy dcrs = do-    let crs = map snd dcrs-    -- Check for impossible deployments-    when (any impossibleDeployment crs) $-        err dcrs "Deployment is impossible."--    -- Clean up the situation-    forM_ crs $ \d -> do-        case d of-            DirtySituation _ _ cis -> performClean cis-            _ -> return ()--    -- Check again-    let ds = map fst dcrs-    dcrs2 <- liftIO $ check ds--    -- Error if the cleaning is not done now.-    when (any (impossibleDeployment ||| dirtyDeployment) dcrs2) $-        err (zip ds dcrs2) "Situation was not entirely clean after attemted cleanup. Maybe you forgot to enable cleanups (--replace-all)?"--    -- Perform deployments-    liftIO $ mapM_ performDeployment $ map (\(ReadyToDeploy i) -> i) $ filter deploymentReadyToDeploy dcrs2--    -- Check one last time.-    dcrsf <- liftIO $ check ds-    when (any (not . deploymentIsDone) dcrsf) $ do-        err (zip ds dcrsf) "Something went wrong during deployment. It's not done yet."-  where-    err :: [(Deployment, DeploymentCheckResult)] -> String -> Sparker ()-    err dcrs text = do-        liftIO $ putStrLn $ formatDeploymentChecks dcrs-        throwError $ DeployError text--
− src/Deployer/Internal.hs 
@@ -1,94 +0,0 @@-module Deployer.Internal where--import           Check.Types-import           Compiler.Types-import           Data.List             (isPrefixOf)-import           Data.Text             (pack)-import           Deployer.Types-import           Shelly                (cp_r, fromText, shelly)-import           System.Directory      (getHomeDirectory,-                                        removeDirectoryRecursive, removeFile)-import           System.Environment    (getEnvironment)-import           System.FilePath       (normalise, (</>))-import           System.FilePath.Posix (dropFileName)-import           System.Posix.Files    (createSymbolicLink, removeLink)-import           Types-import           Utils--completeDeployments :: [Deployment] -> IO [Deployment]-completeDeployments ds = do-    home <- getHomeDirectory-    env <- getEnvironment-    case mapM (completeDeployment home env) ds of-        Left err -> die err-        Right fp -> return fp--type Environment = [(String, String)]-type HomeDir = FilePath--completeDeployment :: HomeDir -> Environment -> Deployment -> Either String Deployment-completeDeployment home env (Put srcs dst kind) = do-    csrcs <- mapM (complete home env) srcs-    cdst <- complete home env dst-    return $ Put csrcs cdst kind--complete :: HomeDir -> Environment -> FilePath -> Either String FilePath-complete home env fp = do-    let ids = parseId fp-    strs <- mapM (replaceId env) ids-    let completed = map (replaceHome home) strs-    return $ normalise $ concat completed--parseId :: FilePath -> [ID]-parseId [] = []-parseId ('$':'(':rest) = (Var id):(parseId next)-  where (id, (')':next)) = break (\c -> c == ')') rest-parseId (s:ss)-    = case parseId ss of-        (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-    case lookup str e of-        Nothing -> Left $ unwords ["variable", str, "could not be resolved from environment."]-        Just fp -> Right fp--replaceHome :: HomeDir -> FilePath -> FilePath-replaceHome home path-    = if "~" `isPrefixOf` path-        then home </> drop 2 path-        else path--performClean :: CleanupInstruction -> Sparker ()-performClean (CleanFile fp)         = incase conf_deploy_replace_files       $ rmFile fp-performClean (CleanDirectory fp)    = incase conf_deploy_replace_directories $ rmDir fp-performClean (CleanLink fp)         = incase conf_deploy_replace_links       $ unlink fp--unlink :: FilePath -> Sparker ()-unlink fp = liftIO $ removeLink fp--rmFile :: FilePath -> Sparker ()-rmFile fp = liftIO $ removeFile fp--rmDir :: FilePath -> Sparker ()-rmDir fp  = liftIO $ removeDirectoryRecursive fp---performDeployment :: Instruction -> IO ()-performDeployment (Instruction source destination LinkDeployment) = link source destination-performDeployment (Instruction source destination CopyDeployment) = copy source destination--copy :: FilePath -> FilePath -> IO ()-copy src dst = do-    createDirectoryIfMissing upperDir-    shelly $ cp_r (fromText $ pack src) (fromText $ pack dst)-  where upperDir = dropFileName dst--link :: FilePath -> FilePath -> IO ()-link src dst = do-    createDirectoryIfMissing upperDir-    createSymbolicLink src dst-  where upperDir = dropFileName dst-
− src/Deployer/Types.hs 
@@ -1,38 +0,0 @@-module Deployer.Types where--import           Language.Types-import           Monad-import           System.FilePath.Posix (takeExtension)-import           Types--data DeployerCardReference-    = DeployerCardCompiled FilePath-    | DeployerCardUncompiled CardFileReference-    deriving (Show, Eq)--instance Read DeployerCardReference where-    readsPrec _ fp-        = case length (words fp) of-            0 -> []-            1 -> if takeExtension fp == ".sus"-                  then [(DeployerCardUncompiled (CardFileReference fp Nothing) ,"")]-                  else [(DeployerCardCompiled fp, "")]-            2 -> let [f, c] = words fp-                  in [(DeployerCardUncompiled (CardFileReference f (Just $ CardNameReference c)), "")]-            _ -> []--type SparkDeployer = StateT DeployerState Sparker-data DeployerState = DeployerState--data PreDeployment-    = Ready FilePath FilePath DeploymentKind-    | AlreadyDone-    | Error String-    deriving (Show, Eq)--data ID-    = Plain String-    | Var String-    deriving (Show, Eq)--
− src/Dispatch.hs 
@@ -1,36 +0,0 @@-module Dispatch (dispatch) where--import           Check-import           Compiler-import           Compiler.Types-import           Control.Monad  (void)-import           Deployer-import           Deployer.Types-import           Dispatch.Types-import           Parser-import           Seed-import           Types--dispatch :: Dispatch -> Sparker ()-dispatch (DispatchParse fp) = do-    void $ parseFile fp  -- Just parse, throw away the results.--dispatch (DispatchCompile cfr) = do-    deployments <- compileJob cfr-    outputCompiled deployments--dispatch (DispatchCheck dcr) = do-    deps <- compileDeployerCardRef dcr-    seeded <- seedByCompiledCardRef dcr deps-    dcrs <- liftIO $ check seeded-    liftIO $ putStrLn $ formatDeploymentChecks $ zip seeded dcrs--dispatch (DispatchDeploy dcr) = do-    deps <- compileDeployerCardRef dcr-    seeded <- seedByCompiledCardRef dcr deps-    dcrs <- liftIO $ check seeded-    deploy $ zip seeded dcrs--compileDeployerCardRef :: DeployerCardReference -> Sparker [Deployment]-compileDeployerCardRef (DeployerCardCompiled fp) = inputCompiled fp-compileDeployerCardRef (DeployerCardUncompiled cfr) = compileJob cfr
− src/Dispatch/Types.hs 
@@ -1,19 +0,0 @@-module Dispatch.Types where--import           Types--import           Deployer.Types-import           Language.Types---type Instructions = (Dispatch, SparkConfig)--data Dispatch-    = DispatchParse FilePath-    | DispatchCompile CardFileReference-    | DispatchCheck DeployerCardReference-    | DispatchDeploy DeployerCardReference-    deriving (Show, Eq)--type Options = (Dispatch, GlobalOptions)-
+ src/Import.hs view
@@ -0,0 +1,26 @@+module Import+    ( module X+    ) where++import Prelude as X hiding (readFile, appendFile, writeFile, putStr, putStrLn)++import Control.Arrow as X+import Data.Maybe as X+import GHC.Generics as X+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++import Control.Monad as X+import Control.Monad.Except as X+import Control.Monad.IO.Class as X (MonadIO(..))+import Control.Monad.Identity as X+import Control.Monad.Reader as X+import Control.Monad.State as X+import Control.Monad.Writer as X++import Data.Validity as X+import Data.Validity.Path as X ()
− src/Language/Types.hs 
@@ -1,61 +0,0 @@-module Language.Types where--import           CoreTypes---- * Cards--type CardName = String-type Source = FilePath-type Destination = FilePath--data Card = Card-    { cardName    :: CardName-    , cardContent :: Declaration-    } deriving (Show, Eq)---- ** Declarations---- | A declaration in a card-data Declaration-    = SparkOff CardReference -- ^ Spark off another card-    | Deploy Source Destination (Maybe DeploymentKind) -- ^ Deploy from source to destination-    | IntoDir Directory -- ^ Deploy into a directory-    | OutofDir Directory -- ^ Deploy outof a directory-    | DeployKindOverride DeploymentKind -- ^ Override the deployment kind-    | Alternatives [Directory] -- ^ Provide a list of alternative sources-    | Block [Declaration] -- ^ A scoped block of declarations-    deriving (Show, Eq)---- * Card references---- | Reference a card by name (inside a file)-data CardNameReference = CardNameReference CardName-    deriving (Show, Eq)---- | Reference a card by the file it is in and therein potentially by a name reference-data CardFileReference = CardFileReference FilePath (Maybe CardNameReference)-    deriving (Show, Eq)---instance Read CardFileReference where-    readsPrec _ fp-        = case length (words fp) of-            1 -> [(CardFileReference fp Nothing ,"")]-            2 -> let [f, c] = words fp-                  in [(CardFileReference f (Just $ CardNameReference c), "")]-            _ -> []----- | Union card reference-data CardReference-    = CardFile CardFileReference-    | CardName CardNameReference-    deriving (Show, Eq)----- * Card files-data SparkFile = SparkFile-    { sparkFilePath  :: FilePath-    , sparkFileCards :: [Card]-    } deriving (Show, Eq)-
− src/Monad.hs 
@@ -1,25 +0,0 @@-module Monad where--import           Control.Monad.Except (ExceptT, runExceptT)-import           Control.Monad.Reader (ReaderT, runReaderT)-import           Text.Parsec          (ParseError)--import           Config.Types---- | The base monad-type Sparker = ExceptT SparkError (ReaderT SparkConfig IO)--runSparker :: SparkConfig -> Sparker a -> IO (Either SparkError a)-runSparker conf func = runReaderT (runExceptT func) conf--data SparkError = ParseError ParseError-                | PreCompileError [PreCompileError]-                | CompileError CompileError-                | DeployError DeployError-                | UnpredictedError String-    deriving (Show, Eq)--type CompileError = String-type PreCompileError = String-type DeployError = String-
− src/Parser.hs 
@@ -1,20 +0,0 @@-module Parser where--import           Control.Exception (try)-import           Language.Types-import           Parser.Internal-import           Types---parseFile :: FilePath -> Sparker SparkFile-parseFile file = do-    esf <- liftIO $ try $ parseFileIO file-    case esf of-        Left ioe -> throwError $ UnpredictedError $ show (ioe :: IOError)-        Right sf -> do-            case sf of-                Left pe -> throwError $ ParseError pe-                Right cs -> return cs--parseFileIO :: FilePath -> IO (Either ParseError SparkFile)-parseFileIO file = (liftIO $ readFile file) >>= return . parseCardFile file
− src/Parser/Internal.hs 
@@ -1,282 +0,0 @@-module Parser.Internal where--import           Constants-import           Data.List          (isSuffixOf)-import           Deployer.Types-import           Language.Types-import           Text.Parsec-import           Text.Parsec.String-import           Types---parseCardFile :: FilePath -> String -> Either ParseError SparkFile-parseCardFile f s = do-    cs <- parseFromSource sparkFile f s-    return $ SparkFile f cs--parseFromSource :: Parser a -> FilePath -> String -> Either ParseError a-parseFromSource = parse-----[ Language ]----sparkFile :: Parser [Card]-sparkFile = do-    clean <- eatComments-    setInput clean-    resetPosition-    cards--cards :: Parser [Card]-cards = card `sepEndBy1` whitespace--resetPosition :: Parser ()-resetPosition = do-    pos <- getPosition-    setPosition $ setSourceColumn (setSourceLine pos 1) 1--card :: Parser Card-card = do-    whitespace-    skip $ string keywordCard-    whitespace-    name <- cardNameP-    whitespace-    b <- block-    whitespace-    return $ Card name b--declarations :: Parser [Declaration]-declarations = (inLineSpace declaration) `sepEndBy` delim--declaration :: Parser Declaration-declaration = choice $ map try-    [ block-    , alternatives-    , sparkOff-    , intoDir-    , outOfDir-    , deploymentKindOverride-    , deployment-    ]--block :: Parser Declaration-block = do-    ds <- inBraces $ inWhiteSpace declarations-    return $ Block ds-    <?> "block"--sparkOff :: Parser Declaration-sparkOff = do-    skip $ string keywordSpark-    linespace-    ref <- cardReference-    return $ SparkOff ref-    <?> "sparkoff"--compilerCardReference :: Parser CardFileReference-compilerCardReference = unprefixedCardFileReference--deployerCardReference :: Parser DeployerCardReference-deployerCardReference = goComp <|> goUncomp-  where-    goComp = compiledCardReference >>= return . DeployerCardCompiled-    goUncomp = unprefixedCardFileReference >>= return . DeployerCardUncompiled--compiledCardReference :: Parser FilePath-compiledCardReference = do-    skip $ string "compiled"-    skip linespace-    filepath--cardReference :: Parser CardReference-cardReference = try goName <|> try goFile <?> "card reference"-  where-    goName = cardNameReference >>= return . CardName-    goFile = cardFileReference >>= return . CardFile--cardNameReference :: Parser CardNameReference-cardNameReference = do-    skip $ string keywordCard-    linespace-    name <- cardNameP-    return $ CardNameReference name-    <?> "card name reference"--cardNameP :: Parser CardName-cardNameP = identifier <?> "card name"--cardFileReference :: Parser CardFileReference-cardFileReference = do-    skip $ string keywordFile-    skip linespace-    unprefixedCardFileReference--unprefixedCardFileReference :: Parser CardFileReference-unprefixedCardFileReference = do-    fp <- filepath-    linespace-    mn <- optionMaybe $ try cardNameP-    return $ case mn of-        Nothing -> CardFileReference fp Nothing-        Just cn  -> CardFileReference fp (Just $ CardNameReference cn)-    <?> "card file reference"--intoDir :: Parser Declaration-intoDir = do-    skip $ string keywordInto-    linespace-    dir <- directory-    return $ IntoDir dir-    <?> "into directory declaration"--outOfDir :: Parser Declaration-outOfDir = do-    skip $ string keywordOutof-    linespace-    dir <- directory-    return $ OutofDir dir-    <?> "outof directory declaration"--deploymentKindOverride :: Parser Declaration-deploymentKindOverride = do-    skip $ string keywordKindOverride-    linespace-    kind <- try copy <|> link-    return $ DeployKindOverride kind-    <?> "deployment kind override"-  where-    copy = string keywordCopy >> return CopyDeployment-    link = string keywordLink >> return LinkDeployment--shortDeployment :: Parser Declaration-shortDeployment = do-    source <- try directory <|> filepath-    return $ Deploy source source Nothing--longDeployment :: Parser Declaration-longDeployment = do-    source <- filepath-    linespace-    kind <- deploymentKind-    linespace-    dest <- filepath-    return $ Deploy source dest kind--deployment :: Parser Declaration-deployment = try longDeployment <|> shortDeployment-    <?> "deployment"--deploymentKind :: Parser (Maybe DeploymentKind)-deploymentKind = try link <|> try copy <|> def-    <?> "deployment kind"-    where-        link = string linkKindSymbol >> return (Just LinkDeployment)-        copy = string copyKindSymbol >> return (Just CopyDeployment)-        def  = string unspecifiedKindSymbol >> return Nothing--alternatives :: Parser Declaration-alternatives = do-    skip $ string keywordAlternatives-    linespace-    ds <- directory `sepBy1` linespace-    return $ Alternatives ds---- [ FilePaths ]----filepath :: Parser FilePath-filepath = do-    i <- identifier <?> "Filepath"-    if "/" `isSuffixOf` i-    then unexpected "slash at the end"-    else return i--directory :: Parser Directory-directory = filepath <?> "Directory"-----[ Comments ]----comment :: Parser String-comment = try lineComment <|> try blockComment <?> "Comment"--lineComment :: Parser String-lineComment = (<?> "Line comment") $ do-    skip $ try $ string lineCommentStr-    anyChar `manyTill` eol--blockComment :: Parser String-blockComment = (<?> "Block comment") $ do-    skip $ try $ string start-    anyChar `manyTill` (try $ string stop)-  where (start, stop) = blockCommentStrs----notComment :: Parser String-notComment = manyTill anyChar (lookAhead ((skip comment) <|> eof))--eatComments :: Parser String-eatComments = do-    optional comment-    xs <- notComment `sepBy` comment-    optional comment-    let withoutComments = concat xs-    return withoutComments-----[ Identifiers ]---identifier :: Parser String-identifier = try quotedIdentifier <|> plainIdentifier--plainIdentifier :: Parser String-plainIdentifier = many1 $ noneOf $ quotesChar : lineDelimiter ++ whitespaceChars ++ bracesChars--quotedIdentifier :: Parser String-quotedIdentifier = inQuotes $ many $ noneOf $ quotesChar:endOfLineChars-----[ Delimiters ]----inBraces :: Parser a -> Parser a-inBraces = between (char '{') (char '}')--inQuotes :: Parser a -> Parser a-inQuotes = between (char quotesChar) (char quotesChar)--delim :: Parser ()-delim = try (skip $ string lineDelimiter) <|> go-  where-    go = do-        eol-        whitespace-----[ Whitespace ]----inLineSpace :: Parser a -> Parser a-inLineSpace = between linespace linespace--inWhiteSpace :: Parser a -> Parser a-inWhiteSpace = between whitespace whitespace--linespace :: Parser ()-linespace = skip $ many $ oneOf linespaceChars--whitespace :: Parser ()-whitespace = skip $ many $ oneOf whitespaceChars--eol :: Parser ()-eol =  skip newline-  where-    newline-        =   try (string "\r\n")-        <|> try (string "\n")-        <|> string "\r"-        <?> "end of line"-----[ Utils ]----skip :: Parser a -> Parser ()-skip p = p >> return ()
− src/PreCompiler.hs 
@@ -1,57 +0,0 @@-module PreCompiler where--import           Compiler.Types-import           Language.Types-import           Types-import           Utils--preCompileChecks :: Card -> [PreCompileError]-preCompileChecks c = runIdentity $ execWriterT $ cleanCard c--dirty :: String -> Precompiler ()-dirty s = tell ["Precompilation check failed: " ++ s]--cleanCard :: Card -> Precompiler ()-cleanCard (Card name d) = do-    cleanCardName name-    cleanDeclaration d--cleanDeclaration :: Declaration -> Precompiler ()-cleanDeclaration (Deploy src dst _) = do-    cleanFilePath src-    cleanFilePath dst--cleanDeclaration (SparkOff cr) = cleanCardReference cr-cleanDeclaration (IntoDir dir) = cleanFilePath dir-cleanDeclaration (OutofDir dir) = cleanFilePath dir-cleanDeclaration (DeployKindOverride _) = return () -- Nothing can go wrong.-cleanDeclaration (Alternatives fs) = mapM_ cleanFilePath fs-cleanDeclaration (Block ds) = mapM_ cleanDeclaration ds--cleanCardReference :: CardReference -> Precompiler ()-cleanCardReference (CardFile cfr) = cleanCardFileReference cfr-cleanCardReference (CardName cnr) = cleanCardNameReference cnr--cleanCardFileReference :: CardFileReference -> Precompiler ()-cleanCardFileReference (CardFileReference fp mcnr) = do-    cleanFilePath fp-    case mcnr of-        Nothing -> return ()-        Just cnr -> cleanCardNameReference cnr--cleanCardNameReference :: CardNameReference -> Precompiler ()-cleanCardNameReference (CardNameReference cn) = cleanCardName cn--cleanCardName :: CardName -> Precompiler ()-cleanCardName n-    | containsNewline n = dirty $ "Card name contains newline character(s): " ++ n-    | otherwise = return ()--cleanFilePath :: FilePath -> Precompiler ()-cleanFilePath [] = dirty "Empty filepath"-cleanFilePath fp-    | containsNewline fp =-        dirty $ "Filepath contains newline character(s): " ++ fp-    | containsMultipleConsequtiveSlashes fp =-        dirty $ "Filepath contains multiple consequtive slashes: " ++ fp-    | otherwise = return ()
− src/Seed.hs 
@@ -1,25 +0,0 @@-module Seed where--import           Compiler.Types-import           Deployer.Types-import           Language.Types-import           Monad-import           System.Directory (getCurrentDirectory)-import           System.FilePath  (takeDirectory, (</>))-import           Types--seedByCompiledCardRef :: DeployerCardReference -> [Deployment] -> Sparker [Deployment]-seedByCompiledCardRef (DeployerCardCompiled fp) = seedByRel fp-seedByCompiledCardRef (DeployerCardUncompiled (CardFileReference fp _)) = seedByRel fp--seedByRel :: FilePath -> [Deployment] -> Sparker [Deployment]-seedByRel file ds = do-    cur <- liftIO $ getCurrentDirectory-    let reldir = takeDirectory file-    return $ seed (cur </> reldir) ds--seed :: FilePath -> [Deployment] -> [Deployment]-seed fp = map (\d -> d { deployment_srcs = map seedsrc $ deployment_srcs d })-  where-    seedsrc :: FilePath -> FilePath-    seedsrc = (fp </>)
− src/Spark.hs 
@@ -1,22 +0,0 @@-module Spark (spark) where--import           Arguments-import           Dispatch-import           Types-import           Utils--spark :: IO ()-spark = do-    (di, config) <- getInstructions--    er <- runSparker config $ dispatch di-    case er of-        Left err -> die $ showError err-        Right _ -> return ()--showError :: SparkError -> String-showError (ParseError err) = show err-showError (PreCompileError errs) = unlines errs-showError (CompileError err) = err-showError (UnpredictedError err) = "Panic: " ++ err-showError (DeployError err) = err
+ src/SuperUserSpark.hs view
@@ -0,0 +1,24 @@+module SuperUserSpark+    ( spark+    ) where++import Import++import SuperUserSpark.Bake+import SuperUserSpark.Check+import SuperUserSpark.Compiler+import SuperUserSpark.Deployer+import SuperUserSpark.Diagnose+import SuperUserSpark.OptParse+import SuperUserSpark.Parser++spark :: IO ()+spark = getDispatch >>= dispatch++dispatch :: Dispatch -> IO ()+dispatch (DispatchParse pas) = parseFromArgs pas+dispatch (DispatchCompile cas) = compileFromArgs cas+dispatch (DispatchBake bas) = bakeFromArgs bas+dispatch (DispatchDiagnose bas) = diagnoseFromArgs bas+dispatch (DispatchCheck cas) = checkFromArgs cas+dispatch (DispatchDeploy das) = deployFromArgs das
+ src/SuperUserSpark/Bake.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE RecordWildCards #-}++{-+    The responsibility of the baker is to turn raw deployments into baked+    deployments. This takes care of everything that couldn't happen during+    compilation yet. The differences between raw deployments and baked+    deployments are:+    - Baked deployments only deal with absolute filepaths so as to be+      working-directory-independent.+    - Baked deployments are aware of the kind of things the checker/deployer+      will be operating on (files versus directories).++    The baker is not responsible for checking any existences.+-}+module SuperUserSpark.Bake where++import Import++import qualified Data.Aeson.Encode.Pretty as JSON+import System.Environment (getEnvironment)+import System.FilePath (takeExtension)++import SuperUserSpark.Bake.Internal+import SuperUserSpark.Bake.Types+import SuperUserSpark.Compiler+import SuperUserSpark.Compiler.Types+import SuperUserSpark.Language.Types+import SuperUserSpark.OptParse.Types+import SuperUserSpark.Utils++bakeFromArgs :: BakeArgs -> IO ()+bakeFromArgs ba = do+    errOrAss <- bakeAssignment ba+    case errOrAss of+        Left be -> die $ unwords ["Failed to build bake assignment:", be]+        Right ass -> bake ass++bakeAssignment :: BakeArgs -> IO (Either String BakeAssignment)+bakeAssignment BakeArgs {..} = do+    errOrCardRef <- parseBakeCardReference bakeCardRef+    case errOrCardRef of+        Left err -> pure $ Left err+        Right cardRef ->+            BakeAssignment cardRef <$$> deriveBakeSettings cardRef bakeFlags++parseBakeCardReference :: String -> IO (Either String BakeCardReference)+parseBakeCardReference s =+    case words s of+        [fp] ->+            if takeExtension fp == ".sus"+                then BakeCardUncompiled <$$> parseStrongCardFileReference fp+                else BakeCardCompiled <$$> resolveFile'Either fp+        [f, c] ->+            BakeCardUncompiled <$$>+            ((\(StrongCardFileReference p _) ->+                  StrongCardFileReference p (Just $ CardNameReference c)) <$$>+             parseStrongCardFileReference f)+        _ -> pure $ Left $ unwords ["Could not parse card reference from:", s]++deriveBakeSettings :: BakeCardReference+                   -> BakeFlags+                   -> IO (Either String BakeSettings)+deriveBakeSettings bcr BakeFlags {..} =+    BakeSettings (rootOf bcr) <$$> (Right <$> getEnvironment) <**>+    deriveCompileSettings bakeCompileFlags++rootOf :: BakeCardReference -> Path Abs Dir+rootOf bcr =+    parent $+    case bcr of+        (BakeCardCompiled fp) -> fp+        (BakeCardUncompiled (StrongCardFileReference fp _)) -> fp++bake :: BakeAssignment -> IO ()+bake BakeAssignment {..} = do+    errOrDone <-+        runReaderT (runExceptT $ bakeByCardRef bakeCardReference) bakeSettings+    case errOrDone of+        Left err -> die $ formatBakeError err+        Right () -> pure ()++formatBakeError :: BakeError -> String+formatBakeError (BakeCompileError ce) = formatCompileError ce+formatBakeError (BakeError s) = unwords ["Bake failed:", s]++bakeByCardRef :: BakeCardReference -> SparkBaker ()+bakeByCardRef bakeCardReference = do+    deps <- compileBakeCardRef bakeCardReference+    bdeps <- bakeDeployments deps+    putStrLn $ JSON.encodePretty bdeps++compileBakeCardRef :: BakeCardReference -> SparkBaker [RawDeployment]+compileBakeCardRef (BakeCardCompiled fp) = bakerCompile $ inputCompiled fp+compileBakeCardRef (BakeCardUncompiled bcf) = bakerCompile $ compileJob bcf++bakerCompile :: ImpureCompiler a -> SparkBaker a+bakerCompile =+    withExceptT BakeCompileError . mapExceptT (withReaderT bakeCompileSettings)
+ src/SuperUserSpark/Bake/Internal.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE RecordWildCards #-}++module SuperUserSpark.Bake.Internal where++import Import++import Control.Exception (try)+import System.FilePath+       (isAbsolute, replaceDirectory, takeDirectory)++import SuperUserSpark.Bake.Types+import SuperUserSpark.Compiler.Types++bakeDeployments :: [RawDeployment] -> SparkBaker [BakedDeployment]+bakeDeployments = mapM bakeDeployment++bakeDeployment :: RawDeployment -> SparkBaker BakedDeployment+bakeDeployment Deployment {..} = do+    d <- bakeDirections deploymentDirections+    pure $+        Deployment {deploymentDirections = d, deploymentKind = deploymentKind}++bakeDirections :: DeploymentDirections FilePath+               -> SparkBaker (DeploymentDirections AbsP)+bakeDirections (Directions srcs dst) =+    Directions <$> mapM bakeFilePath srcs <*> bakeFilePath dst++-- | Bake asingle 'FilePath'+--+-- The result should:+--+-- * ... not contain any more variables.+-- * ... not contain any reference to the home directory: @~@.+-- * ... be absolute.+bakeFilePath :: FilePath -> SparkBaker AbsP+bakeFilePath fp = do+    env <- asks bakeEnvironment+    root <- asks bakeRoot+    case complete env fp of+        Left err -> throwError $ BakeError $ err+        Right cp -> do+            if isAbsolute cp+                then case parseAbsFile cp of+                         Left err -> throwError $ BakeError $ show err+                         Right af -> pure $ AbsP af+                else do+                    let dir = takeDirectory cp+                    errOrAp <-+                        liftIO $+                        try $ do+                            d <- resolveFile root dir+                            parseAbsFile $ replaceDirectory cp $ toFilePath d+                    case errOrAp of+                        Left err ->+                            throwError $+                            BakeError $ show (err :: PathParseException)+                        Right absp -> pure $ AbsP absp++type Environment = [(String, String)]++complete :: Environment -> FilePath -> Either String FilePath+complete env fp = do+    let ids = parseId fp+    strs <- mapM (replaceId env) ids+    return $ concat strs++parseId :: FilePath -> [ID]+parseId fp =+    case fp of+        ('~':rest) -> Var "HOME" : go rest+        _ -> go fp+  where+    go :: FilePath -> [ID]+    go [] = []+    go ('$':'(':rest) = (Var id_) : (go next)+      where+        (id_, (')':next)) = break (\c -> c == ')') rest+    go (s:ss) =+        case go ss of+            (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+    case lookup str e of+        Nothing ->+            Left $+            unwords ["variable", str, "could not be resolved from environment."]+        Just fp -> Right fp
+ src/SuperUserSpark/Bake/Types.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveGeneric #-}++module SuperUserSpark.Bake.Types where++import Import++import Data.Aeson++import SuperUserSpark.Compiler.Types++data BakeAssignment = BakeAssignment+    { bakeCardReference :: BakeCardReference+    , bakeSettings :: BakeSettings+    } deriving (Show, Eq, Generic)++instance Validity BakeAssignment++data BakeCardReference+    = BakeCardCompiled (Path Abs File)+    | BakeCardUncompiled StrongCardFileReference+    deriving (Show, Eq, Generic)++instance Validity BakeCardReference++data BakeSettings = BakeSettings+    { bakeRoot :: Path Abs Dir+    , bakeEnvironment :: [(String, String)]+    , bakeCompileSettings :: CompileSettings+    } deriving (Show, Eq, Generic)++instance Validity BakeSettings++defaultBakeSettings :: BakeSettings+defaultBakeSettings =+    BakeSettings+    { bakeRoot = $(mkAbsDir "/")+    , bakeEnvironment = []+    , bakeCompileSettings = defaultCompileSettings+    }++type SparkBaker = ExceptT BakeError (ReaderT BakeSettings IO)++data BakeError+    = BakeCompileError CompileError+    | BakeError String+    deriving (Show, Eq, Generic)++instance Validity BakeError++type BakedDeployment = Deployment AbsP++-- | An absolute path.+--+-- This is kept as a 'Path Abs File' to avoid existential quantification, but+-- that is an implementation detail and should not be exposed as functionality.+newtype AbsP = AbsP+    { unAbsP :: Path Abs File+    } deriving (Show, Eq, Generic)++instance Validity AbsP++instance ToJSON AbsP where+    toJSON (AbsP p) = toJSON p++instance FromJSON AbsP where+    parseJSON v = AbsP <$> parseJSON v++toPath :: AbsP -> FilePath+toPath = toFilePath . unAbsP++data ID+    = Plain String+    | Var String+    deriving (Show, Eq, Generic)++instance Validity ID
+ src/SuperUserSpark/Check.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE RecordWildCards #-}++module SuperUserSpark.Check+    ( checkFromArgs+    , checkAssignment+    , deriveCheckSettings+    , check+    , formatCheckError+    , formatDeploymentChecks+    , checkDeployments+    ) where++import Import++import SuperUserSpark.Bake+import SuperUserSpark.Bake.Internal+import SuperUserSpark.Bake.Types+import SuperUserSpark.Check.Internal+import SuperUserSpark.Check.Types+import SuperUserSpark.Diagnose+import SuperUserSpark.Diagnose.Types+import SuperUserSpark.OptParse.Types+import SuperUserSpark.Utils++checkFromArgs :: CheckArgs -> IO ()+checkFromArgs cas = do+    errOrAss <- checkAssignment cas+    case errOrAss of+        Left err -> die $ unwords ["Failed to build Check assignment:", err]+        Right ass -> check ass++checkAssignment :: CheckArgs -> IO (Either String CheckAssignment)+checkAssignment CheckArgs {..} = do+    errOrCardRef <- parseBakeCardReference checkArgCardRef+    case errOrCardRef of+        Left err -> pure $ Left err+        Right cardRef ->+            CheckAssignment cardRef <$$> deriveCheckSettings cardRef checkFlags++deriveCheckSettings :: BakeCardReference+                    -> CheckFlags+                    -> IO (Either String CheckSettings)+deriveCheckSettings bcr CheckFlags {..} =+    CheckSettings <$$> deriveDiagnoseSettings bcr checkDiagnoseFlags++check :: CheckAssignment -> IO ()+check CheckAssignment {..} = do+    errOrDone <-+        runReaderT+            (runExceptT $ checkByCardRef checkCardReference)+            checkSettings+    case errOrDone of+        Left err -> die $ formatCheckError err+        Right () -> pure ()++formatCheckError :: CheckError -> String+formatCheckError (CheckDiagnoseError ce) = formatDiagnoseError ce+formatCheckError (CheckError s) = unwords ["Check failed:", s]++checkByCardRef :: BakeCardReference -> SparkChecker ()+checkByCardRef checkCardReference = do+    ddeps <-+        checkerDiagnose $+        diagnoserBake+            (compileBakeCardRef checkCardReference >>= bakeDeployments) >>=+        (liftIO . diagnoseDeployments)+    liftIO $ putStrLn $ formatDeploymentChecks $ zip ddeps $ checkDeployments ddeps++checkerDiagnose :: SparkDiagnoser a -> SparkChecker a+checkerDiagnose =+    withExceptT CheckDiagnoseError .+    mapExceptT (withReaderT checkDiagnoseSettings)++checkDeployments :: [DiagnosedDeployment] -> [DeploymentCheckResult]+checkDeployments = map checkDeployment
+ src/SuperUserSpark/Check/Internal.hs view
@@ -0,0 +1,277 @@+module SuperUserSpark.Check.Internal where++import Import++import Data.Maybe (catMaybes)++import SuperUserSpark.Bake.Types+import SuperUserSpark.Check.Types+import SuperUserSpark.Compiler.Types+import SuperUserSpark.Constants+import SuperUserSpark.CoreTypes+import SuperUserSpark.Diagnose.Types++checkDeployment :: DiagnosedDeployment -> DeploymentCheckResult+checkDeployment (Deployment (Directions [] (D dst _ _)) _) =+    ImpossibleDeployment+        [unwords ["No source for deployment with destination", toPath dst]]+checkDeployment (Deployment (Directions srcs dst) kind) =+    bestResult $ map (\src -> checkSingle src dst kind) srcs++bestResult :: [CheckResult] -> DeploymentCheckResult+bestResult cs+    | all impossible cs = ImpossibleDeployment $ map (\(Impossible s) -> s) cs+    | otherwise+        -- Will not be empty as per line above+     =+        case head $ dropWhile impossible cs of+            AlreadyDone -> DeploymentDone+            Ready i -> ReadyToDeploy i+            Dirty s i c -> DirtySituation s i c+            Impossible _ -> error "Cannot be the case"++impossible :: CheckResult -> Bool+impossible (Impossible _) = True+impossible _ = False++impossibleDeployment :: DeploymentCheckResult -> Bool+impossibleDeployment (ImpossibleDeployment _) = True+impossibleDeployment _ = False++dirtyDeployment :: DeploymentCheckResult -> Bool+dirtyDeployment (DirtySituation _ _ _) = True+dirtyDeployment _ = False++deploymentReadyToDeploy :: DeploymentCheckResult -> Bool+deploymentReadyToDeploy (ReadyToDeploy _) = True+deploymentReadyToDeploy _ = False++deploymentIsDone :: DeploymentCheckResult -> Bool+deploymentIsDone DeploymentDone = True+deploymentIsDone _ = False++-- | Check a single (@source@, @destination@, @kind@) triple.+checkSingle :: DiagnosedFp -> DiagnosedFp -> DeploymentKind -> CheckResult+checkSingle (D src srcd srch) (D dst dstd dsth) kind =+    let parseBoth cons p =+            case (p $ toPath src, p $ toPath dst) of+                (Left err1, Left err2) ->+                    Impossible $ unwords [show err1, show err2]+                (Left err, _) -> Impossible $ show err+                (_, Left err) -> Impossible $ show err+                (Right s, Right d) -> Ready $ cons s d+        readyCopyFile = parseBoth CopyFile parseAbsFile+        readyCopyDir = parseBoth CopyDir parseAbsDir+        readyLinkFile = parseBoth LinkFile parseAbsFile+        readyLinkDir = parseBoth LinkDir parseAbsDir+    in case (srcd, dstd, kind) of+           (IsFile, Nonexistent, CopyDeployment) -> readyCopyFile+           (IsFile, Nonexistent, LinkDeployment) -> readyLinkFile+           (IsFile, IsFile, LinkDeployment) ->+               e+                   readyLinkFile+                   [ "Both the source:"+                   , toPath src+                   , "and the destination:"+                   , toPath dst+                   , "are files for a link deployment."+                   ]+           (IsFile, IsFile, CopyDeployment) ->+               if srch == dsth+                   then AlreadyDone+                   else e+                            readyCopyFile+                            [ "Both the source:"+                            , toPath src+                            , "and the destination:"+                            , toPath dst+                            , "are files for a copy deployment, but they are not equal."+                            ]+           (IsFile, IsDirectory, LinkDeployment) ->+               e+                   readyLinkFile+                   [ "The source: "+                   , toPath src+                   , "is a file but the destination:"+                   , toPath dst+                   , "is a directory for a link deployment."+                   ]+           (IsFile, IsDirectory, CopyDeployment) ->+               e+                   readyCopyFile+                   [ "The source: "+                   , toPath src+                   , "is a file but the destination:"+                   , toPath dst+                   , "is a directory for a copy deployment."+                   ]+           (IsFile, IsLinkTo l, LinkDeployment) ->+               if l == src+                   then AlreadyDone+                   else e+                            readyLinkFile+                            [ "The source:"+                            , toPath src+                            , "is a file and the destination:"+                            , toPath dst+                            , "is a link for a link deployment but the destination does not point to the source. Instead it points to:"+                            , toPath l ++ "."+                            ]+           (IsFile, IsLinkTo _, CopyDeployment) ->+               e+                   readyCopyFile+                   [ "The source:"+                   , toPath src+                   , "is a file and the destination:"+                   , toPath dst+                   , "is a link for a copy deployment."+                   ]+           (IsDirectory, Nonexistent, LinkDeployment) -> readyLinkDir+           (IsDirectory, Nonexistent, CopyDeployment) -> readyCopyDir+           (IsDirectory, IsFile, LinkDeployment) ->+               e+                   readyLinkDir+                   [ "The source:"+                   , toPath src+                   , "is a directory and the destination:"+                   , toPath dst+                   , "is a file for a link deployment"+                   ]+           (IsDirectory, IsFile, CopyDeployment) ->+               e+                   readyCopyDir+                   [ "The source:"+                   , toPath src+                   , "is a directory and the destination:"+                   , toPath dst+                   , "is a file for a copy deployment"+                   ]+           (IsDirectory, IsDirectory, LinkDeployment) ->+               e+                   readyLinkDir+                   [ "The source:"+                   , toPath src+                   , "and the destination:"+                   , toPath dst+                   , "are directories for a link deployment."+                   ]+           (IsDirectory, IsDirectory, CopyDeployment) ->+               if srch == dsth+                   then AlreadyDone+                   else e+                            readyCopyDir+                            [ "The source:"+                            , toPath src+                            , "and destination:"+                            , toPath dst+                            , "are directories for a copy deployment, but they are not equal."+                            ]+           (IsDirectory, IsLinkTo l, LinkDeployment) ->+               if l == src+                   then AlreadyDone+                   else e+                            readyLinkDir+                            [ "The source:"+                            , toPath src+                            , "is a directory and the destination:"+                            , toPath dst+                            , "is a link for a link deployment but the destination does not point to the source. Instead it points to:"+                            , toPath l ++ "."+                            ]+           (IsDirectory, IsLinkTo _, CopyDeployment) ->+               e+                   readyCopyDir+                   [ "The source:"+                   , toPath src+                   , "is a directory and the destination:"+                   , toPath dst+                   , "is a link for a copy deployment."+                   ]+           (Nonexistent, _, _) ->+               i ["The source:", toPath src, "does not exist."]+           (IsLinkTo _, _, _) -> i ["The source:", toPath src, "is a link."]+           (IsWeird, IsWeird, _) ->+               i+                   [ "Both the source:"+                   , toPath src+                   , "and the destination:"+                   , toPath dst+                   , "are weird."+                   ]+           (IsWeird, _, _) -> i ["The source:", toPath src, "is weird."]+           (_, IsWeird, _) -> i ["The destination:", toPath dst, "is weird."]+  where+    i = Impossible . unlines+    e mins s =+        case mins of+            (Impossible _) -> mins+            (Ready ins) ->+                case dstd of+                    IsFile -> Dirty (unlines s) ins $ CleanFile $ unAbsP dst+                    IsLinkTo _ -> Dirty (unlines s) ins $ CleanLink $ unAbsP dst+                    IsDirectory ->+                        case parseAbsDir $ toPath dst of+                            Left err -> Impossible $ show err -- Should not happen, but just in case.+                            Right dir ->+                                Dirty (unlines s) ins $ CleanDirectory dir+                    _ -> Impossible "should not occur"+            _ -> Impossible "should not occur."++formatDeploymentChecks :: [(DiagnosedDeployment, DeploymentCheckResult)]+                       -> String+formatDeploymentChecks dss =+    if null output+        then "Deployment is done already."+        else unlines output +++             if all (impossibleDeployment . snd) dss+                 then "Deployment is impossible."+                 else "Deployment is possible."+  where+    output = catMaybes $ map formatDeploymentCheck dss++formatDeploymentCheck :: (DiagnosedDeployment, DeploymentCheckResult)+                      -> Maybe String+formatDeploymentCheck (_, (ReadyToDeploy is)) =+    Just $ "READY: " ++ formatInstruction is+formatDeploymentCheck (_, DeploymentDone) = Nothing+formatDeploymentCheck (d, ImpossibleDeployment ds) =+    Just $+    concat+        [ "IMPOSSIBLE: "+        , toPath $+          diagnosedFilePath $ directionDestination $ deploymentDirections d+        , " cannot be deployed:\n"+        , unlines ds+        , "\n"+        ]+formatDeploymentCheck (d, (DirtySituation str is c)) =+    Just $+    concat+        [ "DIRTY: "+        , toPath $+          diagnosedFilePath $ directionDestination $ deploymentDirections d+        , "\n"+        , str+        , "planned: "+        , formatInstruction is+        , "\n"+        , "cleanup needed:\n"+        , formatCleanupInstruction c+        , "\n"+        ]++formatInstruction :: Instruction -> String+formatInstruction (CopyFile from to) =+    unwords $ [toFilePath from, "c->", toFilePath to]+formatInstruction (CopyDir from to) =+    unwords $ [toFilePath from, "c->", toFilePath to]+formatInstruction (LinkFile from to) =+    unwords $ [toFilePath from, "l->", toFilePath to]+formatInstruction (LinkDir from to) =+    unwords $ [toFilePath from, "l->", toFilePath to]++formatCleanupInstruction :: CleanupInstruction -> String+formatCleanupInstruction (CleanFile fp) = "remove file " ++ toFilePath fp+formatCleanupInstruction (CleanDirectory dir) =+    "remove directory " ++ toFilePath dir+formatCleanupInstruction (CleanLink link) = "remove link " ++ toFilePath link
+ src/SuperUserSpark/Check/Types.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE RecordWildCards #-}++module SuperUserSpark.Check.Types where++import Import++import SuperUserSpark.Bake.Types+import SuperUserSpark.Diagnose.Types++data CheckAssignment = CheckAssignment+    { checkCardReference :: BakeCardReference+    , checkSettings :: CheckSettings+    } deriving (Show, Eq, Generic)++instance Validity CheckAssignment++data CheckSettings = CheckSettings+    { checkDiagnoseSettings :: DiagnoseSettings+    } deriving (Show, Eq, Generic)++instance Validity CheckSettings++defaultCheckSettings :: CheckSettings+defaultCheckSettings =+    CheckSettings {checkDiagnoseSettings = defaultDiagnoseSettings}++type SparkChecker = ExceptT CheckError (ReaderT CheckSettings IO)++data CheckError+    = CheckDiagnoseError DiagnoseError+    | CheckError String+    deriving (Show, Eq, Generic)++instance Validity CheckError++data Instruction+    = CopyFile (Path Abs File)+               (Path Abs File)+    | CopyDir (Path Abs Dir)+              (Path Abs Dir)+    | LinkFile (Path Abs File)+               (Path Abs File)+    | LinkDir (Path Abs Dir)+              (Path Abs Dir)+    deriving (Show, Eq, Generic)++instance Validity Instruction++data CleanupInstruction+    = CleanFile (Path Abs File)+    | CleanDirectory (Path Abs Dir)+    | CleanLink (Path Abs File)+    deriving (Show, Eq, Generic)++instance Validity CleanupInstruction++data DeploymentCheckResult+    = DeploymentDone -- ^ Done already+    | ReadyToDeploy Instruction -- ^ Immediately possible+    | DirtySituation String+                     Instruction+                     CleanupInstruction -- ^ Possible after cleanup of destination+    | ImpossibleDeployment [String] -- ^ Entirely impossible+    deriving (Show, Eq, Generic)++instance Validity DeploymentCheckResult++data CheckResult+    = AlreadyDone -- ^ Done already+    | Ready Instruction -- ^ Immediately possible+    | Dirty String+            Instruction+            CleanupInstruction -- ^ Possible after cleanup+    | Impossible String -- ^ Entirely impossible+    deriving (Show, Eq, Generic)++instance Validity CheckResult
+ src/SuperUserSpark/Compiler.hs view
@@ -0,0 +1,201 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}++{-+    The Compiler is responsible for transforming an AST into a list of+    deployments. A deployment knows about the possible sources, the+    destination, and how to deploy a source to a destination.++    Everything that the compiler does needs to be independent of the host+    system because compilation could have happened independently of deployment.++    As such, raw deployments still contain references to variables such as:+    - Environment variables+    - The home directory: @~@+-}+module SuperUserSpark.Compiler where++import Import hiding ((</>))++import Control.Exception (try)+import Data.Aeson (eitherDecode)+import Data.Aeson.Encode.Pretty (encodePretty)+import Data.List (find)++import SuperUserSpark.Compiler.Internal+import SuperUserSpark.Compiler.Types+import SuperUserSpark.CoreTypes+import SuperUserSpark.Language.Types+import SuperUserSpark.OptParse.Types+import SuperUserSpark.Parser+import SuperUserSpark.PreCompiler+import SuperUserSpark.Utils++compileFromArgs :: CompileArgs -> IO ()+compileFromArgs ca = do+    errOrrAss <- compileAssignment ca+    case errOrrAss of+        Left ce -> die $ unwords ["Failed to build compile assignment:", ce]+        Right ass -> compile ass++compileAssignment :: CompileArgs -> IO (Either String CompileAssignment)+compileAssignment CompileArgs {..} =+    CompileAssignment <$$> (parseStrongCardFileReference compileArgCardRef) <**>+    (case compileArgOutput of+         Nothing -> pure $ pure Nothing+         Just f -> do+             af <-+                 left (show :: PathParseException -> String) <$>+                 try (resolveFile' f)+             pure $ Just <$> af) <**>+    deriveCompileSettings compileFlags++resolveFile'Either :: FilePath -> IO (Either String (Path Abs File))+resolveFile'Either fp = do+    errOrSp <- try $ resolveFile' fp+    pure $ left (show :: PathParseException -> String) $ errOrSp++parseStrongCardFileReference :: FilePath+                             -> IO (Either String StrongCardFileReference)+parseStrongCardFileReference fp =+    (\sfp -> StrongCardFileReference sfp Nothing) <$$> resolveFile'Either fp++deriveCompileSettings :: CompileFlags -> IO (Either String CompileSettings)+deriveCompileSettings CompileFlags {..} =+    CompileSettings <$$>+    (pure $+     case compileDefaultKind of+         Nothing -> Right LinkDeployment+         Just s -> readEither s) <**>+    (pure $+     case compileKindOverride of+         Nothing -> Right Nothing+         Just s -> readEither s)++compile :: CompileAssignment -> IO ()+compile CompileAssignment {..} = do+    errOrDone <-+        runReaderT+            (runExceptT $+             compileJob compileCardReference >>= outputCompiled compileOutput)+            compileSettings+    case errOrDone of+        Left ce -> die $ formatCompileError ce+        Right () -> pure ()++formatCompileError :: CompileError -> String+formatCompileError (CompileParseError s) = unlines ["Parse failed:", show s]+formatCompileError (PreCompileErrors ss) =+    unlines $ "Precompilation checks failed:" : map show ss+formatCompileError (DuringCompilationError s) =+    unlines ["Compilation failed:", s]++decideCardToCompile :: StrongCardFileReference+                    -> [Card]+                    -> Either CompileError Card+decideCardToCompile (StrongCardFileReference fp mcn) scope =+    case mcn of+        Nothing ->+            case scope of+                [] ->+                    Left $+                    DuringCompilationError $+                    unwords+                        [ "No cards found for compilation in file:"+                        , toFilePath fp+                        ]+                            -- TODO more detailed error here+                (fst_:_) -> pure fst_+        Just (CardNameReference name) -> do+            case find (\c -> cardName c == name) scope of+                Nothing ->+                    Left $+                    DuringCompilationError $+                    unwords ["Card", name, "not found for compilation."] -- TODO more detailed error here+                Just cu -> return cu++throwEither :: Either CompileError a -> ImpureCompiler a+throwEither (Left e) = throwError e+throwEither (Right a) = pure a++injectBase :: Maybe (Path Rel Dir) -> Card -> Card+injectBase Nothing c = c+injectBase (Just base) (Card name s) =+    Card name $ Block [OutofDir $ toFilePath base, s]++compileJob :: StrongCardFileReference -> ImpureCompiler [RawDeployment]+compileJob cr@(StrongCardFileReference root _) =+    compileJobWithRoot root Nothing cr++compileJobWithRoot+    :: Path Abs File+    -> Maybe (Path Rel Dir)+    -> StrongCardFileReference+    -> ImpureCompiler [RawDeployment]+compileJobWithRoot root base cfr@(StrongCardFileReference fp _) = do+    sf <- compilerParse fp+    unit <- throwEither $ decideCardToCompile cfr $ sparkFileCards sf+    -- Inject base outofDir+    let injected = injectBase base unit+    -- Precompile checks+    let pces = preCompileChecks injected+    when (not . null $ pces) $ throwError $ PreCompileErrors pces+    -- Compile this unit+    (deps, crfs) <- embedPureCompiler $ compileUnit injected+    -- Compile the rest of the units+    rcrfs <- mapM (resolveCardReferenceRelativeTo fp) crfs+    restDeps <-+        fmap concat $+        forM rcrfs $ \rcrf ->+            case rcrf of+                (StrongCardFile cfr_@(StrongCardFileReference base2 _)) -> do+                    let (newRoot, newBase) =+                            case stripDir (parent root) (parent base2) of+                                Nothing -> (base2, Nothing)+                                Just d -> (root, Just d)+                    compileJobWithRoot newRoot newBase cfr_+                (StrongCardName cnr) ->+                    compileJobWithRoot+                        root+                        base+                        (StrongCardFileReference fp $ Just cnr)+    return $ deps ++ restDeps++resolveCardReferenceRelativeTo :: Path Abs File+                               -> CardReference+                               -> ImpureCompiler StrongCardReference+resolveCardReferenceRelativeTo fp (CardFile (CardFileReference cfp mcn)) = do+    nfp <- liftIO $ resolveFile (parent fp) cfp+    pure $ StrongCardFile $ StrongCardFileReference nfp mcn+resolveCardReferenceRelativeTo _ (CardName cnr) = pure $ StrongCardName cnr++compilerParse :: Path Abs File -> ImpureCompiler SparkFile+compilerParse fp = do+    esf <- liftIO $ parseFile fp+    case esf of+        Left pe -> throwError $ CompileParseError pe+        Right sf_ -> pure sf_++embedPureCompiler :: PureCompiler a -> ImpureCompiler a+embedPureCompiler = withExceptT id . mapExceptT (mapReaderT idToIO)+  where+    idToIO :: Identity a -> IO a+    idToIO = return . runIdentity++outputCompiled :: Maybe (Path Abs File) -> [RawDeployment] -> ImpureCompiler ()+outputCompiled out deps =+    liftIO $ do+        let bs = encodePretty deps+        case out of+            Nothing -> putStrLn bs+            Just fp -> writeFile fp bs++inputCompiled :: Path Abs File -> ImpureCompiler [RawDeployment]+inputCompiled fp = do+    bs <- readFile fp+    case eitherDecode bs of+        Left err ->+            throwError $+            DuringCompilationError $+            "Something went wrong while deserialising json data: " ++ err+        Right ds -> return ds
+ src/SuperUserSpark/Compiler/Internal.hs view
@@ -0,0 +1,52 @@+module SuperUserSpark.Compiler.Internal where++import Import hiding ((</>))++import System.FilePath ((</>))++import SuperUserSpark.Compiler.Types+import SuperUserSpark.Compiler.Utils+import SuperUserSpark.Language.Types++compileUnit :: Card -> PureCompiler ([RawDeployment], [CardReference])+compileUnit card =+    execWriterT $ evalStateT (compileDecs [cardContent card]) initialState++compileDecs :: [Declaration] -> InternalCompiler ()+compileDecs = mapM_ compileDec++compileDec :: Declaration -> InternalCompiler ()+compileDec (Deploy src dst kind) = do+    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+    into <- gets stateInto+    let directions =+            Directions+            { directionSources = resolvePrefix $ outof ++ [sources src]+            , directionDestination = into </> dst+            }+    addDeployment $ Deployment directions resultKind+compileDec (SparkOff cr) = addCardRef cr+compileDec (IntoDir dir) = do+    ip <- gets stateInto+    if null ip+        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+    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]})
+ src/SuperUserSpark/Compiler/Types.hs view
@@ -0,0 +1,128 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-}++module SuperUserSpark.Compiler.Types where++import Import++import Data.Aeson+       (FromJSON(..), ToJSON(..), object, (.:), (.=), withObject)++import SuperUserSpark.CoreTypes+import SuperUserSpark.Language.Types+import SuperUserSpark.Parser.Types+import SuperUserSpark.PreCompiler.Types++data CompileAssignment = CompileAssignment+    { compileCardReference :: StrongCardFileReference+    , compileOutput :: Maybe (Path Abs File)+    , compileSettings :: CompileSettings+    } deriving (Show, Eq, Generic)++instance Validity CompileAssignment++data StrongCardFileReference =+    StrongCardFileReference (Path Abs File)+                            (Maybe CardNameReference)+    deriving (Show, Eq, Generic)++instance Validity StrongCardFileReference++data StrongCardReference+    = StrongCardFile StrongCardFileReference+    | StrongCardName CardNameReference+    deriving (Show, Eq, Generic)++instance Validity StrongCardReference++data CompileSettings = CompileSettings+    { compileDefaultKind :: DeploymentKind+    , compileKindOverride :: Maybe DeploymentKind+    } deriving (Show, Eq, Generic)++instance Validity CompileSettings++defaultCompileSettings :: CompileSettings+defaultCompileSettings =+    CompileSettings+    {compileDefaultKind = LinkDeployment, compileKindOverride = Nothing}++type RawDeployment = Deployment FilePath++data Deployment a = Deployment+    { deploymentDirections :: DeploymentDirections a+    , deploymentKind :: DeploymentKind+    } deriving (Show, Eq, Generic)++instance Validity a =>+         Validity (Deployment a)++instance FromJSON a =>+         FromJSON (Deployment a) where+    parseJSON =+        withObject "Deployment" $ \o ->+            Deployment <$> o .: "directions" <*> o .: "deployment kind"++instance ToJSON a =>+         ToJSON (Deployment a) where+    toJSON depl =+        object+            [ "directions" .= deploymentDirections depl+            , "deployment kind" .= deploymentKind depl+            ]++instance Functor Deployment where+    fmap f (Deployment dis dk) = Deployment (fmap f dis) dk++data DeploymentDirections a = Directions+    { directionSources :: [a]+    , directionDestination :: a+    } deriving (Show, Eq, Generic)++instance Validity a =>+         Validity (DeploymentDirections a)++instance ToJSON a =>+         ToJSON (DeploymentDirections a) where+    toJSON (Directions srcs dst) =+        object ["sources" .= srcs, "destination" .= dst]++instance FromJSON a =>+         FromJSON (DeploymentDirections a) where+    parseJSON =+        withObject "Deployment Directions" $ \o ->+            Directions <$> o .: "sources" <*> o .: "destination"++instance Functor DeploymentDirections where+    fmap f (Directions srcs dst) = Directions (map f srcs) (f dst)++type CompilerPrefix = [PrefixPart]++data PrefixPart+    = Literal String+    | Alts [String]+    deriving (Show, Eq, Generic)++instance Validity PrefixPart++data CompilerState = CompilerState+    { stateDeploymentKindLocalOverride :: Maybe DeploymentKind+    , stateInto :: Directory+    , stateOutof_prefix :: CompilerPrefix+    } deriving (Show, Eq, Generic)++instance Validity CompilerState++type ImpureCompiler = ExceptT CompileError (ReaderT CompileSettings IO)++type PureCompiler = ExceptT CompileError (ReaderT CompileSettings Identity)++type InternalCompiler = StateT CompilerState (WriterT ([RawDeployment], [CardReference]) PureCompiler)++data CompileError+    = CompileParseError ParseError+    | PreCompileErrors [PreCompileError]+    | DuringCompilationError String+    deriving (Show, Eq, Generic)++instance Validity CompileError
+ src/SuperUserSpark/Compiler/Utils.hs view
@@ -0,0 +1,37 @@+module SuperUserSpark.Compiler.Utils where++import Import hiding ((</>))++import SuperUserSpark.Compiler.Types+import SuperUserSpark.Language.Types+import System.FilePath ((</>))++initialState :: CompilerState+initialState =+    CompilerState+    { stateDeploymentKindLocalOverride = Nothing+    , stateInto = ""+    , stateOutof_prefix = []+    }++addDeployment :: RawDeployment -> InternalCompiler ()+addDeployment d = tell ([d], [])++addCardRef :: CardReference -> InternalCompiler ()+addCardRef c = tell ([], [c])++sources :: FilePath -> PrefixPart+sources fp@('.':f) = Alts [fp, f]+sources fp = Literal fp++resolvePrefix :: CompilerPrefix -> [FilePath]+resolvePrefix [] = []+resolvePrefix [Literal s] = [s]+resolvePrefix [Alts ds] = ds+resolvePrefix ((Literal s):ps) = do+    rest <- resolvePrefix ps+    return $ s </> rest+resolvePrefix ((Alts as):ps) = do+    a <- as+    rest <- resolvePrefix ps+    return $ a </> rest
+ src/SuperUserSpark/Constants.hs view
@@ -0,0 +1,69 @@+module SuperUserSpark.Constants where++import Import++keywordCard :: String+keywordCard = "card"++keywordSpark :: String+keywordSpark = "spark"++keywordFile :: String+keywordFile = "file"++keywordInto :: String+keywordInto = "into"++keywordOutof :: String+keywordOutof = "outof"++keywordKindOverride :: String+keywordKindOverride = "kind"++keywordLink :: String+keywordLink = "link"++keywordCopy :: String+keywordCopy = "copy"++keywordAlternatives :: String+keywordAlternatives = "alternatives"++linkKindSymbol :: String+linkKindSymbol = "l->"++copyKindSymbol :: String+copyKindSymbol = "c->"++unspecifiedKindSymbol :: String+unspecifiedKindSymbol = "->"++bracesChars :: [Char]+bracesChars = ['{', '}']++linespaceChars :: [Char]+linespaceChars = [' ', '\t']++endOfLineChars :: [Char]+endOfLineChars = ['\n', '\r']++whitespaceChars :: [Char]+whitespaceChars = linespaceChars ++ endOfLineChars++lineDelimiter :: String+lineDelimiter = ";"++branchDelimiter :: String+branchDelimiter = ":"++quotesChar :: Char+quotesChar = '"'++lineCommentStr :: String+lineCommentStr = "#"++blockCommentStrs :: (String, String)+blockCommentStrs = ("[[", "]]")++sparkExtension :: String+sparkExtension = "sus"
+ src/SuperUserSpark/CoreTypes.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-}++module SuperUserSpark.CoreTypes where++import Import++import Control.Monad (mzero)+import Data.Aeson (FromJSON(..), ToJSON(..), Value(..))++type Directory = FilePath++-- | The kind of a deployment+data DeploymentKind+    = LinkDeployment+    | CopyDeployment+    deriving (Show, Eq, Generic)++instance Validity DeploymentKind++instance Read DeploymentKind where+    readsPrec _ "link" = [(LinkDeployment, "")]+    readsPrec _ "copy" = [(CopyDeployment, "")]+    readsPrec _ _ = []++instance FromJSON DeploymentKind where+    parseJSON (String "link") = return LinkDeployment+    parseJSON (String "copy") = return CopyDeployment+    parseJSON _ = mzero++instance ToJSON DeploymentKind where+    toJSON LinkDeployment = String "link"+    toJSON CopyDeployment = String "copy"
+ src/SuperUserSpark/Deployer.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE RecordWildCards #-}++module SuperUserSpark.Deployer where++import Import++import SuperUserSpark.Bake+import SuperUserSpark.Bake.Internal+import SuperUserSpark.Bake.Types+import SuperUserSpark.Check+import SuperUserSpark.Check.Internal+import SuperUserSpark.Check.Types+import SuperUserSpark.Deployer.Internal+import SuperUserSpark.Deployer.Types+import SuperUserSpark.Diagnose+import SuperUserSpark.Diagnose.Types+import SuperUserSpark.OptParse.Types+import SuperUserSpark.Utils++deployFromArgs :: DeployArgs -> IO ()+deployFromArgs das = do+    errOrAss <- deployAssignment das+    case errOrAss of+        Left err -> die $ unwords ["Failed to make Deployment assignment:", err]+        Right ass -> deploy ass++deployAssignment :: DeployArgs -> IO (Either String DeployAssignment)+deployAssignment DeployArgs {..} = do+    errOrCardRef <- parseBakeCardReference deployArgCardRef+    case errOrCardRef of+        Left err -> pure $ Left err+        Right cardRef ->+            DeployAssignment cardRef <$$>+            deriveDeploySettings cardRef deployFlags++deriveDeploySettings :: BakeCardReference+                     -> DeployFlags+                     -> IO (Either String DeploySettings)+deriveDeploySettings bcr DeployFlags {..} = do+    ecs <- deriveCheckSettings bcr deployCheckFlags+    pure $ do+        cs <- ecs+        pure+            DeploySettings+            { deploySetsReplaceLinks =+                  deployFlagReplaceLinks || deployFlagReplaceAll+            , deploySetsReplaceFiles =+                  deployFlagReplaceFiles || deployFlagReplaceAll+            , deploySetsReplaceDirectories =+                  deployFlagReplaceDirectories || deployFlagReplaceAll+            , deployCheckSettings = cs+            }++deploy :: DeployAssignment -> IO ()+deploy DeployAssignment {..} = do+    errOrDone <-+        runReaderT+            (runExceptT $ deployByCardRef deployCardReference)+            deploySettings+    case errOrDone of+        Left err -> die $ formatDeployError err+        Right () -> pure ()++formatDeployError :: DeployError -> String+formatDeployError (DeployCheckError e) = formatCheckError e+formatDeployError (DeployError s) = unwords ["Deployment failed:", s]++deployByCardRef :: BakeCardReference -> SparkDeployer ()+deployByCardRef dcr = do+    deps <- deployerBake $ compileBakeCardRef dcr >>= bakeDeployments+    deployAbss deps++deployerBake :: SparkBaker a -> SparkDeployer a+deployerBake =+    withExceptT (DeployCheckError . CheckDiagnoseError . DiagnoseBakeError) .+    mapExceptT+        (withReaderT $+         diagnoseBakeSettings . checkDiagnoseSettings . deployCheckSettings)++deployAbss :: [BakedDeployment] -> SparkDeployer ()+deployAbss ds = do+    stage1+    stage2+    stage3+  where+    stage1 = do+        ddeps <- liftIO $ diagnoseDeployments ds+        let dcrs = checkDeployments ddeps+        -- Check for impossible deployments+        when (any impossibleDeployment dcrs) $+            err (zip ddeps dcrs) "Deployment is impossible."+        -- Clean up the situation+        forM_ dcrs $ \d -> do+            case d of+                DirtySituation _ _ cis -> performClean cis+                _ -> return ()+    stage2+      -- Check again+     = do+        ddeps2 <- liftIO $ diagnoseDeployments ds+        let dcrs2 = checkDeployments ddeps2+        -- Error if the cleaning is not done now.+        when (any (\d -> impossibleDeployment d || dirtyDeployment d) dcrs2) $+            err (zip ddeps2 dcrs2) $+            unlines+                [ "Situation was not entirely clean after attemted cleanup."+                , "Maybe you forgot to enable cleanups (--replace-all)?"+                ]+        -- Perform deployments+        liftIO $+            mapM_ performDeployment $+            map (\(ReadyToDeploy i) -> i) $ filter deploymentReadyToDeploy dcrs2+    stage3+        -- Check one last time.+     = do+        do ddeps3 <- liftIO $ diagnoseDeployments ds+           let dcrsf3 = checkDeployments ddeps3+           when (any (not . deploymentIsDone) dcrsf3) $ do+               err+                   (zip ddeps3 dcrsf3)+                   "Something went wrong during deployment. It's not done yet."+    err :: [(DiagnosedDeployment, DeploymentCheckResult)]+        -> String+        -> SparkDeployer ()+    err dcrs_ text = do+        liftIO $ putStrLn $ formatDeploymentChecks dcrs_+        throwError $ DeployError text
+ src/SuperUserSpark/Deployer/Internal.hs view
@@ -0,0 +1,61 @@+module SuperUserSpark.Deployer.Internal where++import Import hiding ((</>))++import Data.Text (pack)+import System.FilePath.Posix+       (dropFileName, 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++performClean :: CleanupInstruction -> SparkDeployer ()+performClean (CleanFile fp) = incase deploySetsReplaceFiles $ rmFile fp+performClean (CleanDirectory fp) =+    incase deploySetsReplaceDirectories $ rmDir fp+performClean (CleanLink fp) = incase deploySetsReplaceLinks $ unlink fp++unlink :: Path Abs File -> SparkDeployer ()+unlink = liftIO . removeLink . dropTrailingPathSeparator . toFilePath++rmFile :: Path Abs File -> SparkDeployer ()+rmFile = liftIO . removeFile++rmDir :: Path Abs Dir -> SparkDeployer ()+rmDir = liftIO . removeDirRecur++performDeployment :: Instruction -> IO ()+performDeployment (CopyFile source destination) =+    performCopyFile source destination+performDeployment (CopyDir source destination) =+    performCopyDir source destination+performDeployment (LinkFile source destination) =+    performLinkFile source destination+performDeployment (LinkDir source destination) =+    performLinkDir source destination++performCopyFile :: Path Abs File -> Path Abs File -> IO ()+performCopyFile src dst = do+    ensureDir $ parent dst+    copyFile src dst++performCopyDir :: Path Abs Dir -> Path Abs Dir -> IO ()+performCopyDir src dst = do+    ensureDir $ parent dst+    copyDirRecur src dst++performLinkFile :: Path Abs File -> Path Abs File -> IO ()+performLinkFile src dst = do+    ensureDir $ parent dst+    createSymbolicLink (toFilePath src) (toFilePath dst)++performLinkDir :: Path Abs Dir -> Path Abs Dir -> IO ()+performLinkDir src dst = do+    ensureDir $ parent dst+    createSymbolicLink+        (dropTrailingPathSeparator $ toFilePath src)+        (dropTrailingPathSeparator $ toFilePath dst)
+ src/SuperUserSpark/Deployer/Types.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE DeriveGeneric #-}++module SuperUserSpark.Deployer.Types where++import Import++import SuperUserSpark.Bake.Types+import SuperUserSpark.Check.Types+import SuperUserSpark.CoreTypes++data DeployAssignment = DeployAssignment+    { deployCardReference :: BakeCardReference+    , deploySettings :: DeploySettings+    } deriving (Show, Eq, Generic)++instance Validity DeployAssignment++data DeploySettings = DeploySettings+    { deploySetsReplaceLinks :: Bool+    , deploySetsReplaceFiles :: Bool+    , deploySetsReplaceDirectories :: Bool+    , deployCheckSettings :: CheckSettings+    } deriving (Show, Eq, Generic)++instance Validity DeploySettings++defaultDeploySettings :: DeploySettings+defaultDeploySettings =+    DeploySettings+    { deploySetsReplaceLinks = False+    , deploySetsReplaceFiles = False+    , deploySetsReplaceDirectories = False+    , deployCheckSettings = defaultCheckSettings+    }++type SparkDeployer = ExceptT DeployError (ReaderT DeploySettings IO)++data DeployError+    = DeployCheckError CheckError+    | DeployError String+    deriving (Show, Eq, Generic)++instance Validity DeployError++data PreDeployment+    = Ready FilePath+            FilePath+            DeploymentKind+    | AlreadyDone+    | Error String+    deriving (Show, Eq, Generic)++instance Validity PreDeployment
+ src/SuperUserSpark/Diagnose.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE RecordWildCards #-}++{-+    The responsibility of the diagnoser is to turn baked deployments into+    diagnosed deployments. This is purely a read-only operation that looks+    at the current state of the file system.+-}+module SuperUserSpark.Diagnose+    ( diagnoseFromArgs+    , diagnoseAssignment+    , deriveDiagnoseSettings+    , diagnose+    , formatDiagnoseError+    , diagnoserBake+    , diagnoseDeployments+    ) where++import Import++import qualified Data.Aeson.Encode.Pretty as JSON++import SuperUserSpark.Bake+import SuperUserSpark.Bake.Internal+import SuperUserSpark.Bake.Types+import SuperUserSpark.Diagnose.Internal+import SuperUserSpark.Diagnose.Types+import SuperUserSpark.OptParse.Types+import SuperUserSpark.Utils++diagnoseFromArgs :: DiagnoseArgs -> IO ()+diagnoseFromArgs cas = do+    errOrAss <- diagnoseAssignment cas+    case errOrAss of+        Left err -> die $ unwords ["Failed to build Diagnose assignment:", err]+        Right ass -> diagnose ass++diagnoseAssignment :: DiagnoseArgs -> IO (Either String DiagnoseAssignment)+diagnoseAssignment DiagnoseArgs {..} = do+    errOrCardRef <- parseBakeCardReference diagnoseArgCardRef+    case errOrCardRef of+        Left err -> pure $ Left err+        Right cardRef ->+            DiagnoseAssignment cardRef <$$>+            deriveDiagnoseSettings cardRef diagnoseFlags++deriveDiagnoseSettings :: BakeCardReference+                       -> DiagnoseFlags+                       -> IO (Either String DiagnoseSettings)+deriveDiagnoseSettings bcr DiagnoseFlags {..} =+    DiagnoseSettings <$$> deriveBakeSettings bcr diagnoseBakeFlags++diagnose :: DiagnoseAssignment -> IO ()+diagnose DiagnoseAssignment {..} = do+    errOrDone <-+        runReaderT+            (runExceptT $ diagnoseByCardRef diagnoseCardReference)+            diagnoseSettings+    case errOrDone of+        Left err -> die $ formatDiagnoseError err+        Right () -> pure ()++formatDiagnoseError :: DiagnoseError -> String+formatDiagnoseError (DiagnoseBakeError ce) = formatBakeError ce+formatDiagnoseError (DiagnoseError s) = unwords ["Diagnose failed:", s]++diagnoseByCardRef :: BakeCardReference -> SparkDiagnoser ()+diagnoseByCardRef checkCardReference = do+    deps <-+        diagnoserBake $+        compileBakeCardRef checkCardReference >>= bakeDeployments+    ddeps <- liftIO $ diagnoseDeployments deps+    putStrLn $ JSON.encodePretty ddeps++diagnoserBake :: SparkBaker a -> SparkDiagnoser a+diagnoserBake =+    withExceptT DiagnoseBakeError .+    mapExceptT (withReaderT diagnoseBakeSettings)++diagnoseDeployments :: [BakedDeployment] -> IO [DiagnosedDeployment]+diagnoseDeployments = mapM diagnoseDeployment
+ src/SuperUserSpark/Diagnose/Internal.hs view
@@ -0,0 +1,77 @@+module SuperUserSpark.Diagnose.Internal where++import Import++import qualified Data.ByteString as SB+import Data.Hashable+import System.Posix.Files+       (getSymbolicLinkStatus, isBlockDevice, isCharacterDevice,+        isDirectory, isNamedPipe, isRegularFile, isSocket, isSymbolicLink,+        readSymbolicLink)++import SuperUserSpark.Bake.Types+import SuperUserSpark.Compiler.Types+import SuperUserSpark.Diagnose.Types++diagnoseDeployment :: BakedDeployment -> IO DiagnosedDeployment+diagnoseDeployment (Deployment bds kind) = do+    ddirs <- diagnoseDirs bds+    return $ Deployment ddirs kind++diagnoseDirs :: DeploymentDirections AbsP+             -> IO (DeploymentDirections DiagnosedFp)+diagnoseDirs (Directions srcs dst) =+    Directions <$> mapM diagnoseAbsP srcs <*> diagnoseAbsP dst++diagnoseAbsP :: AbsP -> IO DiagnosedFp+diagnoseAbsP fp = do+    d <- diagnoseFp fp+    hash_ <- hashFilePath fp+    return $ D fp d hash_++diagnoseFp :: AbsP -> IO Diagnostics+diagnoseFp absp = do+    let fp = toPath absp+    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++-- | Hash a filepath so that two filepaths with the same contents have the same hash+hashFilePath :: AbsP -> IO HashDigest+hashFilePath fp = do+    d <- diagnoseFp fp+    case d of+        IsFile -> hashFile fp+        IsDirectory -> hashDirectory fp+        IsLinkTo _ -> return $ HashDigest $ hash ()+        IsWeird -> return $ HashDigest $ hash ()+        Nonexistent -> return $ HashDigest $ hash ()++hashFile :: AbsP -> IO HashDigest+hashFile fp = (HashDigest . hash) <$> SB.readFile (toPath fp)++hashDirectory :: AbsP -> IO HashDigest+hashDirectory fp = do+    tdir <- parseAbsDir (toPath fp)+    walkDirAccum Nothing writer_ tdir+  where+    writer_ _ _ files = do+        hashes <- mapM (hashFile . AbsP) files+        pure $ HashDigest $ hash hashes
+ src/SuperUserSpark/Diagnose/Types.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module SuperUserSpark.Diagnose.Types where++import Import++import Data.Aeson+import Data.Hashable+import Text.Printf++import SuperUserSpark.Bake.Types+import SuperUserSpark.Compiler.Types++data DiagnoseAssignment = DiagnoseAssignment+    { diagnoseCardReference :: BakeCardReference+    , diagnoseSettings :: DiagnoseSettings+    } deriving (Show, Eq, Generic)++instance Validity DiagnoseAssignment++data DiagnoseSettings = DiagnoseSettings+    { diagnoseBakeSettings :: BakeSettings+    } deriving (Show, Eq, Generic)++instance Validity DiagnoseSettings++defaultDiagnoseSettings :: DiagnoseSettings+defaultDiagnoseSettings =+    DiagnoseSettings {diagnoseBakeSettings = defaultBakeSettings}++type SparkDiagnoser = ExceptT DiagnoseError (ReaderT DiagnoseSettings IO)++data DiagnoseError+    = DiagnoseBakeError BakeError+    | DiagnoseError String+    deriving (Show, Eq, Generic)++instance Validity DiagnoseError++newtype HashDigest =+    HashDigest Int+    deriving (Show, Eq, Generic)++instance Validity HashDigest++instance Monoid HashDigest where+    mempty = HashDigest (hash ())+    (HashDigest h1) `mappend` (HashDigest h2) = HashDigest $ h1 * 31 + h2++instance Hashable HashDigest++instance ToJSON HashDigest where+    toJSON (HashDigest i) = toJSON $ (printf "%016x" i :: String)++data Diagnostics+    = Nonexistent+    | IsFile+    | IsDirectory+    | IsLinkTo AbsP -- Could point to directory too.+    | IsWeird+    deriving (Show, Eq, Generic)++instance Validity Diagnostics++instance ToJSON Diagnostics where+    toJSON Nonexistent = String "nonexistent"+    toJSON IsFile = String "file"+    toJSON IsDirectory = String "directory"+    toJSON (IsLinkTo ap) =+        object ["kind" .= String "link", "link destination" .= ap]+    toJSON IsWeird = String "weird"++data DiagnosedFp = D+    { diagnosedFilePath :: AbsP+    , diagnosedDiagnostics :: Diagnostics+    , diagnosedHashDigest :: HashDigest+    } deriving (Show, Eq, Generic)++instance Validity DiagnosedFp++instance ToJSON DiagnosedFp where+    toJSON D {..} =+        object $+        ["path" .= diagnosedFilePath, "diagnostics" .= diagnosedDiagnostics] +++        if diagnosedHashDigest == mempty+            then []+            else ["hash" .= diagnosedHashDigest]++type DiagnosedDeployment = Deployment DiagnosedFp
+ src/SuperUserSpark/Language/Types.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE DeriveGeneric #-}++module SuperUserSpark.Language.Types where++import Import++import SuperUserSpark.CoreTypes++-- * Cards+type CardName = String++type Source = FilePath++type Destination = FilePath++data Card = Card+    { cardName :: CardName+    , cardContent :: Declaration+    } deriving (Show, Eq, Generic)++instance Validity Card++-- ** Declarations+-- | A declaration in a card+data Declaration+    = SparkOff CardReference -- ^ Spark off another card+    | Deploy Source+             Destination+             (Maybe DeploymentKind) -- ^ Deploy from source to destination+    | IntoDir Directory -- ^ Deploy into a directory+    | OutofDir Directory -- ^ Deploy outof a directory+    | DeployKindOverride DeploymentKind -- ^ Override the deployment kind+    | Alternatives [Directory] -- ^ Provide a list of alternative sources+    | Block [Declaration] -- ^ A scoped block of declarations+    deriving (Show, Eq, Generic)++instance Validity Declaration++-- * Card references+-- | Reference a card by name (inside a file)+newtype CardNameReference =+    CardNameReference CardName+    deriving (Show, Eq, Generic)++instance Validity CardNameReference++-- | Reference a card by the file it is in and therein potentially by a name reference+data CardFileReference =+    CardFileReference FilePath+                      (Maybe CardNameReference)+    deriving (Show, Eq, Generic)++instance Validity CardFileReference++instance Read CardFileReference where+    readsPrec _ fp =+        case length (words fp) of+            1 -> [(CardFileReference fp Nothing, "")]+            2 ->+                let [f, c] = words fp+                in [(CardFileReference f (Just $ CardNameReference c), "")]+            _ -> []++-- | Union card reference+data CardReference+    = CardFile CardFileReference+    | CardName CardNameReference+    deriving (Show, Eq, Generic)++instance Validity CardReference++-- * Card files+data SparkFile = SparkFile+    { sparkFilePath :: Path Abs File+    , sparkFileCards :: [Card]+    } deriving (Show, Eq, Generic)++instance Validity SparkFile
+ src/SuperUserSpark/OptParse.hs view
@@ -0,0 +1,187 @@+module SuperUserSpark.OptParse+    ( getDispatch+    , Dispatch(..)+    ) where++import Import++import Options.Applicative+import System.Environment (getArgs)++import SuperUserSpark.OptParse.Types++getDispatch :: IO Dispatch+getDispatch = do+    args <- getArgs+    let result = runOptionsParser args+    handleParseResult result++runOptionsParser :: [String] -> ParserResult Dispatch+runOptionsParser strs = execParserPure prefs_ optionsParser strs+  where+    prefs_ =+        ParserPrefs+        { prefMultiSuffix = ""+        , prefDisambiguate = True+        , prefShowHelpOnError = True+        , prefShowHelpOnEmpty = True+        , prefBacktrack = True+        , prefColumns = 80+        }++optionsParser :: ParserInfo Dispatch+optionsParser =+    info+        (helper <*> parseDispatch)+        (fullDesc <> progDesc "Super User Spark, author: Tom Sydney Kerckhove")++parseDispatch :: Parser Dispatch+parseDispatch =+    hsubparser $+    mconcat+        [ command "parse" parseParse+        , command "compile" parseCompile+        , command "bake" parseBake+        , command "diagnose" parseDiagnose+        , command "check" parseCheck+        , command "deploy" parseDeploy+        ]++parseParse :: ParserInfo Dispatch+parseParse = info parser modifier+  where+    parser = DispatchParse <$> parseParseArgs+    modifier =+        fullDesc <>+        progDesc "Parse a spark file and check for syntactic errors."++parseParseArgs :: Parser ParseArgs+parseParseArgs =+    ParseArgs <$>+    strArgument (mconcat [metavar "FILE", help "the file to parse"])++parseCompile :: ParserInfo Dispatch+parseCompile = info parser modifier+  where+    parser = DispatchCompile <$> parseCompileArgs+    modifier = fullDesc <> progDesc "Compile a spark card."++parseCompileArgs :: Parser CompileArgs+parseCompileArgs =+    CompileArgs <$>+    strArgument (metavar "CARDREF" <> help "the card file to compile") <*>+    option+        (Just <$> str)+        (mconcat+             [ long "output"+             , short 'o'+             , value Nothing+             , metavar "FILE"+             , help "The output file for compilation"+             ]) <*>+    parseCompileFlags++parseCompileFlags :: Parser CompileFlags+parseCompileFlags =+    CompileFlags <$>+    option+        (Just <$> str)+        (mconcat+             [ long "kind"+             , short 'k'+             , value Nothing+             , metavar "KIND"+             , help+                   "The kind specification for unspecified deployments (default: link)"+             ]) <*>+    option+        (Just <$> str)+        (mconcat+             [ long "override"+             , short 'O'+             , value Nothing+             , metavar "KIND"+             , help "Override every deployment to be of the given kind"+             ])++parseBake :: ParserInfo Dispatch+parseBake = info parser modifier+  where+    parser = DispatchBake <$> parseBakeArgs+    modifier = fullDesc <> progDesc "Bake the raw deployment of a spark card."++parseBakeArgs :: Parser BakeArgs+parseBakeArgs =+    BakeArgs <$> strArgument (metavar "CARDREF" <> help "the card to bake") <*>+    parseBakeFlags++parseBakeFlags :: Parser BakeFlags+parseBakeFlags = BakeFlags <$> parseCompileFlags++parseDiagnose :: ParserInfo Dispatch+parseDiagnose = info parser modifier+  where+    parser = DispatchDiagnose <$> parseDiagnoseArgs+    modifier =+        fullDesc <> progDesc "Diagnose the baked deployment of a spark card."++parseDiagnoseArgs :: Parser DiagnoseArgs+parseDiagnoseArgs =+    DiagnoseArgs <$>+    strArgument (metavar "CARDREF" <> help "the card to diagnose") <*>+    parseDiagnoseFlags++parseDiagnoseFlags :: Parser DiagnoseFlags+parseDiagnoseFlags = DiagnoseFlags <$> parseBakeFlags++parseCheck :: ParserInfo Dispatch+parseCheck = info parser modifier+  where+    parser = DispatchCheck <$> parseCheckArgs+    modifier = fullDesc <> progDesc "Check the deployment of a spark card."++parseCheckArgs :: Parser CheckArgs+parseCheckArgs =+    CheckArgs <$> strArgument (metavar "CARDREF" <> help "the card to check") <*>+    parseCheckFlags++parseCheckFlags :: Parser CheckFlags+parseCheckFlags = CheckFlags <$> parseDiagnoseFlags++parseDeploy :: ParserInfo Dispatch+parseDeploy = info parser modifier+  where+    parser = DispatchDeploy <$> parseDeployArgs+    modifier = fullDesc <> progDesc "Deploy a spark card."++parseDeployArgs :: Parser DeployArgs+parseDeployArgs =+    DeployArgs <$> strArgument (metavar "CARDREF" <> help "the card to deploy") <*>+    parseDeployFlags++parseDeployFlags :: Parser DeployFlags+parseDeployFlags =+    DeployFlags <$>+    switch+        (mconcat+             [ long "replace-links"+             , help "Replace links at deploy destinations."+             ]) <*>+    switch+        (mconcat+             [ long "replace-files"+             , help "Replace existing files at deploy destinations."+             ]) <*>+    switch+        (mconcat+             [ long "replace-Directories"+             , help "Replace existing directories at deploy destinations."+             ]) <*>+    switch+        (mconcat+             [ long "replace-all"+             , short 'r'+             , help+                   "Equivalent to --replace-files --replace-directories --replace-links"+             ]) <*>+    parseCheckFlags
+ src/SuperUserSpark/OptParse/Types.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE DeriveGeneric #-}++module SuperUserSpark.OptParse.Types where++import Import++data Dispatch+    = DispatchParse ParseArgs+    | DispatchCompile CompileArgs+    | DispatchBake BakeArgs+    | DispatchDiagnose DiagnoseArgs+    | DispatchCheck CheckArgs+    | DispatchDeploy DeployArgs+    deriving (Show, Eq, Generic)++instance Validity Dispatch++data ParseArgs = ParseArgs+    { parseFilePath :: FilePath+    } deriving (Show, Eq, Generic)++instance Validity ParseArgs++data CompileArgs = CompileArgs+    { compileArgCardRef :: String+    , compileArgOutput :: Maybe FilePath+    , compileFlags :: CompileFlags+    } deriving (Show, Eq, Generic)++instance Validity CompileArgs++data CompileFlags = CompileFlags+    { compileDefaultKind :: Maybe String+    , compileKindOverride :: Maybe String+    } deriving (Show, Eq, Generic)++instance Validity CompileFlags++data BakeArgs = BakeArgs+    { bakeCardRef :: String+    , bakeFlags :: BakeFlags+    } deriving (Show, Eq, Generic)++instance Validity BakeArgs++data BakeFlags = BakeFlags+    { bakeCompileFlags :: CompileFlags+    } deriving (Show, Eq, Generic)++instance Validity BakeFlags++data DiagnoseArgs = DiagnoseArgs+    { diagnoseArgCardRef :: String+    , diagnoseFlags :: DiagnoseFlags+    } deriving (Show, Eq, Generic)++instance Validity DiagnoseArgs++data DiagnoseFlags = DiagnoseFlags+    { diagnoseBakeFlags :: BakeFlags+    } deriving (Show, Eq, Generic)++instance Validity DiagnoseFlags++data CheckArgs = CheckArgs+    { checkArgCardRef :: String+    , checkFlags :: CheckFlags+    } deriving (Show, Eq, Generic)++instance Validity CheckArgs++data CheckFlags = CheckFlags+    { checkDiagnoseFlags ::DiagnoseFlags+    } deriving (Show, Eq, Generic)++instance Validity CheckFlags++data DeployArgs = DeployArgs+    { deployArgCardRef :: String+    , deployFlags :: DeployFlags+    } deriving (Show, Eq, Generic)++instance Validity DeployArgs++data DeployFlags = DeployFlags+    { deployFlagReplaceLinks :: Bool+    , deployFlagReplaceFiles :: Bool+    , deployFlagReplaceDirectories :: Bool+    , deployFlagReplaceAll :: Bool+    , deployCheckFlags :: CheckFlags+    } deriving (Show, Eq, Generic)++instance Validity DeployFlags
+ src/SuperUserSpark/Parser.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE RecordWildCards #-}++{-+    The Parser is responsible for transforming a 'String' into an AST.+-}+module SuperUserSpark.Parser where++import Import++import Control.Exception (try)++import SuperUserSpark.Language.Types+import SuperUserSpark.OptParse.Types+import SuperUserSpark.Parser.Internal+import SuperUserSpark.Parser.Types+import SuperUserSpark.Utils++parseFromArgs :: ParseArgs -> IO ()+parseFromArgs pa = do+    errOrAss <- parseAssignment pa+    case errOrAss of+        Left err -> die $ unwords ["Unable to build parse assignment:", err]+        Right ass -> parse ass++parseAssignment :: ParseArgs -> IO (Either String ParseAssignment)+parseAssignment ParseArgs {..} =+    ParseAssignment <$$>+    ((left (show :: PathParseException -> String)) <$>+     try (resolveFile' parseFilePath))++parse :: ParseAssignment -> IO ()+parse ParseAssignment {..} = do+    errOrFile <- parseFile fileToParse+    case errOrFile of+        Left err -> die $ formatParseError err+        Right _ -> pure ()++formatParseError :: ParseError -> String+formatParseError (ParseError pe) = show pe++parseFile :: Path Abs File -> IO (Either ParseError SparkFile)+parseFile file = (left ParseError . parseCardFile file) <$> readFile file
+ src/SuperUserSpark/Parser/Internal.hs view
@@ -0,0 +1,267 @@+module SuperUserSpark.Parser.Internal where++import Import++import Data.List (isSuffixOf)+import SuperUserSpark.Constants+import SuperUserSpark.CoreTypes+import SuperUserSpark.Language.Types+import Text.Parsec+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++parseFromSource :: Parser a -> Path Abs File -> String -> Either ParseError a+parseFromSource parser file = parse parser $ toFilePath file++--[ Language ]--+sparkFile :: Parser [Card]+sparkFile = do+    clean <- eatComments+    setInput clean+    resetPosition+    cards++cards :: Parser [Card]+cards = card `sepEndBy1` whitespace++resetPosition :: Parser ()+resetPosition = do+    pos <- getPosition+    setPosition $ setSourceColumn (setSourceLine pos 1) 1++card :: Parser Card+card = do+    whitespace+    skip $ string keywordCard+    whitespace+    name <- cardNameP+    whitespace+    b <- block+    whitespace+    return $ Card name b++declarations :: Parser [Declaration]+declarations = (inLineSpace declaration) `sepEndBy` delim++declaration :: Parser Declaration+declaration =+    choice $+    map+        try+        [ block+        , alternatives+        , sparkOff+        , intoDir+        , outOfDir+        , deploymentKindOverride+        , deployment+        ]++block :: Parser Declaration+block =+    do ds <- inBraces $ inWhiteSpace declarations+       return $ Block ds+       <?> "block"++sparkOff :: Parser Declaration+sparkOff =+    do skip $ string keywordSpark+       linespace+       ref <- cardReference+       return $ SparkOff ref+       <?> "sparkoff"++compilerCardReference :: Parser CardFileReference+compilerCardReference = unprefixedCardFileReference++compiledCardReference :: Parser FilePath+compiledCardReference = do+    skip $ string "compiled"+    skip linespace+    filepath++cardReference :: Parser CardReference+cardReference = try goName <|> try goFile <?> "card reference"+  where+    goName = cardNameReference >>= return . CardName+    goFile = cardFileReference >>= return . CardFile++cardNameReference :: Parser CardNameReference+cardNameReference =+    do skip $ string keywordCard+       linespace+       name <- cardNameP+       return $ CardNameReference name+       <?> "card name reference"++cardNameP :: Parser CardName+cardNameP = identifier <?> "card name"++cardFileReference :: Parser CardFileReference+cardFileReference = do+    skip $ string keywordFile+    skip linespace+    unprefixedCardFileReference++unprefixedCardFileReference :: Parser CardFileReference+unprefixedCardFileReference =+    do fp <- filepath+       linespace+       mn <- optionMaybe $ try cardNameP+       return $+           case mn of+               Nothing -> CardFileReference fp Nothing+               Just cn -> CardFileReference fp (Just $ CardNameReference cn)+       <?> "card file reference"++intoDir :: Parser Declaration+intoDir =+    do skip $ string keywordInto+       linespace+       dir <- directory+       return $ IntoDir dir+       <?> "into directory declaration"++outOfDir :: Parser Declaration+outOfDir =+    do skip $ string keywordOutof+       linespace+       dir <- directory+       return $ OutofDir dir+       <?> "outof directory declaration"++deploymentKindOverride :: Parser Declaration+deploymentKindOverride =+    do skip $ string keywordKindOverride+       linespace+       kind <- try copy <|> link+       return $ DeployKindOverride kind+       <?> "deployment kind override"+  where+    copy = string keywordCopy >> return CopyDeployment+    link = string keywordLink >> return LinkDeployment++shortDeployment :: Parser Declaration+shortDeployment = do+    source <- try directory <|> filepath+    return $ Deploy source source Nothing++longDeployment :: Parser Declaration+longDeployment = do+    source <- filepath+    linespace+    kind <- deploymentKind+    linespace+    dest <- filepath+    return $ Deploy source dest kind++deployment :: Parser Declaration+deployment = try longDeployment <|> shortDeployment <?> "deployment"++deploymentKind :: Parser (Maybe DeploymentKind)+deploymentKind = try link <|> try copy <|> def <?> "deployment kind"+  where+    link = string linkKindSymbol >> return (Just LinkDeployment)+    copy = string copyKindSymbol >> return (Just CopyDeployment)+    def = string unspecifiedKindSymbol >> return Nothing++alternatives :: Parser Declaration+alternatives = do+    skip $ string keywordAlternatives+    linespace+    ds <- directory `sepBy1` linespace+    return $ Alternatives ds++-- [ FilePaths ]--+filepath :: Parser FilePath+filepath = do+    i <- identifier <?> "Filepath"+    if "/" `isSuffixOf` i+        then unexpected "slash at the end"+        else return i++directory :: Parser Directory+directory = filepath <?> "Directory"++--[ Comments ]--+comment :: Parser String+comment = try lineComment <|> try blockComment <?> "Comment"++lineComment :: Parser String+lineComment =+    (<?> "Line comment") $ do+        skip $ try $ string lineCommentStr+        anyChar `manyTill` eol++blockComment :: Parser String+blockComment =+    (<?> "Block comment") $ do+        skip $ try $ string start+        anyChar `manyTill` (try $ string stop)+  where+    (start, stop) = blockCommentStrs++notComment :: Parser String+notComment = manyTill anyChar (lookAhead ((skip comment) <|> eof))++eatComments :: Parser String+eatComments = do+    optional comment+    xs <- notComment `sepBy` comment+    optional comment+    let withoutComments = concat xs+    return withoutComments++--[ Identifiers ]--+identifier :: Parser String+identifier = try quotedIdentifier <|> plainIdentifier++plainIdentifier :: Parser String+plainIdentifier =+    many1 $+    noneOf $ quotesChar : lineDelimiter ++ whitespaceChars ++ bracesChars++quotedIdentifier :: Parser String+quotedIdentifier = inQuotes $ many $ noneOf $ quotesChar : endOfLineChars++--[ Delimiters ]--+inBraces :: Parser a -> Parser a+inBraces = between (char '{') (char '}')++inQuotes :: Parser a -> Parser a+inQuotes = between (char quotesChar) (char quotesChar)++delim :: Parser ()+delim = try (skip $ string lineDelimiter) <|> go+  where+    go = do+        eol+        whitespace++--[ Whitespace ]--+inLineSpace :: Parser a -> Parser a+inLineSpace = between linespace linespace++inWhiteSpace :: Parser a -> Parser a+inWhiteSpace = between whitespace whitespace++linespace :: Parser ()+linespace = skip $ many $ oneOf linespaceChars++whitespace :: Parser ()+whitespace = skip $ many $ oneOf whitespaceChars++eol :: Parser ()+eol = skip newline_+  where+    newline_ =+        try (string "\r\n") <|> try (string "\n") <|>+        string "\r" <?> "end of line"++--[ Utils ]--+skip :: Parser a -> Parser ()+skip p = p >> return ()
+ src/SuperUserSpark/Parser/Types.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-}++module SuperUserSpark.Parser.Types where++import Import++import qualified Text.Parsec as Parsec++data ParseAssignment = ParseAssignment+    { fileToParse :: Path Abs File+    } deriving (Show, Eq, Generic)++instance Validity ParseAssignment++data ParseSettings =+    ParseSettings+    deriving (Show, Eq, Generic)++instance Validity ParseSettings++newtype ParseError =+    ParseError Parsec.ParseError+    deriving (Show, Eq, Generic)++instance Validity ParseError where+    isValid (ParseError _) = True
+ src/SuperUserSpark/PreCompiler.hs view
@@ -0,0 +1,58 @@+module SuperUserSpark.PreCompiler where++import Import++import SuperUserSpark.Language.Types+import SuperUserSpark.PreCompiler.Types+import SuperUserSpark.Utils++preCompileChecks :: Card -> [PreCompileError]+preCompileChecks c = runIdentity $ execWriterT $ cleanCard c++dirty :: String -> Precompiler ()+dirty s = tell [PreCompileError $ "Precompilation check failed: " ++ s]++cleanCard :: Card -> Precompiler ()+cleanCard (Card name d) = do+    cleanCardName name+    cleanDeclaration d++cleanDeclaration :: Declaration -> Precompiler ()+cleanDeclaration (Deploy src dst _) = do+    cleanFilePath src+    cleanFilePath dst+cleanDeclaration (SparkOff cr) = cleanCardReference cr+cleanDeclaration (IntoDir dir) = cleanFilePath dir+cleanDeclaration (OutofDir dir) = cleanFilePath dir+cleanDeclaration (DeployKindOverride _) = return () -- Nothing can go wrong.+cleanDeclaration (Alternatives fs) = mapM_ cleanFilePath fs+cleanDeclaration (Block ds) = mapM_ cleanDeclaration ds++cleanCardReference :: CardReference -> Precompiler ()+cleanCardReference (CardFile cfr) = cleanCardFileReference cfr+cleanCardReference (CardName cnr) = cleanCardNameReference cnr++cleanCardFileReference :: CardFileReference -> Precompiler ()+cleanCardFileReference (CardFileReference fp mcnr) = do+    cleanFilePath fp+    case mcnr of+        Nothing -> return ()+        Just cnr -> cleanCardNameReference cnr++cleanCardNameReference :: CardNameReference -> Precompiler ()+cleanCardNameReference (CardNameReference cn) = cleanCardName cn++cleanCardName :: CardName -> Precompiler ()+cleanCardName n+    | containsNewline n =+        dirty $ "Card name contains newline character(s): " ++ n+    | otherwise = return ()++cleanFilePath :: FilePath -> Precompiler ()+cleanFilePath [] = dirty "Empty filepath"+cleanFilePath fp+    | containsNewline fp =+        dirty $ "Filepath contains newline character(s): " ++ fp+    | containsMultipleConsequtiveSlashes fp =+        dirty $ "Filepath contains multiple consequtive slashes: " ++ fp+    | otherwise = return ()
+ src/SuperUserSpark/PreCompiler/Types.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE DeriveGeneric #-}++module SuperUserSpark.PreCompiler.Types where++import Import++newtype PreCompileError =+    PreCompileError String+    deriving (Show, Eq, Generic)++instance Validity PreCompileError++type Precompiler = WriterT [PreCompileError] Identity
+ src/SuperUserSpark/Utils.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module SuperUserSpark.Utils where++import Import++import Data.List (isInfixOf)+import qualified System.Directory as D (createDirectoryIfMissing)++incase+    :: MonadReader c m+    => (c -> Bool) -> m () -> m ()+incase bf func = do+    b <- asks bf+    when b func++incaseElse+    :: MonadReader c m+    => (c -> Bool) -> m a -> m a -> m a+incaseElse bf funcif funcelse = do+    b <- asks bf+    if b+        then funcif+        else funcelse++containsNewline :: String -> Bool+containsNewline f = any (\c -> elem c f) ['\n', '\r']++containsMultipleConsequtiveSlashes :: String -> Bool+containsMultipleConsequtiveSlashes = isInfixOf "//"++(&&&) :: (a -> Bool) -> (a -> Bool) -> a -> Bool+(&&&) f g = \a -> f a && g a++(<$$>) :: (a -> b) -> IO (Either e a) -> IO (Either e b)+(<$$>) f fa = do+    a <- fa+    pure $ f <$> a++(<**>) :: IO (Either e (a -> b)) -> IO (Either e a) -> IO (Either e b)+(<**>) fa fb = do+    e1 <- fa+    e2 <- fb+    pure $ e1 <*> e2
− src/Types.hs 
@@ -1,49 +0,0 @@-module Types-    ( module Types-    , module CoreTypes-    , module Monad-    , module Config.Types--    , module Control.Monad.Except-    , module Control.Monad.IO.Class-    , module Control.Monad.Reader-    , module Control.Monad.State-    , module Control.Monad.Writer-    , module Control.Monad.Trans-    , module Control.Monad.Identity-    , module Text.Parsec--    , module Debug.Trace-    ) where--import           Control.Monad.Except   (ExceptT, mapExceptT, runExceptT,-                                         throwError, withExceptT)-import           Control.Monad.Identity (Identity, runIdentity)-import           Control.Monad.IO.Class (MonadIO (..), liftIO)-import           Control.Monad.Reader   (MonadReader (..), ReaderT, ask, asks,-                                         mapReaderT, runReaderT)-import           Control.Monad.State    (MonadState (..), StateT, evalStateT,-                                         execStateT, get, gets, modify, put,-                                         runStateT)-import           Control.Monad.Trans    (lift)-import           Control.Monad.Writer   (MonadWriter (..), WriterT, execWriterT,-                                         runWriterT, tell)-import           Debug.Trace--import           Text.Parsec            (ParseError)--import           Config.Types-import           CoreTypes-import           Monad-----[ Options ]----data GlobalOptions = GlobalOptions-    { opt_output              :: Maybe FilePath-    , opt_kind                :: Maybe DeploymentKind-    , opt_overrride           :: Maybe DeploymentKind-    , opt_replace_links       :: Bool-    , opt_replace_files       :: Bool-    , opt_replace_directories :: Bool-    , opt_replace             :: Bool-    , opt_debug               :: Bool-    } deriving (Show, Eq)
− src/Utils.hs 
@@ -1,44 +0,0 @@-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE MultiParamTypeClasses #-}-module Utils where--import           Control.Monad    (when)-import           Data.List        (isInfixOf)-import qualified System.Directory as D (createDirectoryIfMissing)-import           System.Exit      (exitFailure)-import           System.IO        (hPutStrLn, stderr)-import           Types--debug :: (MonadReader SparkConfig m, MonadIO m) => String -> m ()-debug str = incase (asks conf_debug) $ liftIO $ putStrLn str--incase :: MonadReader SparkConfig m => (SparkConfig -> Bool) -> m () -> m ()-incase bf func = do-    b <- asks bf-    when b func--incaseElse :: MonadReader SparkConfig m => (SparkConfig -> Bool) -> m a -> m a -> m a-incaseElse bf funcif funcelse = do-    b <- asks bf-    if b-    then funcif-    else funcelse--die :: String -> IO a-die err = hPutStrLn stderr err >> exitFailure--containsNewline :: String -> Bool-containsNewline f = any (\c -> elem c f) ['\n', '\r']--containsMultipleConsequtiveSlashes :: String -> Bool-containsMultipleConsequtiveSlashes = isInfixOf "//"--(&&&) :: (a -> Bool) -> (a -> Bool) -> a -> Bool-(&&&) f g = \a -> f a && g a--(|||) :: (a -> Bool) -> (a -> Bool) -> a -> Bool-(|||) f g = \a -> f a || g a--createDirectoryIfMissing :: FilePath -> IO ()-createDirectoryIfMissing = D.createDirectoryIfMissing True-
super-user-spark.cabal view
@@ -1,5 +1,5 @@ name:                super-user-spark-version:             0.3.2.0+version:             0.4.0.0 license:             MIT license-file:        LICENSE description:         Configure your dotfile deployment with a DSL.@@ -14,32 +14,36 @@ library   hs-source-dirs:   src   exposed-modules: -        Arguments-      , Check-      , Check.Internal-      , Check.Types-      , Compiler-      , Compiler.Internal-      , Compiler.Types-      , Compiler.Utils-      , Config.Types-      , Config-      , Constants-      , CoreTypes-      , Deployer-      , Deployer.Types-      , Deployer.Internal-      , Dispatch-      , Dispatch.Types-      , Language.Types-      , Monad-      , Parser-      , Parser.Internal-      , PreCompiler-      , Seed-      , Spark-      , Types-      , Utils+        SuperUserSpark+      , SuperUserSpark.Bake+      , SuperUserSpark.Bake.Internal+      , SuperUserSpark.Bake.Types+      , SuperUserSpark.Check+      , SuperUserSpark.Check.Internal+      , SuperUserSpark.Check.Types+      , SuperUserSpark.Compiler+      , SuperUserSpark.Compiler.Internal+      , SuperUserSpark.Compiler.Types+      , SuperUserSpark.Compiler.Utils+      , SuperUserSpark.Constants+      , SuperUserSpark.CoreTypes+      , SuperUserSpark.Deployer+      , SuperUserSpark.Deployer.Internal+      , SuperUserSpark.Deployer.Types+      , SuperUserSpark.Diagnose+      , SuperUserSpark.Diagnose.Internal+      , SuperUserSpark.Diagnose.Types+      , SuperUserSpark.Language.Types+      , SuperUserSpark.OptParse+      , SuperUserSpark.OptParse.Types+      , SuperUserSpark.Parser+      , SuperUserSpark.Parser.Internal+      , SuperUserSpark.Parser.Types+      , SuperUserSpark.PreCompiler+      , SuperUserSpark.PreCompiler.Types+      , SuperUserSpark.Utils+  other-modules:+        Import    ghc-options:              -Wall@@ -49,24 +53,28 @@        -fno-warn-name-shadowing    build-depends:   -        base                  >= 4.6   && < 5-      , aeson                 >= 0.8   && < 1.1-      , aeson-pretty          >= 0.7   && < 0.9+        base                  >= 4.9   && < 5+      , aeson                 >= 0.11  && < 1.2+      , aeson-pretty          >= 0.8   && < 0.9       , bytestring            >= 0.10  && < 0.11-      , directory             >= 1.2.5 && < 1.3+      , directory             >= 1.3   && < 1.4       , filepath              >= 1.4   && < 1.5       , mtl                   >= 2.2   && < 2.3-      , optparse-applicative  >= 0.11  && < 0.14+      , optparse-applicative  >= 0.13  && < 0.14       , parsec                >= 3.1.9 && < 3.2-      , process               >= 1.2   && < 1.5-      , pureMD5               >= 2.1   && < 2.2-      , shelly                >= 1.6   && < 1.7+      , process               >= 1.4   && < 1.6+      , hashable              >= 1.2   && < 1.3       , text                  >= 1.2   && < 1.3-      , transformers          >= 0.4   && < 0.6       , 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   default-language: Haskell2010+  default-extensions: NoImplicitPrelude -executable spark+executable super-user-spark   main-is:          Main.hs   hs-source-dirs:   app   ghc-options:      -Wall@@ -76,7 +84,7 @@                     -fno-warn-name-shadowing                     -threaded -rtsopts -with-rtsopts=-N   build-depends:   -        base                  >= 4.6   && < 5+        base                  >= 4.9   && < 5       , super-user-spark   default-language: Haskell2010   @@ -86,17 +94,34 @@   main-is:          MainTest.hs   hs-source-dirs:   test   other-modules:    -        CheckSpec-      , ParserSpec-      , CompilerSpec-      , DeployerSpec-      , SeedSpec-      , EndToEndSpec+        SuperUserSpark.BakeSpec+      , SuperUserSpark.Bake.Gen+      , SuperUserSpark.Check.Gen+      , SuperUserSpark.Check.TestUtils+      , SuperUserSpark.CheckSpec+      , SuperUserSpark.Compiler.Gen+      , SuperUserSpark.Compiler.TestUtils+      , SuperUserSpark.CompilerSpec+      , SuperUserSpark.Deployer.Gen+      , SuperUserSpark.DeployerSpec+      , SuperUserSpark.Diagnose.Gen+      , SuperUserSpark.Diagnose.TestUtils+      , SuperUserSpark.DiagnoseSpec+      , SuperUserSpark.EndToEnd.RegressionSpec+      , SuperUserSpark.EndToEndSpec+      , SuperUserSpark.Language.Gen+      , SuperUserSpark.OptParse.Gen+      , SuperUserSpark.Parser.Gen+      , SuperUserSpark.Parser.TestUtils+      , SuperUserSpark.ParserSpec+      , SuperUserSpark.PreCompiler.Gen+      , TestImport+      , TestUtils   build-depends:    -        base                  >= 4.6   && < 5+        base                  >= 4.9   && < 5       , super-user-spark-      , hspec                 >= 2.2   && < 2.4-      , hspec-core            >= 2.2   && < 2.4+      , hspec                 >= 2.2   && < 2.5+      , hspec-core            >= 2.2   && < 2.5       , HUnit                 >= 1.2   && < 1.6       , QuickCheck            >= 2.8   && < 2.10       , aeson                 @@ -108,10 +133,19 @@       , optparse-applicative         , parsec                       , process               -      , pureMD5               -      , shelly                       , 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+      , validity+      , validity-path+      , path+      , path-io+      , iostring+      , hashable   default-language:  Haskell2010+  default-extensions: NoImplicitPrelude
− test/CheckSpec.hs 
@@ -1,298 +0,0 @@-module CheckSpec where--import           Check.Gen          ()-import           Check.Internal-import           Check.TestUtils-import           Check.Types-import           Compiler.Types-import           Control.Monad      (forM_)-import           CoreTypes-import qualified Data.ByteString    as SB-import           Parser.Gen-import           System.Directory   (removeDirectoryRecursive, removeFile,-                                     withCurrentDirectory)-import           System.Posix.Files-import           Test.Hspec-import           Test.QuickCheck-import           TestUtils-import           Utils--spec :: Spec-spec = do-    diagnoseSpec-    checkSpec-    hashSpec--diagnoseSpec :: Spec-diagnoseSpec = do-    let sandbox = "test_sandbox"-    let setup = createDirectoryIfMissing sandbox-    let teardown = removeDirectoryRecursive sandbox--    beforeAll_ setup $ afterAll_ teardown $ do-        describe "diagnoseDeployment" $ do-            it "retains the filepaths and deploymentkind that it diagnoses for very simple filepaths" $ do-                once $ forAll (resize 5 $ listOf generateWord) $ \srcs -> do-                    forAll generateWord $ \dst -> do-                        forAll arbitrary $ \kind -> do-                            (Diagnosed dsrcs ddst dkind) <- diagnoseDeployment $ Put srcs dst kind-                            map diagnosedFilePath dsrcs `shouldBe` srcs-                            diagnosedFilePath ddst `shouldBe` dst-                            dkind `shouldBe` kind--            pend---        describe "diagnose" $ do-            it "retains the filepath that it diagnoses for very simple filepaths" $ do-                once $ forAll generateWord $ \fp -> do-                    (D dfp _ _) <- diagnose fp-                    dfp `shouldBe` fp--            pend---        describe "diagnoseFp" $ do-            it "figures out this test file" $ do-                withCurrentDirectory sandbox $ do-                    let file = "test.txt"-                    writeFile file "This is a test"-                    diagnoseFp file `shouldReturn` IsFile-                    removeFile file-                    diagnoseFp file `shouldReturn` Nonexistent--            it "figures out this test directory" $ do-                withCurrentDirectory sandbox $ do-                    let dir = "testdir"-                    createDirectoryIfMissing dir-                    diagnoseFp dir `shouldReturn` IsDirectory-                    removeDirectoryRecursive dir-                    diagnoseFp dir `shouldReturn` Nonexistent--            it "figures out this test symbolic link with a destination" $ do-                withCurrentDirectory sandbox $ do-                    let link = "testlink"-                    let file = "testfile"-                    writeFile file "This is a test"-                    createSymbolicLink file link--                    diagnoseFp file `shouldReturn` IsFile-                    diagnoseFp link `shouldReturn` IsLinkTo file--                    removeLink link-                    removeFile file--                    diagnoseFp link `shouldReturn` Nonexistent--            it "figures out this test symbolic link without a destination" $ do-                withCurrentDirectory sandbox $ do-                    let link = "testlink"-                    let file = "testfile"-                    createSymbolicLink file link--                    diagnoseFp file `shouldReturn` Nonexistent-                    diagnoseFp link `shouldReturn` IsLinkTo file--                    removeLink link--                    diagnoseFp file `shouldReturn` Nonexistent-                    diagnoseFp link `shouldReturn` Nonexistent--            it "figures out that /dev/null is weird" $ do-                diagnoseFp "/dev/null" `shouldReturn` IsWeird--            it "figures out that /dev/random is weird" $ do-                diagnoseFp "/dev/random" `shouldReturn` IsWeird--checkSpec :: Spec-checkSpec = parallel $ do-    checkSingleSpec-    checkDeploymentSpec--checkDeploymentSpec :: Spec-checkDeploymentSpec = do-    describe "checkDeployment" $ do-        it "says 'impossible' for deployments with an empty list of sources" $ do-            forAll arbitrary $ \dst ->-                forAll arbitrary $ \kind ->-                    shouldBeImpossible' $ Diagnosed [] dst kind--        it "says 'impossible' for deployments where all singles are impossible" $ do-            forAll (arbitrary `suchThat` (\(Diagnosed srcs dst kind) -> all (\src -> isImpossible $ checkSingle src dst kind) srcs)) $ \dd ->-                shouldBeImpossible' dd---        it "gives the same result as bestResult (just with a better error for empty lists)" $ do-            property $ \dd@(Diagnosed srcs dst kind) ->-                case (bestResult (map (\src -> checkSingle src dst kind) srcs), checkDeployment dd) of-                    (ImpossibleDeployment r1, ImpossibleDeployment r2) -> length r1 `shouldSatisfy` (<= (length r2))-                    (r1, r2) -> r1 `shouldBe` r2--    describe "bestResult" $ do-        it "says 'impossible' if all checkresults are impossible" $ do-            forAll (arbitrary `suchThat` all isImpossible) shouldBeImpossibleDeployment--        it "says 'done' if the first non-impossible in 'done'" $ do-            forAll (arbitrary `suchThat` (any (not . isImpossible)-                                     &&& (isDone . head . dropWhile isImpossible)))-              $ \dd -> bestResult dd `shouldSatisfy` deploymentIsDone--        it "says 'dirty' if the first non-impossible in 'dirty'" $ do-            forAll (arbitrary `suchThat` (any (not . isImpossible)-                                     &&& (isDirty . head . dropWhile isImpossible)))-              $ \dd -> bestResult dd `shouldSatisfy` dirtyDeployment--        it "says 'ready' if the first non-impossible in 'ready'" $ do-            forAll (arbitrary `suchThat` (any (not . isImpossible)-                                     &&& (isReady . head . dropWhile isImpossible)))-              $ \dd -> bestResult dd `shouldSatisfy` deploymentReadyToDeploy---checkSingleSpec :: Spec-checkSingleSpec = describe "checkSingle" $ do-    it "says 'impossible' if the source does not exist" $ do-        forAll (arbitraryWith Nonexistent) $ \src ->-            forAll arbitrary $ \dst ->-                forAll arbitrary $ \kind ->-                    shouldBeImpossible src dst kind--    it "says 'ready' if the source is a file and the destination does not exist" $ do-        forAll (arbitraryWith IsFile) $ \src ->-            forAll (arbitraryWith Nonexistent) $ \dst ->-                forAll arbitrary $ \kind ->-                    shouldBeReady src dst kind--    it "says 'dirty' if both the source and destination are files and it's a link deployment" $ do-        forAll (arbitraryWith IsFile) $ \src ->-            forAll (arbitraryWith IsFile) $ \dst ->-                shouldBeDirty src dst LinkDeployment $ CleanFile $ diagnosedFilePath dst--    it "says 'done' if both the source and destination are files and it's a copy deployment and the files are equal" $ do-        forAll arbitrary $ \src ->-            forAll arbitrary $ \dst ->-                forAll arbitrary $ \h1 ->-                    shouldBeDone (D src IsFile h1) (D dst IsFile h1) CopyDeployment--    it "says 'dirty' if both the source and destination are files and it's a copy deployment but the files are unequal" $ do-        forAll arbitrary $ \src ->-            forAll arbitrary $ \dst ->-                forAll arbitrary $ \h1 ->-                    forAll (arbitrary `suchThat` (/= h1)) $ \h2 ->-                        shouldBeDirty (D src IsFile h1) (D dst IsFile h2) CopyDeployment $ CleanFile dst--    it "says 'dirty' if the source is a file and the destination is a directory" $ do-        forAll (arbitraryWith IsFile) $ \src ->-            forAll (arbitraryWith IsDirectory) $ \dst ->-                forAll arbitrary $ \kind ->-                    shouldBeDirty src dst kind $ CleanDirectory $ diagnosedFilePath dst--    it "says 'dirty' if the source is a file and the destination is a link for a link deployment but the destination doesn't point to the source" $ do-        forAll (arbitraryWith IsFile) $ \src@(D srcp _ _) ->-            forAll (arbitrary `suchThat` (/= srcp)) $ \l ->-                forAll (arbitraryWith $ IsLinkTo l) $ \dst ->-                    shouldBeDirty src dst LinkDeployment $ CleanLink $ diagnosedFilePath dst--    it "says 'done' if the source is a file and the destination is a link for a link deployment and the destination points to the source" $ do-        forAll (arbitraryWith IsFile) $ \src@(D srcp _ _) ->-            forAll (arbitraryWith $ IsLinkTo srcp) $ \dst ->-                shouldBeDone src dst LinkDeployment--    it "says 'dirty' if the source is a file and the destination is a link for a copy deployment" $ do-        forAll (arbitraryWith IsFile)  $ \src ->-            forAll arbitrary $ \l ->-                forAll (arbitraryWith $ IsLinkTo l) $ \dst ->-                    shouldBeDirty src dst CopyDeployment $ CleanLink $ diagnosedFilePath dst--    it "says 'ready' if the source is a directory and the destination does not exist" $ do-        forAll (arbitraryWith IsDirectory) $ \src ->-            forAll (arbitraryWith Nonexistent) $ \dst ->-                forAll arbitrary $ \kind ->-                    shouldBeReady src dst kind--    it "says 'dirty' if the source is a directory and the destination is a file" $ do-        forAll (arbitraryWith IsDirectory) $ \src ->-            forAll (arbitraryWith IsFile) $ \dst ->-                forAll arbitrary $ \kind ->-                    shouldBeDirty src dst kind $ CleanFile $ diagnosedFilePath dst--    it "says 'dirty' if both the source and destination are directories for a link deployment" $ do-        forAll (arbitraryWith IsDirectory) $ \src ->-            forAll (arbitraryWith IsDirectory) $ \dst ->-                shouldBeDirty src dst LinkDeployment $ CleanDirectory $ diagnosedFilePath dst--    it "says 'done' if both the source and destination are directories and it's a copy deployment and the directories are equal" $ do-        forAll arbitrary $ \src ->-            forAll arbitrary $ \dst ->-                forAll arbitrary $ \h1 ->-                        shouldBeDone (D src IsDirectory h1) (D dst IsDirectory h1) CopyDeployment--    it "says 'dirty' if both the source and destination are directories and it's a copy deployment but the directories are unequal" $ do-        forAll arbitrary $ \src ->-            forAll arbitrary $ \dst ->-                forAll arbitrary $ \h1 ->-                    forAll (arbitrary `suchThat` (/= h1)) $ \h2 ->-                        shouldBeDirty (D src IsDirectory h1) (D dst IsDirectory h2) CopyDeployment $ CleanDirectory dst--    it "says 'dirty' if the source is a directory and the destination is a link for a link deployment but the destination doesn't point to the source" $ do-        forAll (arbitraryWith IsDirectory) $ \src@(D srcp _ _) ->-            forAll (arbitrary `suchThat` (/= srcp)) $ \l ->-                forAll (arbitraryWith $ IsLinkTo l) $ \dst ->-                    shouldBeDirty src dst LinkDeployment $ CleanLink $ diagnosedFilePath dst--    it "says 'done' if the source is a directory and the destination is a link for a link deployment and the destination points to the source" $ do-        forAll (arbitraryWith IsDirectory) $ \src@(D srcp _ _) ->-            forAll (arbitraryWith $ IsLinkTo srcp) $ \dst ->-                shouldBeDone src dst LinkDeployment--    it "says 'dirty' if the source is a directory and the destination is a link for a copy deployment" $ do-        forAll (arbitraryWith IsDirectory) $ \src ->-            forAll arbitrary $ \l ->-                forAll (arbitraryWith $ IsLinkTo l) $ \dst ->-                    shouldBeDirty src dst CopyDeployment $ CleanLink $ diagnosedFilePath dst--    it "says 'dirty' if the source is a link" $ do-        forAll arbitrary $ \l ->-            forAll (arbitraryWith $ IsLinkTo l) $ \src ->-                forAll arbitrary $ \dst ->-                    forAll arbitrary $ \kind ->-                        shouldBeImpossible src dst kind---    it "says 'dirty' for a weird source" $ do-        forAll (arbitraryWith IsWeird) $ \src ->-            forAll arbitrary $ \dst ->-                forAll arbitrary $ \kind ->-                    shouldBeImpossible src dst kind--    it "says 'dirty' for a weird destination" $ do-        forAll arbitrary $ \src ->-            forAll (arbitraryWith IsWeird) $ \dst ->-                forAll arbitrary $ \kind ->-                    shouldBeImpossible src dst kind--    it "works for these unit tests" $ do-        pending----hashSpec :: Spec-hashSpec = do-    tooManyFilesTest--tooManyFilesTest :: Spec-tooManyFilesTest = do-    let sandbox = "test_sandbox"-    let setup = createDirectoryIfMissing sandbox-    let teardown = removeDirectoryRecursive sandbox-    let aLot = 20000 :: Int-    let setupALotOfFiles = do-          forM_ [1..aLot] $ \i ->-            writeFile (sandbox ++ "/file" ++ show i) $ "This is file " ++ show i ++ ".\n"--    beforeAll_ setup $ afterAll_ teardown $ do-        describe "hashFilePath" $ do-            beforeAll_ setupALotOfFiles $ do-                it ("has no problem with hashing a directory of " ++ show aLot ++ " files") $ do-                    hashFilePath "test_sandbox" `shouldNotReturn` md5 SB.empty--
− test/CompilerSpec.hs 
@@ -1,364 +0,0 @@-module CompilerSpec where--import           Compiler-import           Compiler.TestUtils-import           Compiler.Types-import           Config-import           CoreTypes-import           Data.Either           (isLeft, isRight)-import           Data.List             (isPrefixOf)-import           Language.Gen          ()-import           Language.Types-import           PreCompiler-import           System.FilePath.Posix (takeExtension, (<.>), (</>))-import           Test.Hspec-import           Test.QuickCheck-import           TestUtils-import           Types-import           Utils--spec :: Spec-spec = parallel $ do-    singleCompileDecSpec-    precompileSpec-    hopTests-    exactTests-    compilerBlackBoxTests---precompileSpec :: Spec-precompileSpec = describe "pre-compilation" $ do-    cleanContentSpec--cleanContentSpec :: Spec-cleanContentSpec = do-    let validFp = arbitrary `suchThat` cleanBy cleanFilePath--    describe "cleanCard" $ do-        it "doesn't report any card with valid content and a valid name" $ do-            forAll (arbitrary `suchThat` cleanBy cleanCardName) $ \cn ->-              forAll (arbitrary `suchThat` cleanBy cleanDeclaration) $ \cc ->-                Card cn cc `shouldSatisfy` cleanBy cleanCard--    describe "cleanCardName" $ do-        pend--        it "doesn't report an emty card name" $ do-            "" `shouldSatisfy` cleanBy cleanCardName--        it "reports card names with newlines" $ do-            forAll (arbitrary `suchThat` containsNewlineCharacter) $ \s ->-                s `shouldNotSatisfy` cleanBy cleanCardName--    describe "cleanDeclaration" $ do-        describe "Deploy" $ do-            it "doesn't report Deploy declarations with valid filepaths" $ do-                forAll validFp $ \src ->-                  forAll validFp $ \dst ->-                    forAll arbitrary $ \kind ->-                      Deploy src dst kind `shouldSatisfy` cleanBy cleanDeclaration--            it "reports Deploy declarations with an invalid source" $ do-                forAll (arbitrary `suchThat` (not . cleanBy cleanFilePath)) $ \src ->-                  forAll validFp $ \dst ->-                    forAll arbitrary $ \kind ->-                      Deploy src dst kind `shouldNotSatisfy` cleanBy cleanDeclaration--            it "reports Deploy declarations with an invalid destination" $ do-                forAll validFp $ \src ->-                  forAll (arbitrary `suchThat` (not . cleanBy cleanFilePath)) $ \dst ->-                    forAll arbitrary $ \kind ->-                      Deploy src dst kind `shouldNotSatisfy` cleanBy cleanDeclaration--            pend--        describe "SparkOff" $ do-            it "reports SparkOff declarations with an invalid card reference" $ do-                forAll (arbitrary `suchThat` (not . cleanBy cleanCardReference)) $ \cr ->-                  SparkOff cr `shouldNotSatisfy` cleanBy cleanDeclaration--            it "doesn't report SparkOff declarations with a valid card reference" $ do-                forAll (arbitrary `suchThat` cleanBy cleanCardReference) $ \cr ->-                  SparkOff cr `shouldSatisfy` cleanBy cleanDeclaration--            pend--        describe "IntoDir" $ do-            it "reports IntoDir declarations with an invalid filepath" $ do-                forAll (arbitrary `suchThat` (not . cleanBy cleanFilePath)) $ \fp ->-                  IntoDir fp `shouldNotSatisfy` cleanBy cleanDeclaration--            it "doesn't report IntoDir declarations with a valid filepath" $ do-                forAll (arbitrary `suchThat` cleanBy cleanFilePath) $ \fp ->-                  IntoDir fp `shouldSatisfy` cleanBy cleanDeclaration--            pend--        describe "OutofDir" $ do-            it "reports OutofDir declarations with an invalid filepath" $ do-                forAll (arbitrary `suchThat` (not . cleanBy cleanFilePath)) $ \fp ->-                  OutofDir fp `shouldNotSatisfy` cleanBy cleanDeclaration--            it "doesn't report OutofDir declarations with a valid filepath" $ do-                forAll (arbitrary `suchThat` cleanBy cleanFilePath) $ \fp ->-                  OutofDir fp `shouldSatisfy` cleanBy cleanDeclaration--            pend--        describe "DeployKindOverride" $ do-            it "doesn't report any deployment kind override declarations" $ do-                forAll arbitrary $ \kind ->-                    DeployKindOverride kind `shouldSatisfy` cleanBy cleanDeclaration--            pend--        describe "Alternatives" $ do-            it "reports alternatives declarations with as much as a single invalid filepath" $ do-                forAll (arbitrary `suchThat` (any $ not . cleanBy cleanFilePath)) $ \fs ->-                    Alternatives fs `shouldNotSatisfy` cleanBy cleanDeclaration--            it "doesn't report alternatives declarations with valid filepaths" $ do-                forAll (arbitrary `suchThat` (all $ cleanBy cleanFilePath)) $ \fs ->-                    Alternatives fs `shouldSatisfy` cleanBy cleanDeclaration--            pend--        describe "Block" $ do-            it "reports block declarations with as much as a single invalid declaration inside" $ do-                forAll (arbitrary `suchThat` (any $ not . cleanBy cleanDeclaration)) $ \ds ->-                    Block ds `shouldNotSatisfy` cleanBy cleanDeclaration--            it "doesn't report any block declarations with valid declarations inside" $ do-                forAll (arbitrary `suchThat` (all $ cleanBy cleanDeclaration)) $ \ds ->-                    Block ds `shouldSatisfy` cleanBy cleanDeclaration---            pend--    describe "cleanCardReference" $ do-        it "works the same as cleanCardName separately" $ do-            forAll arbitrary $ \cnr ->-                cleanBy cleanCardNameReference cnr === cleanBy cleanCardReference (CardName cnr)--        it "works the same as cleanCardFile separately" $ do-            forAll arbitrary $ \cfr ->-                cleanBy cleanCardFileReference cfr === cleanBy cleanCardReference (CardFile cfr)--        pend--    describe "cleanCardNameReference" $ do-        it "reports card name references with an invalid card name" $ do-            forAll (arbitrary `suchThat` (not . cleanBy cleanCardName)) $ \cn ->-                CardNameReference cn `shouldNotSatisfy` cleanBy cleanCardNameReference--        it "doesn't report card name references with a valid card name" $ do-            forAll (arbitrary `suchThat` cleanBy cleanCardName) $ \cn ->-                CardNameReference cn `shouldSatisfy` cleanBy cleanCardNameReference--        pend--    describe "cleanCardFileReference" $ do-        it "reports card file references with an invalid filepath" $ do-            forAll (arbitrary `suchThat` (not . cleanBy cleanFilePath)) $ \fp ->-                forAll arbitrary $ \cn ->-                    CardFileReference fp cn `shouldNotSatisfy` cleanBy cleanCardFileReference--        it "reports card file references with an invalid card name" $ do-            forAll arbitrary $ \fp ->-                forAll (arbitrary `suchThat` (not . cleanBy cleanCardNameReference)) $ \cn ->-                    CardFileReference fp (Just cn) `shouldNotSatisfy` cleanBy cleanCardFileReference--        it "doesn't report card file references with a valid card name reference and valid filepath" $ do-            forAll (arbitrary `suchThat` cleanBy cleanFilePath) $ \fp ->-                forAll (arbitrary `suchThat` cleanBy cleanCardNameReference) $ \cn ->-                    CardFileReference fp (Just cn) `shouldSatisfy` cleanBy cleanCardFileReference--        pend---    describe "cleanFilePath" $ do-        it "reports empty an filepath" $ do-            filePathDirty []--        let nonNull = arbitrary `suchThat` (not . null)-        it "reports filepaths with newlines" $ do-            forAll (nonNull `suchThat` containsNewlineCharacter) filePathDirty--        let withoutNewlines = nonNull `suchThat` (not . containsNewlineCharacter)-        it "reports filepaths with multiple consequtive slashes" $ do-            once $ forAll (withoutNewlines `suchThat` containsMultipleConsequtiveSlashes) filePathDirty--        let c = filePathClean-        it "doesn't report these valid filepaths" $ do-            c "noextension"-            c ".bashrc"-            c "file.txt"-            c "Some file with spaces.doc"-            c "some/relative/filepath.file"----- TODO(syd) Use the default config to generate this!-defaultCompilerState :: CompilerState-defaultCompilerState = CompilerState-    { state_deployment_kind_override = Nothing-    , state_into = ""-    , state_outof_prefix = []-    }--singleCompileDecSpec :: Spec-singleCompileDecSpec = describe "compileDec" $ do-    let s = defaultCompilerState-    let c = defaultConfig-    let sc = singleShouldCompileTo c s--    let nonNull = arbitrary `suchThat` (not . null)-    let validFilePath = nonNull `suchThat` (not . containsNewlineCharacter)-    let easyFilePath = validFilePath `suchThat` (not . isPrefixOf ".")-    let validFp = arbitrary `suchThat` cleanBy cleanFilePath--    describe "Deploy" $ do-        it "uses the exact right text in source and destination when given valid filepaths without a leading dot" $ do-            forAll easyFilePath $ \from ->-                forAll easyFilePath $ \to ->-                    sc (Deploy from to Nothing) (Put [from] to LinkDeployment)--        it "handles filepaths with a leading dot correctly" $ do-            pending--        it "figures out the correct paths in these cases with default config and initial state" $ do-            let d = (Deploy "from" "to" $ Just LinkDeployment)-            sc d (Put ["from"] "to" LinkDeployment)--        it "uses the alternates correctly" $ do-            pending--        it "uses the into's correctly" $ do-            pending--        it "uses the outof's correctly" $ do-            pending--        pend--    describe "SparkOff" $ do-        it "adds a single card file reference to the list of cards to spark later" $ do-            forAll validFilePath $ \f ->-                let cr = CardFile $ CardFileReference f Nothing-                    d = SparkOff cr-                in compileSingleDec d s c `shouldBe` Right (s, ([], [cr]))--        it "adds any card reference to the list" $ do-            pending--        pend--    let shouldState = shouldResultInState c s-    describe "IntoDir" $ do-        it "adds the given directory to the into state" $ do-            forAll validFp $ \fp ->-                shouldState (IntoDir fp) $ s { state_into = fp }--        it "compounds with the input state" $ do-            pendingWith "Change the input state to an explicit list first"--        pend--    describe "OutofDir" $ do-        it "adds the given directory to the outof state" $ do-            forAll validFp $ \fp ->-                shouldState (OutofDir fp) $ s { state_outof_prefix = [Literal fp] }--        pend--    describe "DeployKindOverride" $ do-        it "modifies the internal deployment kind override" $ do-            property $ \kind -> shouldState (DeployKindOverride kind) $ s { state_deployment_kind_override = Just kind }--        pend--    describe "Block" $ do-        it "uses a separate scope for its sub-compilation" $ do-            property $ \ds -> shouldState (Block ds) s--        pend--    describe "Alternatives" $ do-        it "adds an alternatives prefix to the outof prefix in the compiler state" $ do-            forAll (listOf validFilePath) $ \fps ->-                shouldState (Alternatives fps) $ s { state_outof_prefix = [Alts fps] }--        pend--runDefaultSparker :: Sparker a -> IO (Either SparkError a)-runDefaultSparker func = flip runReaderT defaultConfig $ runExceptT $ func--hopTests :: Spec-hopTests = do-    describe "hop test" $ do-        let dir = "test_resources/hop_test"-        let root = dir </> "root.sus"-        let hop1 = dir </> "hop1dir" </> "hop1.sus"-        let hop2 = dir </> "hop1dir" </> "hop2dir" </> "hop2.sus"-        let hop3 = dir </> "hop1dir" </> "hop2dir" </> "hop3dir" </> "hop3.sus"-        it "compiles hop3 correctly" $ do-            r <- runDefaultSparker $ compileJob $ CardFileReference hop3 Nothing-            r `shouldBe` Right [Put ["z/delta"] "d/three" LinkDeployment]--        it "compiles hop2 correctly" $ do-            r <- runDefaultSparker $ compileJob $ CardFileReference hop2 Nothing-            r `shouldBe` Right-                [ Put ["y/gamma"] "c/two" LinkDeployment-                , Put ["hop3dir/z/delta"] "d/three" LinkDeployment-                ]--        it "compiles hop1 correctly" $ do-            r <- runDefaultSparker $ compileJob $ CardFileReference hop1 Nothing-            r `shouldBe` Right-                [ Put ["x/beta"] "b/one" LinkDeployment-                , Put ["hop2dir/y/gamma"] "c/two" LinkDeployment-                , Put ["hop2dir/hop3dir/z/delta"] "d/three" LinkDeployment-                ]--        it "compiles root correctly" $ do-            r <- runDefaultSparker $ compileJob $ CardFileReference root Nothing-            r `shouldBe` Right-                [ Put ["u/alpha"] "a/zero" LinkDeployment-                , Put ["hop1dir/x/beta"] "b/one" LinkDeployment-                , Put ["hop1dir/hop2dir/y/gamma"] "c/two" LinkDeployment-                , Put ["hop1dir/hop2dir/hop3dir/z/delta"] "d/three" LinkDeployment-                ]--exactTests :: Spec-exactTests = do-    describe "exact tests" $ do-        let dir = "test_resources/exact_compile_test_src"-        forFileInDirss [dir] $ \fp ->-            if takeExtension fp == ".res"-            then return ()-            else do-                it fp $ do-                    let orig = fp-                    let result = fp <.> "res"-                    ads <- runDefaultSparker $ compileJob $ CardFileReference orig Nothing-                    eds <- runDefaultSparker $ inputCompiled result-                    ads `shouldBe` eds----compilerBlackBoxTests :: Spec-compilerBlackBoxTests = do-    let tr = "test_resources"-    describe "Correct succesful compile examples" $ do-        let dirs = map (tr </>) ["shouldCompile", "hop_test"]-        forFileInDirss dirs $ \f -> do-            it f $ do-                r <- runDefaultSparker $ compileJob $ CardFileReference f Nothing-                r `shouldSatisfy` isRight--    describe "Correct unsuccesfull compile examples" $ do-        let dirs = map (tr </>) ["shouldNotParse", "shouldNotCompile"]-        forFileInDirss dirs $ \f -> do-            it f $ do-                r <- runDefaultSparker $ compileJob $ CardFileReference f Nothing-                r `shouldSatisfy` isLeft-
− test/DeployerSpec.hs 
@@ -1,263 +0,0 @@-module DeployerSpec where--import           Check.Internal-import           Check.Types-import           Config-import           Config.Types-import           Data.Either           (isLeft)-import           Data.Maybe            (isNothing)-import           Deployer.Internal-import           Deployer.Types-import           Monad-import           Parser.Gen-import           System.Directory      hiding (createDirectoryIfMissing)-import           System.FilePath.Posix ((</>))-import           System.Posix.Files-import           Test.Hspec-import           Test.QuickCheck-import           Utils--spec :: Spec-spec = do-    cleanSpec-    deploymentSpec-    completionSpec--cleanSpec :: Spec-cleanSpec = do-    let sandbox = "test_sandbox"-    let setup = createDirectoryIfMissing sandbox-    let teardown = removeDirectoryRecursive sandbox--    let clean :: SparkConfig -> CleanupInstruction -> IO ()-        clean conf ci = runSparker conf (performClean ci) `shouldReturn` Right ()--    beforeAll_ setup $ afterAll_ teardown $ do-        describe "performClean" $ do--            it "doesn't remove this file if that's not in the config" $ do-                let c = defaultConfig { conf_deploy_replace_files = False }-                withCurrentDirectory sandbox $ do-                    let file = "test.txt"-                    writeFile file "This is a test"-                    diagnoseFp file `shouldReturn` IsFile-                    clean c $ CleanFile file-                    diagnoseFp file `shouldReturn` IsFile-                    removeFile file-                    diagnoseFp file `shouldReturn` Nonexistent--            it "removes this file if that's in the config" $ do-                let c = defaultConfig { conf_deploy_replace_files = True }-                withCurrentDirectory sandbox $ do-                    let file = "test.txt"-                    writeFile file "This is a test"-                    diagnoseFp file `shouldReturn` IsFile-                    clean c $ CleanFile file-                    diagnoseFp file `shouldReturn` Nonexistent--            it "doesn't remove this directory if that's not in the config" $ do-                let c = defaultConfig { conf_deploy_replace_directories = False }-                withCurrentDirectory sandbox $ do-                    let dir = "testdirectory"-                    createDirectoryIfMissing dir-                    diagnoseFp dir `shouldReturn` IsDirectory-                    clean c $ CleanDirectory dir-                    diagnoseFp dir `shouldReturn` IsDirectory-                    removeDirectoryRecursive dir-                    diagnoseFp dir `shouldReturn` Nonexistent--            it "removes this directory if that's in the config" $ do-                let c = defaultConfig { conf_deploy_replace_directories = True }-                withCurrentDirectory sandbox $ do-                    let dir = "testdirectory"-                    createDirectoryIfMissing dir-                    diagnoseFp dir `shouldReturn` IsDirectory-                    clean c $ CleanDirectory dir-                    diagnoseFp dir `shouldReturn` Nonexistent--            it "doesn't remove this link if that's not in the config" $ do-                let c = defaultConfig { conf_deploy_replace_links = False }-                withCurrentDirectory sandbox $ do-                    let link = "testlink"-                    let file = "testfile"-                    writeFile file "This is a test"-                    createSymbolicLink file link-                    diagnoseFp link `shouldReturn` IsLinkTo file-                    clean c $ CleanLink link-                    diagnoseFp link `shouldReturn` IsLinkTo file-                    removeLink link-                    diagnoseFp link `shouldReturn` Nonexistent-                    removeFile file-                    diagnoseFp file `shouldReturn` Nonexistent--            it "removes this link with an existent source if that's in the config" $ do-                let c = defaultConfig { conf_deploy_replace_links = True }-                withCurrentDirectory sandbox $ do-                    let link = "testlink"-                    let file = "testfile"-                    writeFile file "This is a test"-                    createSymbolicLink file link-                    diagnoseFp link `shouldReturn` IsLinkTo file-                    clean c $ CleanLink link-                    diagnoseFp link `shouldReturn` Nonexistent-                    removeFile file-                    diagnoseFp file `shouldReturn` Nonexistent--            it "removes this link with a nonexistent source if that's in the config" $ do-                let c = defaultConfig { conf_deploy_replace_links = True }-                withCurrentDirectory sandbox $ do-                    let link = "testlink"-                    let file = "testfile"-                    createSymbolicLink file link-                    diagnoseFp link `shouldReturn` IsLinkTo file-                    diagnoseFp file `shouldReturn` Nonexistent-                    clean c $ CleanLink link-                    diagnoseFp link `shouldReturn` Nonexistent-                    diagnoseFp file `shouldReturn` Nonexistent--deploymentSpec :: Spec-deploymentSpec = do-    let sandbox = "test_sandbox"-    let setup = createDirectoryIfMissing sandbox-    let teardown = removeDirectoryRecursive sandbox--    beforeAll_ setup $ afterAll_ teardown $ do-        describe "copy" $ do-            it "succcesfully copies this file" $ do-                withCurrentDirectory sandbox $ do-                    let src = "testfile"-                    let dst = "testcopy"-                    writeFile src "This is a file."--                    diagnoseFp src `shouldReturn` IsFile-                    diagnoseFp dst `shouldReturn` Nonexistent--                    -- Under test-                    copy src dst--                    diagnoseFp src `shouldReturn` IsFile-                    diagnoseFp dst `shouldReturn` IsFile--                    dsrc <- diagnose src-                    ddst <- diagnose dst-                    diagnosedHashDigest ddst `shouldBe` diagnosedHashDigest dsrc--                    removeFile src-                    removeFile dst--                    diagnoseFp src `shouldReturn` Nonexistent-                    diagnoseFp dst `shouldReturn` Nonexistent--            it "succcesfully copies this directory" $ do-                withCurrentDirectory sandbox $ do-                    let src = "testdir"-                    let dst = "testcopy"-                    createDirectoryIfMissing src--                    diagnoseFp src `shouldReturn` IsDirectory-                    diagnoseFp dst `shouldReturn` Nonexistent--                    -- Under test-                    copy src dst--                    diagnoseFp src `shouldReturn` IsDirectory-                    diagnoseFp dst `shouldReturn` IsDirectory--                    dsrc <- diagnose src-                    ddst <- diagnose dst-                    diagnosedHashDigest ddst `shouldBe` diagnosedHashDigest dsrc--                    removeDirectoryRecursive src-                    removeDirectoryRecursive dst--                    diagnoseFp src `shouldReturn` Nonexistent-                    diagnoseFp dst `shouldReturn` Nonexistent--        describe "link" $ do-            it "successfully links this file" $ do-                withCurrentDirectory sandbox $ do-                    let src = "testfile"-                    let dst = "testlink"--                    diagnoseFp src `shouldReturn` Nonexistent-                    diagnoseFp dst `shouldReturn` Nonexistent--                    writeFile src "This is a test."--                    diagnoseFp src `shouldReturn` IsFile-                    diagnoseFp dst `shouldReturn` Nonexistent--                    -- Under test-                    link src dst--                    diagnoseFp src `shouldReturn` IsFile-                    diagnoseFp dst `shouldReturn` IsLinkTo src--                    removeFile src-                    removeLink dst--                    diagnoseFp src `shouldReturn` Nonexistent-                    diagnoseFp dst `shouldReturn` Nonexistent--            it "successfully links this directory" $ do-                withCurrentDirectory sandbox $ do-                    let src = "testdir"-                    let dst = "testlink"--                    diagnoseFp src `shouldReturn` Nonexistent-                    diagnoseFp dst `shouldReturn` Nonexistent--                    createDirectoryIfMissing src--                    diagnoseFp src `shouldReturn` IsDirectory-                    diagnoseFp dst `shouldReturn` Nonexistent--                    -- Under test-                    link src dst--                    diagnoseFp src `shouldReturn` IsDirectory-                    diagnoseFp dst `shouldReturn` IsLinkTo src--                    removeDirectoryRecursive src-                    removeLink dst--                    diagnoseFp src `shouldReturn` Nonexistent-                    diagnoseFp dst `shouldReturn` Nonexistent---completionSpec :: Spec-completionSpec = do-    describe "complete" $ do-        -- Necessary because not all utilities can handle paths with '~' in them.-        it "replaces the home directory as specified for simple home directories and simple paths" $ do-            forAll arbitrary $ \env ->-                forAll generateWord $ \home ->-                    forAll generateWord $ \fp ->-                        complete home env ("~" </> fp) `shouldBe` Right (home </> fp)--    describe "parseId" $ do-        it "Works for these cases" $ do-            parseId "" `shouldBe` []-            parseId "file" `shouldBe` [Plain "file"]-            parseId "something$(with)variable" `shouldBe` [Plain "something", Var "with", Plain "variable"]-            parseId "$(one)$(two)$(three)" `shouldBe` [Var "one", Var "two", Var "three"]--    describe "replaceId" $ do-        it "leaves plain ID's unchanged in any environment" $ do-            forAll arbitrary $ \env ->-                forAll arbitrary $ \s ->-                    replaceId env (Plain s) `shouldBe` Right s--        it "returns Left if a variable is not in the environment" $ do-            forAll arbitrary $ \var ->-                forAll (arbitrary `suchThat` (isNothing . lookup var)) $ \env ->-                    replaceId env (Var var) `shouldSatisfy` isLeft--        it "replaces a variable if it's in the environment" $ do-            forAll arbitrary $ \var ->-                forAll arbitrary $ \val ->-                    forAll (arbitrary `suchThat` (isNothing . lookup var)) $ \env1 ->-                        forAll (arbitrary `suchThat` (isNothing . lookup var)) $ \env2 ->-                            replaceId (env1 ++ [(var, val)] ++ env2) (Var var) `shouldBe` Right val--
− test/EndToEndSpec.hs 
@@ -1,82 +0,0 @@-module EndToEndSpec (spec) where--import           Spark-import           System.Directory      hiding (createDirectoryIfMissing)-import           System.Environment    (withArgs)-import           System.Exit           (ExitCode (ExitSuccess))-import           System.FilePath.Posix ((</>))-import           System.Posix.Files-import           Test.Hspec-import           Utils--spec :: Spec-spec = do-    helpTextSpec-    regularWorkflowSpec--helpTextSpec :: Spec-helpTextSpec = describe "help text test" $ do-    it "shows the help text without crashing" $ do-        withArgs ["--help"] spark `shouldThrow` (== ExitSuccess)--regularWorkflowSpec :: Spec-regularWorkflowSpec = do-    let sandbox = "test_sandbox"-    let setup = createDirectoryIfMissing sandbox-    let teardown = removeDirectoryRecursive sandbox--    let rsc = "test_resources" </> "end-to-end"--    beforeAll_ setup $ afterAll_ teardown $ do-        describe "standard bash card test" $ do-            let bashrsc = rsc </> "bash.sus"-            let bashrscres = rsc </> "bash.sus.res"-            let cardfile = sandbox </> "bash.sus"--            let up = do-                    copyFile bashrsc cardfile-                    withCurrentDirectory sandbox $ do-                        createDirectoryIfMissing "bash"-                        withCurrentDirectory "bash" $ do-                            writeFile "bash_aliases" "bash_aliases"-                            writeFile "bashrc" "bashrc"-                            writeFile "bash_profile" "bash_profile"--            let down = do-                    removeFile cardfile-                    withCurrentDirectory sandbox $ do-                        removeDirectoryRecursive "bash"---            beforeAll_ up $ afterAll_ down $ do-                it "parses correcty" $ do-                    withArgs ["parse", cardfile] spark `shouldReturn` ()--                it "compiles correctly" $ do-                    let outfile = sandbox </> "bash.sus.res"--                    withArgs ["compile", cardfile, "--output", outfile] spark `shouldReturn` ()--                    actual <- readFile outfile-                    expected <- readFile bashrscres-                    actual `shouldBe` expected--                it "checks without exceptions" $ do-                    withArgs ["check", cardfile] spark `shouldReturn` ()--                it "deploys correctly" $ do-                    withArgs ["deploy", cardfile] spark `shouldReturn` ()--                    let f1 = "subdir" </> ".bashrc"-                        f2 = "subdir" </> ".bash_aliases"-                        f3 = "subdir" </> ".bash_profile"--                    readFile f1 `shouldReturn` "bashrc"-                    readFile f2 `shouldReturn` "bash_aliases"-                    readFile f3 `shouldReturn` "bash_profile"--                    removeLink f1-                    removeLink f2-                    removeLink f3--
test/MainTest.hs view
@@ -1,11 +1,10 @@ {-# OPTIONS_GHC -F -pgmF hspec-discover #-}+ module MainTest where  import qualified Spec-import           Test.Hspec.Formatters-import           Test.Hspec.Runner+import Test.Hspec.Formatters+import Test.Hspec.Runner  main :: IO () main = hspecWith defaultConfig {configFormatter = Just progress} Spec.spec--
− test/ParserSpec.hs 
@@ -1,498 +0,0 @@-module ParserSpec where--import           CoreTypes-import           Data.Either           (isLeft, isRight)-import           Data.List             (intercalate)-import           Language.Types-import           Parser.Gen-import           Parser.Internal-import           Parser.TestUtils-import           System.FilePath.Posix ((</>))-import           Test.Hspec-import           Test.QuickCheck-import           TestUtils-import           Text.Parsec--spec :: Spec-spec = parallel $ do-    blankspaceParserTests-    enclosingCharacterTests-    delimiterTests-    identifierParserTests-    commentParserTests-    pathParserTests-    declarationParserTests-    parserBlackBoxTests---enclosingCharacterTests :: Spec-enclosingCharacterTests = do-    describe "inBraces" $ do-        it "succeeds for cases where we enclose braces around a string without braces" $ do-            forAll (listOf1 arbitrary `suchThat` (\c -> c /= "{" && c /= "}")) (\word ->-                parseShouldSucceedAs (inBraces $ string word) ("{" ++ word ++ "}") word)--    describe "inQuotes" $ do-        it "succeeds for cases where we enclose quotes around a string without quotes" $ do-            forAll (listOf1 arbitrary `suchThat` (/= "\"")) (\word ->-                parseShouldSucceedAs (inQuotes $ string word) ("\"" ++ word ++ "\"") word)--blankspaceParserTests :: Spec-blankspaceParserTests = do-    describe "eol" $ do-        let s = shouldSucceed eol-        it "succeeds for Linux line endings" $ do-            s "\n"-        it "succeeds for Windows line endings" $ do-            s "\r\n"-        it "succeeds for Mac line endings" $ do-            s "\r"-        let f = shouldFail eol-        it "fails for the empty string" $ do-            f ""-        it "fails for spaces" $ do-            forAll (listOf generateSpace) (\ss -> f ss)-        it "fails for tabs" $ do-            forAll (listOf generateTab) (\ss -> f ss)-        it "fails for linespace" $ do-            forAll generateLineSpace (\ls -> f ls)--    describe "linespace" $ do-        let s = shouldSucceed linespace-        it "succeeds for spaces" $ do-            forAll (listOf generateSpace) s-        it "succeeds for tabs" $ do-            forAll (listOf generateTab) s-        it "succeeds for mixtures of spaces and tabs" $ do-            forAll generateLineSpace s--        let f = shouldSucceed whitespace-        it "fails for line ending characters" $ do-            forAll (listOf $ oneof [generateCarriageReturn, generateLineFeed]) f-        it "fails for any non-linespace, even if there's linespace in it" $  do-            forAll (listOf1 generateNormalCharacter) (\ls ->-             forAll generateLineSpace (\ls1 ->-              forAll generateLineSpace (\ls2 ->-               shouldFail linespace (ls1 ++ ls ++ ls2))))---    describe "whitespace" $ do-        let s = shouldSucceed whitespace-        it "succeeds for spaces" $ do-            forAll (listOf generateSpace) s-        it "succeeds for tabs" $ do-            forAll (listOf generateTab) s-        it "succeeds carriage returns" $ do-            forAll (listOf generateCarriageReturn) s-        it "succeeds line feeds" $ do-            forAll (listOf generateLineFeed) s-        it "succeeds for mixtures of spaces, tabs, carriage returns and line feeds" $ do-            forAll generateWhiteSpace s--        it "fails for any non-whitespace, even if there's whitespace in it" $  do-            forAll (listOf1 generateNormalCharacter) (\ls ->-                        forAll generateWhiteSpace (\ws1 ->-                         forAll generateWhiteSpace (\ws2 ->-                            shouldFail whitespace (ws1 ++ ls ++ ws2))))---    describe "inLineSpace" $ do-        it "succeeds for cases where we append whitespace to the front and back of non-whitespace" $ do-            forAll generateLineSpace (\ws1 ->-              forAll generateLineSpace (\ws2 ->-                forAll (listOf1 generateNormalCharacter) (\ls ->-                    parseShouldSucceedAs (inLineSpace $ string ls) (ws1 ++ ls ++ ws2) ls)))--    describe "inWhiteSpace" $ do-        it "succeeds for cases where we append whitespace to the front and back of non-whitespace" $ do-            forAll generateWhiteSpace (\ws1 ->-              forAll generateWhiteSpace (\ws2 ->-                forAll (listOf1 generateNormalCharacter) (\ls ->-                    parseShouldSucceedAs (inWhiteSpace $ string ls) (ws1 ++ ls ++ ws2) ls)))--delimiterTests :: Spec-delimiterTests = do-    describe "delim" $ do-        it "succeeds on a semicolon" $ do-            shouldSucceed delim ";"-        it "succeeds on an eol" $ do-            once $ forAll (arbitrary `suchThat` succeeds eol) (shouldSucceed delim)--identifierParserTests :: Spec-identifierParserTests = do-    describe "plainIdentifier" $ do-        it "succeeds for generated plain identifiers" $ do-            forAll generatePlainIdentifier $ \(e, a) ->-                parseShouldSucceedAs plainIdentifier e a--        let pi = shouldSucceed plainIdentifier-        it "succeeds for these examples" $ do-            pi "bash"-            pi "card"-            pi ".bashrc"-            pi "xmonad.hs"--        it "fails for generated quoted identifiers" $ do-            forAll generateQuotedIdentifier $ \(e, _) ->-                shouldFail plainIdentifier e--    describe "quotedIdentifier" $ do-        it "succeeds for generated plain identifiers surrounded in quotes" $ do-            forAll generatePlainIdentifier $ \(e, a) ->-                parseShouldSucceedAs quotedIdentifier ("\"" ++ e ++ "\"") a-        it "succeeds for generated quoted identifiers" $ do-            forAll generateQuotedIdentifier $ \(e, a) ->-                parseShouldSucceedAs quotedIdentifier e a--        let pi i = parseShouldSucceedAs quotedIdentifier ("\"" ++ i ++ "\"") i-        it "succeeds for these examples" $ do-            pi "bashrc"-            pi "with spaces"--        it "fails for generated plain identifiers" $ do-            forAll generatePlainIdentifier $ \(e, _) ->-                shouldFail quotedIdentifier e--        it "fails for generated identifiers with just one quote" $ do-            forAll generatePlainIdentifier $ \(e, _) ->-                shouldFail quotedIdentifier ("\"" ++ e) .&&. shouldFail quotedIdentifier (e ++ "\"")--    describe "identifier" $ do-        it "succeeds for generated identifiers" $ do-            forAll generateIdentifier $ \(e, a) ->-                parseShouldSucceedAs identifier e a--commentParserTests :: Spec-commentParserTests = do-    describe "eatComments" $ do-        it "should succeed unchanged on anything without comments" $ do-            property $ \s -> (not $ succeedsAnywhere comment s) ==> parseShouldSucceedAs eatComments s s--        let (-=>) e a = parseShouldSucceedAs eatComments e a-        it "successfully removes comments in these strings" $ do-            "abc#def\nghi"                          -=> "abcghi"-            "abc# This is a bigger comment \r\nghi" -=> "abcghi"-            "abc[[def]]ghi"                         -=> "abcghi"-            "abc[[ This is a bigger comment ]]ghi"  -=> "abcghi"-            "Heavy[[use]]of#comments\n."            -=> "Heavyof."--    describe "notComment" $ do-        it "should succeed for any string that doesn't contain comments" $ do-            property $ \s -> (not $ succeedsAnywhere comment s) ==> parseShouldSucceedAs notComment s s--    describe "lineComment" $ do-        it "succeeds for generated line comments" $ do-            forAll generateLineComment $ \(e, a) -> parseShouldSucceedAs lineComment e a-        it "succeeds for these test cases" $ do-            parseShouldSucceedAs lineComment "#a\n" "a"-            parseShouldSucceedAs lineComment "# This is a comment\n" " This is a comment"-            parseShouldSucceedAs lineComment "## This is a comment with two comment signs.\n" "# This is a comment with two comment signs."-            parseShouldSucceedAs lineComment "# with other eol\r\n" " with other eol"--    describe "blockComment" $ do-        it "succeeds for generated block comments" $ do-            forAll generateBlockComment $ \(e, a) -> parseShouldSucceedAs blockComment e a-        it "succeeds of these test cases" $ do-            parseShouldSucceedAs blockComment "[[a]]" "a"-            parseShouldSucceedAs blockComment "[[ This is a block comment. ]]" " This is a block comment. "-            parseShouldSucceedAs blockComment "[[ [This is a [block] comment containing brackets.] ]]" " [This is a [block] comment containing brackets.] "--    describe "comment" $ do-        it "succeeds for generated line comments" $ do-            forAll generateLineComment $ \(e, a) -> parseShouldSucceedAs comment e a--        it "succeeds for generated block comments" $ do-            forAll generateBlockComment $ \(e, a) -> parseShouldSucceedAs comment e a--pathParserTests :: Spec-pathParserTests = do-    describe "filepath" $ do-        it "succeeds for generated filepaths" $ do-            forAll generateFilePath $ \(e, a) -> parseShouldSucceedAs filepath e a-        it "succeeds for this quoted filepath with a space in it" $ do-            parseShouldSucceedAs filepath "\"/home/user/with spaces\"" "/home/user/with spaces"--        let s = shouldSucceed filepath-        it "succeeds for this file without an extension" $ do-            s "withoutExtension"-        it "succeeds for this simple file" $ do-            s "test.txt"-        it "succeeds for this simple file with a long extension" $ do-            s "file.somelongextension"-        it "succeeds for this absolute filepath" $ do-            s "/home/user/test.txt"-        it "succeeds for this absolute filepath with a long extension" $ do-            s "/home/user/file.somelongextension"-        it "succeeds for this absolute filepath with multiple extensions" $ do-            s "/home/user/test.multiple.extensions"-        it "succeeds for this relative filepath with a double dot" $ do-            s "/home/user/../user/test.txt"--        let f = shouldFail filepath-        it "fails for just a slash" $ do-            f "/"-        it "fails for strings ending in a slash" $ do-            property $ \s -> f (s ++ "/")--    describe "directory" $ do-        it "succeeds for generated directories" $ do-            forAll generateDirectory $ \(e, a) -> parseShouldSucceedAs directory e a--        let s = shouldSucceed directory-        it "succeeds for the home directory" $ do-            s "~"-        it "succeeds for this relative directory" $ do-            s "directory"-        it "succeeds for this absolute directory" $ do-            s "/home/user"-        it "succeeds for these directories in the home directory" $ do-            s "~/.vim"-            s "~/Dropbox"-            s "~/.xmonad"--        let f = shouldFail directory-        it "fails for just a slash" $ do-            f "/"-        it "fails for strings ending in a slash" $ do-            property $ \s -> f (s ++ "/")---declarationParserTests :: Spec-declarationParserTests = do-    describe "cardName" $ do-        it "succeeds on every card name that we generate" $ do-            forAll generateCardName $ \(a, e) -> parseShouldSucceedAs cardNameP a e--    describe "card" $ do-        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-            forAll generateCardName $ \(a, e) ->-                parseShouldSucceedAs card ("card" ++ a ++ "{}") $ Card e (Block [])--        it "succeeds on empty cards with whitespace around the name" $ do-            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-            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-            forAll generateCardName $ \(a, _) ->-                forAll generateWhiteSpace $ \ws ->-                    shouldFail card ("card" ++ a ++ ws)--        it "succeeds on this complicated example" $ do-            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" $ Block-                    [-                      Alternatives ["$(HOST)", "shared"]-                    , Deploy "hello" "goodbye" (Just LinkDeployment)-                    , IntoDir "$(HOME)"-                    , OutofDir "depot"-                    , SparkOff (CardName (CardNameReference "othercard"))-                    , DeployKindOverride LinkDeployment-                    , Block [-                              Deploy "one" "more" (Just CopyDeployment)-                            , Deploy "source" "destination" Nothing-                            , Deploy "file" "file" Nothing-                            ]-                    ]--    describe "declarations" $ do-        it "succeeds for generated declarations'" $ do-            pending-        let s = parseShouldSucceedAs declarations-        it "succeeds for these cases" $ do-            s "into dir;outof dir" [IntoDir "dir", OutofDir "dir"]--    describe "declaration" $ do-        it "succeeds for generated declarations" $ do-            pending-        let s = parseShouldSucceedAs declaration-        it "succeeds for these cases" $ do-            s "into directory" (IntoDir "directory")-            s "outof \"other directory\"" (OutofDir "other directory")-            s "{}" (Block [])-            s "{{{};{};{}}}" (Block [Block [Block [], Block [], Block[]]])-            s "\"hi i'm a file\"c->iamthedestination" (Deploy "hi i'm a file" "iamthedestination" (Just CopyDeployment))--    describe "block" $ do-        it "succeeds for empty blocks" $ do-            parseShouldSucceedAs block "{}" (Block [])-        it "succeeds for a doubly nested empty block" $ do-            parseShouldSucceedAs block "{{}}" (Block [Block []])-        it "succeeds for a triply nested empty block" $ do-            parseShouldSucceedAs block "{{{}}}" (Block [Block [Block []]])--        let s = parseShouldSucceedAs block-        it "succeeds for these cases" $ do-            s "{into ~;bashrc -> .bashrc}" (Block [IntoDir "~", Deploy "bashrc" ".bashrc" Nothing])-            s "{\n    into \"~\"\n    \"xmonad\" -> \".xmonad\"\n}" (Block [IntoDir "~", Deploy "xmonad" ".xmonad" Nothing])--    describe "sparkOff" $ do-        it "succeeds for generated sparkOff declarations" $ do-            pending--        let s f g = parseShouldSucceedAs sparkOff f (SparkOff $ CardName $ CardNameReference g)-        it "succeeds for these cases" $ do-           s "spark card name" "name"-           s "sparkcardname" "name"-           s "spark card \"name with spaces\"" "name with spaces"--    describe "intoDir" $ do-        it "succeeds for generated into declarations" $ do-            forAll generateLineSpace $ \ls ->-              forAll generateDirectory $ \(d, da) ->-                parseShouldSucceedAs intoDir ("into" ++ ls ++ d) (IntoDir da)--        let s f g = parseShouldSucceedAs intoDir f (IntoDir g)-        it "succeeds for these cases" $ do-            s "into \"bash\"" "bash"-            s "into\t.xmonad" ".xmonad"-            s "into ~" "~"--    describe "outOfDir" $ do-        it "succeeds for generated outof declarations" $ do-            forAll generateLineSpace $ \ls ->-              forAll generateDirectory $ \(d, da) ->-                parseShouldSucceedAs outOfDir ("outof" ++ ls ++ d) (OutofDir da)--        let s f g = parseShouldSucceedAs outOfDir f (OutofDir g)-        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-            forAll (listOf1 generateDirectory) $ \ds ->-              let (des, das) = unzip ds in-              parseShouldSucceedAs alternatives ("alternatives" ++ " " ++ intercalate " " 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-                ==> parseShouldSucceedAs shortDeployment f (Deploy f f Nothing)--        it "succeeds for generated filepaths with an identity deployment" $ do-            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-                ==> parseShouldSucceedAs shortDeployment f (Deploy f f Nothing)--        it "succeeds for generated directories with an identity deployment" $ do-            forAll generateDirectory $ \(f,g) -> parseShouldSucceedAs shortDeployment f (Deploy g g Nothing)--        let s f = parseShouldSucceedAs shortDeployment f (Deploy f f Nothing)-        it "succeeds as-is for these cases" $ do-            s "file.txt"-            s "xmonad.hs"-            s "/home/user/.bashrc"--    describe "longDeployment" $ do-        it "succeeds for generated long deployments with quoted identifiers" $ do-            forAll generateDeploymentKindSymbol $ \dks ->-              forAll generateLineSpace $ \ls1 ->-                forAll generateLineSpace $ \ls2 ->-                  forAll generateQuotedIdentifier $ \(fp1,fp1a) ->-                    forAll generateQuotedIdentifier $ \(fp2,fp2a) ->-                      case parseWithoutSource deploymentKind dks of-                        Left _   -> fail "There was a problem with parsing the deployment kind"-                        Right dk -> parseShouldSucceedAs longDeployment (fp1 ++ ls1 ++ dks ++ ls2 ++ fp2) (Deploy fp1a fp2a dk)--        it "succeeds for single-space-separated long deployments with gerenated plain identifiers" $ do-            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)-        it "succeeds for these cases" $ do-            s "\"something with spaces\"c->/home/user/test.txt"-                "something with spaces"-                "/home/user/test.txt"-                (Just CopyDeployment)-            s "\"xmonad.hs\"l-> /home/user/.xmonad/xmonad.hs"-                "xmonad.hs"-                "/home/user/.xmonad/xmonad.hs"-                (Just LinkDeployment)-            s "bashrc\t->\t/home/user/.bashrc"-                "bashrc"-                "/home/user/.bashrc"-                Nothing---    describe "deploymentKind" $ do-        let (-=>) = parseShouldSucceedAs deploymentKind-        it "succeeds for the link deployment kind" $ do-            "l->" -=> Just LinkDeployment-        it "succeeds for the copy deployment kind" $ do-            "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->", "->"]) ==> shouldFail deploymentKind s--cardReferenceParserTests :: Spec-cardReferenceParserTests = do-    describe "compilerCardReference" $ do-        pend--    describe "deployerCardReference" $ do-        pend--    describe "compiledCardReference" $ do-        pend--    describe "cardReference" $ do-        pend--    describe "cardNameReference" $ do-        pend-        let s f g = parseShouldSucceedAs cardNameReference f (CardNameReference g)-        it "succeeds for these cases" $ do-           s "card name" "name"-           s "cardname" "name"-           s "card \"name with spaces\"" "name with spaces"--    describe "cardFileReference" $ do-        pend-        let s = parseShouldSucceedAs cardFileReference-        it "succeeds for these cases" $ do-            s "file card.sus" (CardFileReference "card.sus" Nothing)-            s "file card.sus name" (CardFileReference "card.sus" $ Just $ CardNameReference "name")--    describe "unprefixedCardFileReference" $ do-        pend---parserBlackBoxTests :: Spec-parserBlackBoxTests = do-    let tr = "test_resources"-    describe "Correct succesful parse examples" $ do-        let dirs = map (tr </>) ["shouldParse", "shouldCompile", "shouldNotCompile"]-        forFileInDirss dirs $ concerningContents $ \f contents -> do-            it f $ parseFromSource sparkFile f contents `shouldSatisfy` isRight--    describe "Correct unsuccesfull parse examples" $ do-        let dirs = map (tr </>) ["shouldNotParse"]-        forFileInDirss dirs $ concerningContents $ \f contents -> do-            it f $ parseFromSource sparkFile f contents `shouldSatisfy` isLeft---toplevelParserTests :: Spec-toplevelParserTests = do-    describe "sparkFile" $ do-        pend--    describe "resetPosition" $ do-        pend
− test/SeedSpec.hs 
@@ -1,24 +0,0 @@-module SeedSpec where--import           Compiler.Gen          ()-import           Compiler.TestUtils-import           Compiler.Types-import           PreCompiler-import           Seed-import           System.FilePath.Posix (isAbsolute)-import           Test.Hspec-import           Test.QuickCheck-import           TestUtils--spec :: Spec-spec = parallel $ do-    pureSeedSpec--pureSeedSpec :: Spec-pureSeedSpec = describe "seed" $ do-    it "ensures that sources are absolute if the seed is an absolute path" $ do-        once $ forAll (arbitrary `suchThat` cleanBy cleanFilePath `suchThat` isAbsolute) $ \fp ->-            forAll arbitrary $ \ds ->-                all (\d -> all (isAbsolute) $ deployment_srcs d) $ seed fp ds--    pend
+ test/SuperUserSpark/Bake/Gen.hs view
@@ -0,0 +1,34 @@+{-# OPTIONS_GHC -Wno-orphans #-}++module SuperUserSpark.Bake.Gen where++import TestImport++import SuperUserSpark.Bake.Types+import SuperUserSpark.Compiler.Gen ()++instance GenUnchecked BakeAssignment++instance GenValid BakeAssignment where+    genValid = BakeAssignment <$> genValid <*> genValid++instance GenUnchecked BakeCardReference++instance GenValid BakeCardReference++instance GenUnchecked BakeSettings++instance GenValid BakeSettings where+    genValid = BakeSettings <$> genValid <*> genValid <*> genValid++instance GenUnchecked BakeError++instance GenValid BakeError++instance GenUnchecked AbsP++instance GenValid AbsP++instance GenUnchecked ID++instance GenValid ID
+ test/SuperUserSpark/BakeSpec.hs view
@@ -0,0 +1,172 @@+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TemplateHaskell #-}++module SuperUserSpark.BakeSpec where++import TestImport++import Data.Either (isLeft)+import Data.Maybe (isNothing)++import qualified System.FilePath as FP+import System.Posix.Files (createSymbolicLink)++import SuperUserSpark.Bake+import SuperUserSpark.Bake.Gen ()+import SuperUserSpark.Bake.Internal+import SuperUserSpark.Bake.Types+import SuperUserSpark.Compiler.Types+import SuperUserSpark.OptParse.Gen ()+import SuperUserSpark.Parser.Gen++spec :: Spec+spec = do+    instanceSpec+    bakeSpec++instanceSpec :: Spec+instanceSpec =+    parallel $ do+        eqSpec @BakeAssignment+        genValidSpec @BakeAssignment+        eqSpec @BakeCardReference+        genValidSpec @BakeCardReference+        eqSpec @BakeSettings+        genValidSpec @BakeSettings+        eqSpec @BakeError+        genValidSpec @BakeError+        eqSpec @BakedDeployment+        genValidSpec @BakedDeployment+        jsonSpecOnValid @BakedDeployment+        eqSpec @AbsP+        genValidSpec @AbsP+        eqSpec @(DeploymentDirections AbsP)+        genValidSpec @(DeploymentDirections AbsP)+        jsonSpecOnValid @(DeploymentDirections AbsP)+        eqSpec @ID+        genValidSpec @ID++bakeSpec :: Spec+bakeSpec =+    parallel $ do+        describe "bakeFilePath" $ do+            it "works for these unit test cases without variables" $ do+                let b root fp s = do+                        absp <- AbsP <$> parseAbsFile s+                        rp <- parseAbsDir root+                        runReaderT+                            (runExceptT (bakeFilePath fp))+                            defaultBakeSettings {bakeRoot = rp} `shouldReturn`+                            Right absp+                b "/home/user/hello" "a/b/c" "/home/user/hello/a/b/c"+                b "/home/user/hello" "/home/user/.files/c" "/home/user/.files/c"+            it "works for a simple home-only variable situation" $ do+                forAll genValid $ \root -> do+                    let b home fp s = do+                            absp <- AbsP <$> parseAbsFile s+                            runReaderT+                                (runExceptT (bakeFilePath fp))+                                defaultBakeSettings+                                { bakeRoot = root+                                , bakeEnvironment = [("HOME", home)]+                                } `shouldReturn`+                                Right absp+                    b "/home/user" "~/a/b/c" "/home/user/a/b/c"+                    b "/home" "~/c" "/home/c"+            here <- runIO getCurrentDir+            let sandbox = here </> $(mkRelDir "test_sandbox")+            before_ (ensureDir sandbox) $+                after_ (removeDirRecur sandbox) $ do+                    it+                        "does not follow toplevel links when the completed path is relative" $ do+                        let file = $(mkRelFile "file")+                        let from = $(mkRelDir "from") </> file+                        let to = $(mkRelDir "to") </> file+                        withCurrentDir sandbox $ do+                            ensureDir $ parent $ sandbox </> from+                            writeFile (sandbox </> from) "contents"+                            ensureDir $ parent $ sandbox </> to+                            createSymbolicLink+                                (toFilePath $ sandbox </> from)+                                (toFilePath $ sandbox </> to)+                        let runBake f =+                                runReaderT+                                    (runExceptT f)+                                    (defaultBakeSettings+                                     {bakeRoot = sandbox, bakeEnvironment = []})+                        runBake (bakeFilePath (toFilePath to)) `shouldReturn`+                            (Right $ AbsP $ sandbox </> to)+                        runBake (bakeFilePath (toFilePath from)) `shouldReturn`+                            (Right $ AbsP $ sandbox </> from)+                    it+                        "follows directory-level links when the completed path is relative" $ do+                        let file = $(mkRelFile "file")+                        let fromdir = $(mkRelDir "from")+                        let from = fromdir </> file+                        let todir = $(mkRelDir "to")+                        let to = todir </> file+                        withCurrentDir sandbox $ do+                            ensureDir $ parent $ sandbox </> from+                            writeFile (sandbox </> from) "from contents"+                            ensureDir $ parent $ sandbox </> todir+                            createSymbolicLink+                                (FP.dropTrailingPathSeparator $+                                 toFilePath $ sandbox </> fromdir)+                                (FP.dropTrailingPathSeparator $+                                 toFilePath $ sandbox </> todir)+                            writeFile (sandbox </> to) "to contents"+                        let runBake f =+                                runReaderT+                                    (runExceptT f)+                                    (defaultBakeSettings+                                     {bakeRoot = sandbox, bakeEnvironment = []})+                        runBake (bakeFilePath (toFilePath to)) `shouldReturn`+                            (Right $ AbsP $ sandbox </> from)+                        runBake (bakeFilePath (toFilePath from)) `shouldReturn`+                            (Right $ AbsP $ sandbox </> from)+        describe "defaultBakeSettings" $+            it "is valid" $ isValid defaultBakeSettings+        describe "formatBakeError" $ do+            it "only ever produces valid strings" $+                producesValid formatBakeError+        describe "complete" $ do+            it "only ever produces a valid filepath" $ validIfSucceeds2 complete+            it+                "replaces the home directory as specified for simple home directories and simple paths" $ do+                forAll arbitrary $ \env ->+                    forAll generateWord $ \home ->+                        forAll generateWord $ \fp ->+                            complete (("HOME", home) : env) ("~" FP.</> fp) `shouldBe`+                            Right (home FP.</> fp)+        describe "parseId" $ do+            it "only ever produces valid IDs" $ producesValid parseId+            it "Figures out the home directory in these cases" $ do+                parseId "~" `shouldBe` [Var "HOME"]+                parseId "~/ab" `shouldBe` [Var "HOME", Plain "/ab"]+            it "Works for these cases" $ do+                parseId "" `shouldBe` []+                parseId "file" `shouldBe` [Plain "file"]+                parseId "something$(with)variable" `shouldBe`+                    [Plain "something", Var "with", Plain "variable"]+                parseId "$(one)$(two)$(three)" `shouldBe`+                    [Var "one", Var "two", Var "three"]+        describe "replaceId" $ do+            it "only ever produces valid FilePaths" $ validIfSucceeds2 replaceId+            it "leaves plain ID's unchanged in any environment" $+                forAll arbitrary $ \env ->+                    forAll arbitrary $ \s ->+                        replaceId env (Plain s) `shouldBe` Right s+            it "returns Left if a variable is not in the environment" $+                forAll arbitrary $ \var ->+                    forAll (arbitrary `suchThat` (isNothing . lookup var)) $ \env ->+                        replaceId env (Var var) `shouldSatisfy` isLeft+            it "replaces a variable if it's in the environment" $+                forAll arbitrary $ \var ->+                    forAll arbitrary $ \val ->+                        forAll (arbitrary `suchThat` (isNothing . lookup var)) $ \env1 ->+                            forAll+                                (arbitrary `suchThat` (isNothing . lookup var)) $ \env2 ->+                                replaceId+                                    (env1 ++ [(var, val)] ++ env2)+                                    (Var var) `shouldBe`+                                Right val
+ test/SuperUserSpark/Check/Gen.hs view
@@ -0,0 +1,69 @@+{-# OPTIONS_GHC -Wno-orphans #-}++module SuperUserSpark.Check.Gen where++import TestImport++import SuperUserSpark.Bake.Gen ()+import SuperUserSpark.Check.Types+import SuperUserSpark.Compiler.Gen ()+import SuperUserSpark.Diagnose.Gen ()+import SuperUserSpark.Language.Gen ()++instance GenUnchecked CheckAssignment++instance GenValid CheckAssignment where+    genValid = CheckAssignment <$> genValid <*> genValid++instance GenUnchecked CheckSettings++instance GenValid CheckSettings where+    genValid = CheckSettings <$> genValid++instance GenUnchecked CheckError++instance GenValid CheckError++instance GenUnchecked CheckResult where+    genUnchecked =+        oneof+            [ pure AlreadyDone+            , Ready <$> genUnchecked+            , Dirty <$> genUnchecked <*> genUnchecked <*> genUnchecked+            , Impossible <$> genUnchecked+            ]++instance GenValid CheckResult where+    genValid =+        oneof+            [ pure AlreadyDone+            , Ready <$> genValid+            , Dirty <$> genValid <*> genValid <*> genValid+            , Impossible <$> genValid+            ]++instance GenUnchecked Instruction++instance GenValid Instruction where+    genValid =+        oneof+            [ CopyFile <$> genValid <*> genValid+            , CopyDir <$> genValid <*> genValid+            , LinkFile <$> genValid <*> genValid+            , LinkDir <$> genValid <*> genValid+            ]++instance GenUnchecked CleanupInstruction++instance GenValid CleanupInstruction++instance GenUnchecked DeploymentCheckResult where+    genUnchecked =+        oneof+            [ pure DeploymentDone+            , ReadyToDeploy <$> genUnchecked+            , DirtySituation <$> genUnchecked <*> genUnchecked <*> genUnchecked+            , ImpossibleDeployment <$> genUnchecked+            ]++instance GenValid DeploymentCheckResult
+ test/SuperUserSpark/Check/TestUtils.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE TemplateHaskell #-}++module SuperUserSpark.Check.TestUtils where++import TestImport++import SuperUserSpark.Bake.Gen ()+import SuperUserSpark.Bake.Types+import SuperUserSpark.Check.Gen ()+import SuperUserSpark.Check.Internal+import SuperUserSpark.Check.Types+import SuperUserSpark.CoreTypes+import SuperUserSpark.Diagnose.Types++-- * Test utils for checkDeployment+shouldBeImpossible' :: DiagnosedDeployment -> Expectation+shouldBeImpossible' dd = checkDeployment dd `shouldSatisfy` impossibleDeployment++shouldBeImpossibleDeployment :: [CheckResult] -> Expectation+shouldBeImpossibleDeployment dd =+    bestResult dd `shouldSatisfy` impossibleDeployment++-- * Test utils for checkSingle+isDirty :: CheckResult -> Bool+isDirty (Dirty _ _ _) = True+isDirty _ = False++isReady :: CheckResult -> Bool+isReady (Ready _) = True+isReady _ = False++isDone :: CheckResult -> Bool+isDone AlreadyDone = True+isDone _ = False++isImpossible :: CheckResult -> Bool+isImpossible (Impossible _) = True+isImpossible _ = False++shouldBeDirty+    :: DiagnosedFp+    -> DiagnosedFp+    -> DeploymentKind+    -> CleanupInstruction+    -> Expectation+shouldBeDirty src dst kind eci =+    case checkSingle src dst kind of+        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+                    tp isrc `shouldBe` toPath (diagnosedFilePath src)+                    tp idst `shouldBe` toPath (diagnosedFilePath dst)+                    LinkDeployment `shouldBe` kind+        t ->+            expectationFailure $+            unlines+                [ "checkSingle"+                , show src+                , show dst+                , show kind+                , "should be dirty but is"+                , show t+                ]++shouldBeReady :: DiagnosedFp -> DiagnosedFp -> DeploymentKind -> Expectation+shouldBeReady src dst kind = checkSingle src dst kind `shouldSatisfy` isReady++shouldBeDone :: DiagnosedFp -> DiagnosedFp -> DeploymentKind -> Expectation+shouldBeDone src dst kind = checkSingle src dst kind `shouldSatisfy` isDone++shouldBeImpossible :: DiagnosedFp+                   -> DiagnosedFp+                   -> DeploymentKind+                   -> Expectation+shouldBeImpossible src dst kind =+    checkSingle src dst kind `shouldSatisfy` isImpossible++validWith :: Diagnostics -> Gen DiagnosedFp+validWith d = D <$> genValid <*> pure d <*> genValid
+ test/SuperUserSpark/CheckSpec.hs view
@@ -0,0 +1,253 @@+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TemplateHaskell #-}++module SuperUserSpark.CheckSpec where++import TestImport++import Control.Monad (forM_)+import Data.Hashable+import System.FilePath (dropTrailingPathSeparator)+import System.Posix.Files++import SuperUserSpark.Bake.Types+import SuperUserSpark.Check+import SuperUserSpark.Check.Gen ()+import SuperUserSpark.Check.Internal+import SuperUserSpark.Check.TestUtils+import SuperUserSpark.Check.Types+import SuperUserSpark.Compiler.Types+import SuperUserSpark.CoreTypes+import SuperUserSpark.Diagnose.Internal+import SuperUserSpark.Diagnose.TestUtils+import SuperUserSpark.Diagnose.Types+import SuperUserSpark.OptParse.Gen ()+import SuperUserSpark.Parser.Gen ()+import SuperUserSpark.Utils+import TestUtils++spec :: Spec+spec = do+    instanceSpec+    checkSpec++instanceSpec :: Spec+instanceSpec = do+    eqSpec @CheckSettings+    genValidSpec @CheckSettings+    eqSpec @Instruction+    genValidSpec @Instruction+    eqSpec @CleanupInstruction+    genValidSpec @CleanupInstruction+    eqSpec @DeploymentCheckResult+    genValidSpec @DeploymentCheckResult+    eqSpec @CheckResult+    genValidSpec @CheckResult++checkSpec :: Spec+checkSpec =+    parallel $ do+        describe "formatCheckError" $+            it "always produces valid strings" $ producesValid formatCheckError+        checkSingleSpec+        checkDeploymentSpec+        describe "formatDeploymentChecks" $+            it "always produces valid strings" $+            producesValid formatDeploymentChecks+        describe "formatDeploymentCheck" $+            it "always produces valid strings" $+            producesValid formatDeploymentCheck+        describe "formatInstruction" $+            it "always produces valid strings" $ producesValid formatInstruction+        describe "formatCleanupInstruction" $+            it "always produces valid strings" $+            producesValid formatCleanupInstruction++checkDeploymentSpec :: Spec+checkDeploymentSpec = do+    describe "checkDeployment" $ do+        it "always produces valid check results" $+            producesValidsOnValids checkDeployment+        it "says 'impossible' for deployments with an empty list of sources" $ do+            forAll genUnchecked $ \dst ->+                forAll genUnchecked $ \kind ->+                    shouldBeImpossible' $ Deployment (Directions [] dst) kind+        it "says 'impossible' for deployments where all singles are impossible" $ do+            forAll+                (genValid `suchThat`+                 (\(Deployment (Directions srcs dst) kind) ->+                      all (\src -> isImpossible $ checkSingle src dst kind) srcs)) $ \dd ->+                shouldBeImpossible' dd+        it+            "gives the same result as bestResult (just with a better error for empty lists)" $ do+            forAll genValid $ \dd@(Deployment (Directions srcs dst) kind) ->+                case ( bestResult (map (\src -> checkSingle src dst kind) srcs)+                     , checkDeployment dd) of+                    (ImpossibleDeployment r1, ImpossibleDeployment r2) ->+                        length r1 `shouldSatisfy` (<= (length r2))+                    (r1, r2) -> r1 `shouldBe` r2+    describe "bestResult" $ do+        it "always produces valid check results" $+            producesValidsOnValids bestResult+        it "says 'impossible' if all checkresults are impossible" $ do+            forAll+                (genValid `suchThat` all isImpossible)+                shouldBeImpossibleDeployment+        it "says 'done' if the first non-impossible in 'done'" $ do+            forAll+                (genValid `suchThat`+                 (any (not . isImpossible) &&&+                  (isDone . head . dropWhile isImpossible))) $ \dd ->+                bestResult dd `shouldSatisfy` deploymentIsDone+        it "says 'dirty' if the first non-impossible in 'dirty'" $ do+            forAll+                (genValid `suchThat`+                 (any (not . isImpossible) &&&+                  (isDirty . head . dropWhile isImpossible))) $ \dd ->+                bestResult dd `shouldSatisfy` dirtyDeployment+        it "says 'ready' if the first non-impossible in 'ready'" $ do+            forAll+                (genValid `suchThat`+                 (any (not . isImpossible) &&&+                  (isReady . head . dropWhile isImpossible))) $ \dd ->+                bestResult dd `shouldSatisfy` deploymentReadyToDeploy++checkSingleSpec :: Spec+checkSingleSpec =+    describe "checkSingle" $ do+        it "always produces valid CheckResults" $+            producesValidsOnValids3 checkSingle+        it "says 'impossible' if the source does not exist" $ do+            forAll (validWith Nonexistent) $ \src ->+                forAll genValid $ \dst ->+                    forAll genValid $ \kind -> shouldBeImpossible src dst kind+        it+            "says 'ready' if the source is a file and the destination does not exist" $ do+            forAll (validWith IsFile) $ \src ->+                forAll (validWith Nonexistent) $ \dst ->+                    forAll genValid $ \kind -> shouldBeReady src dst kind+        it+            "says 'dirty' if both the source and destination are files and it's a link deployment" $ do+            forAll (validWith IsFile) $ \src ->+                forAll (validWith IsFile) $ \dst ->+                    shouldBeDirty src dst LinkDeployment $+                    CleanFile $ unAbsP $ diagnosedFilePath dst+        it+            "says 'done' if both the source and destination are files and it's a copy deployment and the files are equal" $ do+            forAll genValid $ \src ->+                forAll genValid $ \dst ->+                    forAll genValid $ \h1 ->+                        shouldBeDone+                            (D src IsFile h1)+                            (D dst IsFile h1)+                            CopyDeployment+        it+            "says 'dirty' if both the source and destination are files and it's a copy deployment but the files are unequal" $ do+            forAll genValid $ \src ->+                forAll genValid $ \dst ->+                    forAll genValid $ \h1 ->+                        forAll (genValid `suchThat` (/= h1)) $ \h2 ->+                            shouldBeDirty+                                (D src IsFile h1)+                                (D dst IsFile h2)+                                CopyDeployment $+                            CleanFile $ unAbsP dst+        it+            "says 'dirty' if the source is a file and the destination is a directory" $ do+            forAll (validWith IsFile) $ \src ->+                forAll (validWith IsDirectory) $ \dst ->+                    forAll genValid $ \kind -> do+                        d <- parseAbsDir (toPath $ diagnosedFilePath dst)+                        shouldBeDirty src dst kind $ CleanDirectory d+        it+            "says 'dirty' if the source is a file and the destination is a link for a link deployment but the destination doesn't point to the source" $ do+            forAll (validWith IsFile) $ \src@(D srcp _ _) ->+                forAll (genValid `suchThat` (/= srcp)) $ \l ->+                    forAll (validWith $ IsLinkTo l) $ \dst ->+                        shouldBeDirty src dst LinkDeployment $+                        CleanLink $ unAbsP $ diagnosedFilePath dst+        it+            "says 'done' if the source is a file and the destination is a link for a link deployment and the destination points to the source" $ do+            forAll (validWith IsFile) $ \src@(D srcp _ _) ->+                forAll (validWith $ IsLinkTo srcp) $ \dst ->+                    shouldBeDone src dst LinkDeployment+        it+            "says 'dirty' if the source is a file and the destination is a link for a copy deployment" $ do+            forAll (validWith IsFile) $ \src ->+                forAll genValid $ \l ->+                    forAll (validWith $ IsLinkTo l) $ \dst ->+                        shouldBeDirty src dst CopyDeployment $+                        CleanLink $ unAbsP $ diagnosedFilePath dst+        it+            "says 'ready' if the source is a directory and the destination does not exist" $ do+            forAll (validWith IsDirectory) $ \src ->+                forAll (validWith Nonexistent) $ \dst ->+                    forAll genValid $ \kind -> shouldBeReady src dst kind+        it+            "says 'dirty' if the source is a directory and the destination is a file" $ do+            forAll (validWith IsDirectory) $ \src ->+                forAll (validWith IsFile) $ \dst ->+                    forAll genValid $ \kind ->+                        shouldBeDirty src dst kind $+                        CleanFile $ unAbsP $ diagnosedFilePath dst+        it+            "says 'dirty' if both the source and destination are directories for a link deployment" $ do+            forAll (validWith IsDirectory) $ \src ->+                forAll (validWith IsDirectory) $ \dst -> do+                    d <- parseAbsDir (toPath $ diagnosedFilePath dst)+                    shouldBeDirty src dst LinkDeployment $ CleanDirectory d+        it+            "says 'done' if both the source and destination are directories and it's a copy deployment and the directories are equal" $ do+            forAll genValid $ \src ->+                forAll genValid $ \dst ->+                    forAll genValid $ \h1 ->+                        shouldBeDone+                            (D src IsDirectory h1)+                            (D dst IsDirectory h1)+                            CopyDeployment+        it+            "says 'dirty' if both the source and destination are directories and it's a copy deployment but the directories are unequal" $ do+            forAll genValid $ \src ->+                forAll genValid $ \dst ->+                    forAll genValid $ \h1 ->+                        forAll (genValid `suchThat` (/= h1)) $ \h2 -> do+                            d <- parseAbsDir $ toPath dst+                            shouldBeDirty+                                (D src IsDirectory h1)+                                (D dst IsDirectory h2)+                                CopyDeployment $+                                CleanDirectory d+        it+            "says 'dirty' if the source is a directory and the destination is a link for a link deployment but the destination doesn't point to the source" $ do+            forAll (validWith IsDirectory) $ \src@(D srcp _ _) ->+                forAll (genValid `suchThat` (/= srcp)) $ \l ->+                    forAll (validWith $ IsLinkTo l) $ \dst ->+                        shouldBeDirty src dst LinkDeployment $+                        CleanLink $ unAbsP $ diagnosedFilePath dst+        it+            "says 'done' if the source is a directory and the destination is a link for a link deployment and the destination points to the source" $ do+            forAll (validWith IsDirectory) $ \src@(D srcp _ _) ->+                forAll (validWith $ IsLinkTo srcp) $ \dst ->+                    shouldBeDone src dst LinkDeployment+        it+            "says 'dirty' if the source is a directory and the destination is a link for a copy deployment" $ do+            forAll (validWith IsDirectory) $ \src ->+                forAll genValid $ \l ->+                    forAll (validWith $ IsLinkTo l) $ \dst ->+                        shouldBeDirty src dst CopyDeployment $+                        CleanLink $ unAbsP $ diagnosedFilePath dst+        it "says 'dirty' if the source is a link" $ do+            forAll genValid $ \l ->+                forAll (validWith $ IsLinkTo l) $ \src ->+                    forAll genValid $ \dst ->+                        forAll genValid $ \kind ->+                            shouldBeImpossible src dst kind+        it "says 'dirty' for a weird source" $ do+            forAll (validWith IsWeird) $ \src ->+                forAll genValid $ \dst ->+                    forAll genValid $ \kind -> shouldBeImpossible src dst kind+        it "says 'dirty' for a weird destination" $ do+            forAll genValid $ \src ->+                forAll (validWith IsWeird) $ \dst ->+                    forAll genValid $ \kind -> shouldBeImpossible src dst kind+        it "works for these unit tests" $ do pending
+ test/SuperUserSpark/Compiler/Gen.hs view
@@ -0,0 +1,60 @@+{-# OPTIONS_GHC -Wno-orphans #-}++module SuperUserSpark.Compiler.Gen where++import TestImport++import SuperUserSpark.Compiler.Types+import SuperUserSpark.Language.Gen ()+import SuperUserSpark.PreCompiler.Gen ()++instance GenUnchecked CompileAssignment++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++instance GenValid a =>+         GenValid (Deployment a) where+    genValid = Deployment <$> genValid <*> genValid++instance GenUnchecked a =>+         GenUnchecked (DeploymentDirections a)++instance GenValid a =>+         GenValid (DeploymentDirections a) where+    genValid = Directions <$> genValid <*> genValid++instance GenUnchecked PrefixPart++instance GenValid PrefixPart+++instance GenUnchecked CompilerState++instance GenValid CompilerState++instance GenUnchecked CompileError where+    genUnchecked =+        oneof+            [ PreCompileErrors <$> genUnchecked+            , DuringCompilationError <$> genUnchecked+            ]++instance GenValid CompileError+
+ test/SuperUserSpark/Compiler/TestUtils.hs view
@@ -0,0 +1,95 @@+module SuperUserSpark.Compiler.TestUtils where++import TestImport++import Data.Either (isLeft, isRight)++import SuperUserSpark.Compiler.Internal+import SuperUserSpark.Compiler.Types+import SuperUserSpark.Language.Types+import SuperUserSpark.PreCompiler+import SuperUserSpark.PreCompiler.Types++runPreCompiler :: Precompiler () -> [PreCompileError]+runPreCompiler pc = runIdentity $ execWriterT pc++cleanBy :: (a -> Precompiler ()) -> a -> Bool+cleanBy func a = null $ runPreCompiler $ func a++declarationClean :: Declaration -> IO ()+declarationClean d = d `shouldSatisfy` cleanBy cleanDeclaration++declarationDirty :: Declaration -> IO ()+declarationDirty d = d `shouldNotSatisfy` cleanBy cleanDeclaration++filePathDirty :: FilePath -> IO ()+filePathDirty fp = fp `shouldNotSatisfy` cleanBy cleanFilePath++filePathClean :: FilePath -> IO ()+filePathClean fp = fp `shouldSatisfy` cleanBy cleanFilePath++runPureCompiler :: CompileSettings -> PureCompiler a -> Either CompileError a+runPureCompiler c func = runIdentity $ runReaderT (runExceptT func) c++runInternalCompiler+    :: [Declaration]+    -> CompilerState+    -> CompileSettings+    -> Either CompileError (CompilerState, ([RawDeployment], [CardReference]))+runInternalCompiler ds s c =+    runPureCompiler c $ runWriterT $ execStateT (compileDecs ds) s++compileSingleDec+    :: Declaration+    -> CompilerState+    -> CompileSettings+    -> Either CompileError (CompilerState, ([RawDeployment], [CardReference]))+compileSingleDec d = runInternalCompiler [d]++compilationShouldSucceed :: [Declaration]+                         -> CompilerState+                         -> CompileSettings+                         -> IO ()+compilationShouldSucceed ds s c =+    runInternalCompiler ds s c `shouldSatisfy` isRight++compilationShouldFail :: [Declaration]+                      -> CompilerState+                      -> CompileSettings+                      -> IO ()+compilationShouldFail ds s c = runInternalCompiler ds s c `shouldSatisfy` isLeft++singleShouldFail :: CompileSettings -> CompilerState -> Declaration -> IO ()+singleShouldFail c s d = compilationShouldFail [d] s c++shouldCompileTo :: CompileSettings+                -> CompilerState+                -> [Declaration]+                -> [RawDeployment]+                -> IO ()+shouldCompileTo c s ds eds = do+    compilationShouldSucceed ds s c+    let Right (_, (ads, crs)) = runInternalCompiler ds s c+    ads `shouldBe` eds+    crs `shouldSatisfy` null++singleShouldCompileTo :: CompileSettings+                      -> CompilerState+                      -> Declaration+                      -> RawDeployment+                      -> IO ()+singleShouldCompileTo c s d eds = shouldCompileTo c s [d] [eds]++shouldResultInState :: CompileSettings+                    -> CompilerState+                    -> Declaration+                    -> CompilerState+                    -> IO ()+shouldResultInState c s d es = do+    compilationShouldSucceed [d] s c+    let Right (as, _) = runInternalCompiler [d] s c+    as `shouldBe` es++-- Filepath utils+containsNewlineCharacter :: String -> Bool+containsNewlineCharacter f = any (\c -> elem c f) ['\n', '\r']
+ test/SuperUserSpark/CompilerSpec.hs view
@@ -0,0 +1,422 @@+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TemplateHaskell #-}++module SuperUserSpark.CompilerSpec where++import TestImport++import Data.Either (isLeft, isRight)+import Data.List (isPrefixOf)+import System.FilePath.Posix ((<.>))++import SuperUserSpark.Compiler+import SuperUserSpark.Compiler.Gen ()+import SuperUserSpark.Compiler.Internal+import SuperUserSpark.Compiler.TestUtils+import SuperUserSpark.Compiler.Types+import SuperUserSpark.Compiler.Utils+import SuperUserSpark.CoreTypes+import SuperUserSpark.Language.Gen ()+import SuperUserSpark.Language.Types+import SuperUserSpark.OptParse.Gen ()+import SuperUserSpark.PreCompiler+import SuperUserSpark.Utils+import TestUtils++spec :: Spec+spec = do+    parallel $ do+        instanceSpec+        compileSpec+        singleCompileDecSpec+        precompileSpec+        compileUnitSpec+        utilsSpec+    hopTests+    exactTests+    compilerBlackBoxTests++precompileSpec :: Spec+precompileSpec = describe "pre-compilation" $ do cleanContentSpec++cleanContentSpec :: Spec+cleanContentSpec = do+    let validFp = genValid `suchThat` cleanBy cleanFilePath+    describe "cleanCard" $ do+        it "doesn't report any card with valid content and a valid name" $ do+            forAll (genValid `suchThat` cleanBy cleanCardName) $ \cn ->+                forAll (genValid `suchThat` cleanBy cleanDeclaration) $ \cc ->+                    Card cn cc `shouldSatisfy` cleanBy cleanCard+    describe "cleanCardName" $ do+        pend+        it "doesn't report an emty card name" $ do+            "" `shouldSatisfy` cleanBy cleanCardName+        it "reports card names with newlines" $ do+            forAll (genValid `suchThat` containsNewlineCharacter) $ \s ->+                s `shouldNotSatisfy` cleanBy cleanCardName+    describe "cleanDeclaration" $ do+        describe "Deploy" $ do+            it "doesn't report Deploy declarations with valid filepaths" $ do+                forAll validFp $ \src ->+                    forAll validFp $ \dst ->+                        forAll genValid $ \kind ->+                            Deploy src dst kind `shouldSatisfy`+                            cleanBy cleanDeclaration+            it "reports Deploy declarations with an invalid source" $ do+                forAll (genValid `suchThat` (not . cleanBy cleanFilePath)) $ \src ->+                    forAll validFp $ \dst ->+                        forAll genValid $ \kind ->+                            Deploy src dst kind `shouldNotSatisfy`+                            cleanBy cleanDeclaration+            it "reports Deploy declarations with an invalid destination" $ do+                forAll validFp $ \src ->+                    forAll (genValid `suchThat` (not . cleanBy cleanFilePath)) $ \dst ->+                        forAll genValid $ \kind ->+                            Deploy src dst kind `shouldNotSatisfy`+                            cleanBy cleanDeclaration+            pend+        describe "SparkOff" $ do+            it "reports SparkOff declarations with an invalid card reference" $ do+                forAll (genValid `suchThat` (not . cleanBy cleanCardReference)) $ \cr ->+                    SparkOff cr `shouldNotSatisfy` cleanBy cleanDeclaration+            it+                "doesn't report SparkOff declarations with a valid card reference" $ do+                forAll (genValid `suchThat` cleanBy cleanCardReference) $ \cr ->+                    SparkOff cr `shouldSatisfy` cleanBy cleanDeclaration+            pend+        describe "IntoDir" $ do+            it "reports IntoDir declarations with an invalid filepath" $ do+                forAll (genValid `suchThat` (not . cleanBy cleanFilePath)) $ \fp ->+                    IntoDir fp `shouldNotSatisfy` cleanBy cleanDeclaration+            it "doesn't report IntoDir declarations with a valid filepath" $ do+                forAll (genValid `suchThat` cleanBy cleanFilePath) $ \fp ->+                    IntoDir fp `shouldSatisfy` cleanBy cleanDeclaration+            pend+        describe "OutofDir" $ do+            it "reports OutofDir declarations with an invalid filepath" $ do+                forAll (genValid `suchThat` (not . cleanBy cleanFilePath)) $ \fp ->+                    OutofDir fp `shouldNotSatisfy` cleanBy cleanDeclaration+            it "doesn't report OutofDir declarations with a valid filepath" $ do+                forAll (genValid `suchThat` cleanBy cleanFilePath) $ \fp ->+                    OutofDir fp `shouldSatisfy` cleanBy cleanDeclaration+            pend+        describe "DeployKindOverride" $ do+            it "doesn't report any deployment kind override declarations" $ do+                forAll genValid $ \kind ->+                    DeployKindOverride kind `shouldSatisfy`+                    cleanBy cleanDeclaration+            pend+        describe "Alternatives" $ do+            it+                "reports alternatives declarations with as much as a single invalid filepath" $ do+                forAll (genValid `suchThat` (any $ not . cleanBy cleanFilePath)) $ \fs ->+                    Alternatives fs `shouldNotSatisfy` cleanBy cleanDeclaration+            it "doesn't report alternatives declarations with valid filepaths" $ do+                forAll (genValid `suchThat` (all $ cleanBy cleanFilePath)) $ \fs ->+                    Alternatives fs `shouldSatisfy` cleanBy cleanDeclaration+            pend+        describe "Block" $ do+            it+                "reports block declarations with as much as a single invalid declaration inside" $ do+                forAll+                    (genValid `suchThat` (any $ not . cleanBy cleanDeclaration)) $ \ds ->+                    Block ds `shouldNotSatisfy` cleanBy cleanDeclaration+            it+                "doesn't report any block declarations with valid declarations inside" $ do+                forAll (genValid `suchThat` (all $ cleanBy cleanDeclaration)) $ \ds ->+                    Block ds `shouldSatisfy` cleanBy cleanDeclaration+            pend+    describe "cleanCardReference" $ do+        it "works the same as cleanCardName separately" $ do+            forAll genValid $ \cnr ->+                cleanBy cleanCardNameReference cnr ===+                cleanBy cleanCardReference (CardName cnr)+        it "works the same as cleanCardFile separately" $ do+            forAll genValid $ \cfr ->+                cleanBy cleanCardFileReference cfr ===+                cleanBy cleanCardReference (CardFile cfr)+        pend+    describe "cleanCardNameReference" $ do+        it "reports card name references with an invalid card name" $ do+            forAll (genValid `suchThat` (not . cleanBy cleanCardName)) $ \cn ->+                CardNameReference cn `shouldNotSatisfy`+                cleanBy cleanCardNameReference+        it "doesn't report card name references with a valid card name" $ do+            forAll (genValid `suchThat` cleanBy cleanCardName) $ \cn ->+                CardNameReference cn `shouldSatisfy`+                cleanBy cleanCardNameReference+        pend+    describe "cleanCardFileReference" $ do+        it "reports card file references with an invalid filepath" $ do+            forAll (genValid `suchThat` (not . cleanBy cleanFilePath)) $ \fp ->+                forAll genValid $ \cn ->+                    CardFileReference fp cn `shouldNotSatisfy`+                    cleanBy cleanCardFileReference+        it "reports card file references with an invalid card name" $ do+            forAll genValid $ \fp ->+                forAll+                    (genValid `suchThat` (not . cleanBy cleanCardNameReference)) $ \cn ->+                    CardFileReference fp (Just cn) `shouldNotSatisfy`+                    cleanBy cleanCardFileReference+        it+            "doesn't report card file references with a valid card name reference and valid filepath" $ do+            forAll (genValid `suchThat` cleanBy cleanFilePath) $ \fp ->+                forAll (genValid `suchThat` cleanBy cleanCardNameReference) $ \cn ->+                    CardFileReference fp (Just cn) `shouldSatisfy`+                    cleanBy cleanCardFileReference+        pend+    describe "cleanFilePath" $ do+        it "reports empty an filepath" $ do filePathDirty []+        let nonNull = genValid `suchThat` (not . null)+        it "reports filepaths with newlines" $ do+            forAll (nonNull `suchThat` containsNewlineCharacter) filePathDirty+        let withoutNewlines =+                nonNull `suchThat` (not . containsNewlineCharacter)+        it "reports filepaths with multiple consequtive slashes" $ do+            once $+                forAll+                    (withoutNewlines `suchThat`+                     containsMultipleConsequtiveSlashes)+                    filePathDirty+        let c = filePathClean+        it "doesn't report these valid filepaths" $ do+            c "noextension"+            c ".bashrc"+            c "file.txt"+            c "Some file with spaces.doc"+            c "some/relative/filepath.file"++-- TODO(syd) Use the default config to generate this!+defaultCompilerState :: CompilerState+defaultCompilerState =+    CompilerState+    { stateDeploymentKindLocalOverride = Nothing+    , stateInto = ""+    , stateOutof_prefix = []+    }++instanceSpec :: Spec+instanceSpec =+    parallel $ do+        eqSpec @CompileAssignment+        genValidSpec @CompileAssignment+        eqSpec @CompileSettings+        genValidSpec @CompileSettings+        eqSpec @(Deployment FilePath)+        genValidSpec @(Deployment FilePath)+        jsonSpecOnValid @(Deployment FilePath)+        functorSpec @Deployment+        eqSpec @(DeploymentDirections FilePath)+        genValidSpec @(DeploymentDirections FilePath)+        jsonSpecOnValid @(DeploymentDirections FilePath)+        functorSpec @DeploymentDirections+        eqSpec @PrefixPart+        genValidSpec @PrefixPart+        eqSpec @CompilerState+        genValidSpec @CompilerState+        eqSpec @CompileError+        genValidSpec @CompileError++compileSpec :: Spec+compileSpec = do+    describe "formatCompileError" $+        it "only produces valid strings" $ producesValid formatCompileError++singleCompileDecSpec :: Spec+singleCompileDecSpec =+    describe "compileDec" $ do+        let s = defaultCompilerState+        let c = defaultCompileSettings+        let sc = singleShouldCompileTo c s+        let nonNull = genValid `suchThat` (not . null)+        let validFilePath = nonNull `suchThat` (not . containsNewlineCharacter)+        let easyFilePath = validFilePath `suchThat` (not . isPrefixOf ".")+        let validFp = genValid `suchThat` cleanBy cleanFilePath+        describe "Deploy" $ do+            it+                "uses the exact right text in source and destination when given valid filepaths without a leading dot" $ do+                forAll easyFilePath $ \from ->+                    forAll easyFilePath $ \to ->+                        sc+                            (Deploy from to Nothing)+                            (Deployment (Directions [from] to) LinkDeployment)+            it "handles filepaths with a leading dot correctly" $ do pending+            it+                "figures out the correct paths in these cases with default config and initial state" $ do+                let d = (Deploy "from" "to" $ Just LinkDeployment)+                sc d (Deployment (Directions ["from"] "to") LinkDeployment)+            it "uses the alternates correctly" $ do pending+            it "uses the into's correctly" $ do pending+            it "uses the outof's correctly" $ do pending+            pend+        describe "SparkOff" $ do+            it+                "adds a single card file reference to the list of cards to spark later" $ do+                forAll validFilePath $ \f ->+                    let cr = CardFile $ CardFileReference f Nothing+                        d = SparkOff cr+                    in compileSingleDec d s c `shouldBe` Right (s, ([], [cr]))+            it "adds any card reference to the list" $ do pending+            pend+        let shouldState = shouldResultInState c s+        describe "IntoDir" $ do+            it "adds the given directory to the into state" $ do+                forAll validFp $ \fp ->+                    shouldState (IntoDir fp) $ s {stateInto = fp}+            it "compounds with the input state" $ do+                pendingWith "Change the input state to an explicit list first"+            pend+        describe "OutofDir" $ do+            it "adds the given directory to the outof state" $ do+                forAll validFp $ \fp ->+                    shouldState (OutofDir fp) $+                    s {stateOutof_prefix = [Literal fp]}+            pend+        describe "DeployKindOverride" $ do+            it "modifies the internal deployment kind override" $ do+                forAll genValid $ \kind ->+                    shouldState (DeployKindOverride kind) $+                    s {stateDeploymentKindLocalOverride = Just kind}+            pend+        describe "Block" $ do+            it "uses a separate scope for its sub-compilation" $ do+                forAll genValid $ \ds -> shouldState (Block ds) s+            pend+        describe "Alternatives" $ do+            it+                "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]}+            pend++runDefaultImpureCompiler :: ImpureCompiler a -> IO (Either CompileError a)+runDefaultImpureCompiler = flip runReaderT defaultCompileSettings . runExceptT++compileUnitSpec :: Spec+compileUnitSpec =+    describe "compileUnit" $ do+        it "Only ever produces valid results" $+            forAll genValid $ \sets ->+                validIfSucceeds+                    (runIdentity .+                     flip runReaderT sets . runExceptT . compileUnit)++utilsSpec :: Spec+utilsSpec =+    parallel $ do+        describe "initialState" $ it "is valid" $ isValid initialState+        describe "sources" $+            it "only produces valid prefix parts" $ producesValid sources+        describe "resolvePrefix" $+            it "only produces valid paths" $ producesValid resolvePrefix++hopTests :: Spec+hopTests = do+    describe "hop test" $ do+        dir <- runIO $ resolveDir' "test_resources/hop_test"+        let root = dir </> $(mkRelFile "root.sus")+        let hop1 = dir </> $(mkRelDir "hop1dir") </> $(mkRelFile "hop1.sus")+        let hop2 =+                dir </> $(mkRelDir "hop1dir") </> $(mkRelDir "hop2dir") </>+                $(mkRelFile "hop2.sus")+        let hop3 =+                dir </> $(mkRelDir "hop1dir") </> $(mkRelDir "hop2dir") </>+                $(mkRelDir "hop3dir") </>+                $(mkRelFile "hop3.sus")+        it "compiles hop3 correctly" $ do+            r <-+                runDefaultImpureCompiler $+                compileJob $ StrongCardFileReference hop3 Nothing+            r `shouldBe`+                Right+                    [ Deployment+                          (Directions ["z/delta"] "d/three")+                          LinkDeployment+                    ]+        it "compiles hop2 correctly" $ do+            r <-+                runDefaultImpureCompiler $+                compileJob $ StrongCardFileReference hop2 Nothing+            r `shouldBe`+                Right+                    [ Deployment (Directions ["y/gamma"] "c/two") LinkDeployment+                    , Deployment+                          (Directions ["hop3dir/z/delta"] "d/three")+                          LinkDeployment+                    ]+        it "compiles hop1 correctly" $ do+            r <-+                runDefaultImpureCompiler $+                compileJob $ StrongCardFileReference hop1 Nothing+            r `shouldBe`+                Right+                    [ Deployment (Directions ["x/beta"] "b/one") LinkDeployment+                    , Deployment+                          (Directions ["hop2dir/y/gamma"] "c/two")+                          LinkDeployment+                    , Deployment+                          (Directions ["hop2dir/hop3dir/z/delta"] "d/three")+                          LinkDeployment+                    ]+        it "compiles root correctly" $ do+            r <-+                runDefaultImpureCompiler $+                compileJob $ StrongCardFileReference root Nothing+            r `shouldBe`+                Right+                    [ Deployment+                          (Directions ["u/alpha"] "a/zero")+                          LinkDeployment+                    , Deployment+                          (Directions ["hop1dir/x/beta"] "b/one")+                          LinkDeployment+                    , Deployment+                          (Directions ["hop1dir/hop2dir/y/gamma"] "c/two")+                          LinkDeployment+                    , Deployment+                          (Directions+                               ["hop1dir/hop2dir/hop3dir/z/delta"]+                               "d/three")+                          LinkDeployment+                    ]++exactTests :: Spec+exactTests = do+    describe "exact tests" $ do+        dir <- runIO $ resolveDir' "test_resources/exact_compile_test_src"+        forFileInDirss [dir] $ \fp ->+            if fileExtension fp == ".res"+                then return ()+                else do+                    it (toFilePath fp) $ do+                        let orig = fp+                        result <- parseAbsFile $ toFilePath fp <.> "res"+                        ads <-+                            runDefaultImpureCompiler $+                            compileJob $ StrongCardFileReference orig Nothing+                        eds <- runDefaultImpureCompiler $ inputCompiled result+                        ads `shouldBe` eds++hopTestDir :: Path Rel Dir+hopTestDir = $(mkRelDir "hop_test")++compilerBlackBoxTests :: Spec+compilerBlackBoxTests = do+    tr <- runIO $ resolveDir' "test_resources"+    describe "Succesful compile examples" $ do+        let dirs = map (tr </>) [shouldCompileDir, hopTestDir]+        forFileInDirss dirs $ \f -> do+            it (toFilePath f) $ do+                r <-+                    runDefaultImpureCompiler $+                    compileJob $ StrongCardFileReference f Nothing+                r `shouldSatisfy` isRight+    describe "Unsuccesfull compile examples" $ do+        let dirs = map (tr </>) [shouldNotParseDir, shouldNotCompileDir]+        forFileInDirss dirs $ \f -> do+            it (toFilePath f) $ do+                r <-+                    runDefaultImpureCompiler $+                    compileJob $ StrongCardFileReference f Nothing+                r `shouldSatisfy` isLeft
+ test/SuperUserSpark/Deployer/Gen.hs view
@@ -0,0 +1,30 @@+{-# OPTIONS_GHC -Wno-orphans #-}++module SuperUserSpark.Deployer.Gen where++import TestImport++import SuperUserSpark.Check.Gen ()+import SuperUserSpark.Deployer.Types++instance GenUnchecked DeployAssignment++instance GenValid DeployAssignment where+    genValid = DeployAssignment <$> genValid <*> genValid++instance GenUnchecked DeploySettings++instance GenValid DeploySettings where+    genValid =+        DeploySettings <$> genValid <*> genValid <*> genValid <*> genValid+++instance GenUnchecked DeployError++instance GenValid DeployError+++instance GenUnchecked PreDeployment++instance GenValid PreDeployment+
+ test/SuperUserSpark/DeployerSpec.hs view
@@ -0,0 +1,257 @@+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TemplateHaskell #-}++module SuperUserSpark.DeployerSpec where++import TestImport++import System.Posix.Files++import SuperUserSpark.Bake.Types+import SuperUserSpark.Check.Internal+import SuperUserSpark.Check.Types+import SuperUserSpark.Deployer+import SuperUserSpark.Deployer.Gen ()+import SuperUserSpark.Deployer.Internal+import SuperUserSpark.Deployer.Types+import SuperUserSpark.Diagnose.Internal+import SuperUserSpark.Diagnose.Types+import SuperUserSpark.OptParse.Gen ()+import SuperUserSpark.Parser.Gen ()++spec :: Spec+spec = do+    instanceSpec+    deployerSpec+    cleanSpec+    deploymentSpec++instanceSpec :: Spec+instanceSpec =+    parallel $ do+        eqSpec @DeployAssignment+        genValidSpec @DeployAssignment+        eqSpec @DeploySettings+        genValidSpec @DeploySettings+        eqSpec @DeployError+        genValidSpec @DeployError+        eqSpec @PreDeployment+        genValidSpec @PreDeployment++deployerSpec :: Spec+deployerSpec =+    parallel $ do+        describe "defaultDeploySettings" $+            it "is valid" $ isValid defaultDeploySettings+        describe "formatDeployError" $ do+            it "only ever produces valid strings" $+                producesValid formatDeployError++cleanSpec :: Spec+cleanSpec = do+    here <- runIO getCurrentDir+    let sandbox = here </> $(mkRelDir "test_sandbox")+    let setup = ensureDir sandbox+    let teardown = removeDirRecur sandbox+    let clean :: DeploySettings -> CleanupInstruction -> IO ()+        clean sets ci =+            runReaderT (runExceptT $ performClean ci) sets `shouldReturn`+            Right ()+    beforeAll_ setup $+        afterAll_ teardown $ do+            describe "performClean" $ do+                it "doesn't remove this file if that's not in the config" $ do+                    let c =+                            defaultDeploySettings+                            {deploySetsReplaceFiles = False}+                    withCurrentDir sandbox $ do+                        let file = sandbox </> $(mkRelFile "test.txt")+                        let fp = AbsP file+                        writeFile file "This is a test"+                        diagnoseFp fp `shouldReturn` IsFile+                        clean c $ CleanFile file+                        diagnoseFp fp `shouldReturn` IsFile+                        removeFile file+                        diagnoseFp fp `shouldReturn` Nonexistent+                it "removes this file if that's in the config" $ do+                    let c =+                            defaultDeploySettings+                            {deploySetsReplaceFiles = True}+                    withCurrentDir sandbox $ do+                        let file = sandbox </> $(mkRelFile "test.txt")+                        let fp = AbsP file+                        writeFile file "This is a test"+                        diagnoseFp fp `shouldReturn` IsFile+                        clean c $ CleanFile file+                        diagnoseFp fp `shouldReturn` Nonexistent+                it "doesn't remove this directory if that's not in the config" $ do+                    let c =+                            defaultDeploySettings+                            {deploySetsReplaceDirectories = False}+                    withCurrentDir sandbox $ do+                        let dir = sandbox </> $(mkRelDir "testdirectory")+                        let dirf =+                                AbsP $ sandbox </> $(mkRelFile "testdirectory")+                        ensureDir dir+                        diagnoseFp dirf `shouldReturn` IsDirectory+                        clean c $ CleanDirectory dir+                        diagnoseFp dirf `shouldReturn` IsDirectory+                        removeDirRecur dir+                        diagnoseFp dirf `shouldReturn` Nonexistent+                it "removes this directory if that's in the config" $ do+                    let c =+                            defaultDeploySettings+                            {deploySetsReplaceDirectories = True}+                    withCurrentDir sandbox $ do+                        let dir = sandbox </> $(mkRelDir "testdirectory")+                        let dirf =+                                AbsP $ sandbox </> $(mkRelFile "testdirectory")+                        ensureDir dir+                        diagnoseFp dirf `shouldReturn` IsDirectory+                        clean c $ CleanDirectory dir+                        diagnoseFp dirf `shouldReturn` Nonexistent+                it "doesn't remove this link if that's not in the config" $ do+                    let c =+                            defaultDeploySettings+                            {deploySetsReplaceLinks = False}+                    withCurrentDir sandbox $ do+                        let link_ = sandbox </> $(mkRelFile "testlink")+                        let link_' = AbsP link_+                        let file_ = sandbox </> $(mkRelFile "testfile")+                        let file_' = AbsP file_+                        writeFile file_ "This is a test"+                        createSymbolicLink (toFilePath file_) (toFilePath link_)+                        diagnoseFp link_' `shouldReturn` IsLinkTo file_'+                        clean c $ CleanLink link_+                        diagnoseFp link_' `shouldReturn` IsLinkTo file_'+                        removeLink $ toFilePath link_+                        diagnoseFp link_' `shouldReturn` Nonexistent+                        removeFile file_+                        diagnoseFp file_' `shouldReturn` Nonexistent+                it+                    "removes this link with an existent source if that's in the config" $ do+                    let c =+                            defaultDeploySettings+                            {deploySetsReplaceLinks = True}+                    withCurrentDir sandbox $ do+                        let link_ = sandbox </> $(mkRelFile "testlink")+                        let link_' = AbsP link_+                        let file_ = sandbox </> $(mkRelFile "testfile")+                        let file_' = AbsP file_+                        writeFile file_ "This is a test"+                        createSymbolicLink (toFilePath file_) (toFilePath link_)+                        diagnoseFp link_' `shouldReturn` IsLinkTo file_'+                        clean c $ CleanLink link_+                        diagnoseFp link_' `shouldReturn` Nonexistent+                        diagnoseFp file_' `shouldReturn` IsFile+                        removeFile file_+                        diagnoseFp file_' `shouldReturn` Nonexistent+                it+                    "removes this link with a nonexistent source if that's in the config" $ do+                    let c =+                            defaultDeploySettings+                            {deploySetsReplaceLinks = True}+                    withCurrentDir sandbox $ do+                        let link_ = sandbox </> $(mkRelFile "testlink")+                        let link_' = AbsP link_+                        let file_ = sandbox </> $(mkRelFile "testfile")+                        let file_' = AbsP file_+                        createSymbolicLink (toFilePath file_) (toFilePath link_)+                        diagnoseFp link_' `shouldReturn` IsLinkTo file_'+                        diagnoseFp file_' `shouldReturn` Nonexistent+                        clean c $ CleanLink link_+                        diagnoseFp link_' `shouldReturn` Nonexistent+                        diagnoseFp file_' `shouldReturn` Nonexistent++deploymentSpec :: Spec+deploymentSpec = do+    here <- runIO $ getCurrentDir+    let sandbox = here </> $(mkRelDir "test_sandbox")+    let setup = ensureDir sandbox+    let teardown = removeDirRecur sandbox+    beforeAll_ setup $+        afterAll_ teardown $ do+            describe "performCopyFile" $ do+                it "succcesfully copies this file" $ do+                    withCurrentDir sandbox $ do+                        let src = sandbox </> $(mkRelFile "testfile")+                        let src' = AbsP src+                        let dst = sandbox </> $(mkRelFile "testcopy")+                        let dst' = AbsP dst+                        writeFile src "This is a file."+                        diagnoseFp src' `shouldReturn` IsFile+                        diagnoseFp dst' `shouldReturn` Nonexistent+                        -- Under test+                        performCopyFile src dst+                        diagnoseFp src' `shouldReturn` IsFile+                        diagnoseFp dst' `shouldReturn` IsFile+                        dsrc <- diagnoseAbsP src'+                        ddst <- diagnoseAbsP dst'+                        diagnosedHashDigest ddst `shouldBe`+                            diagnosedHashDigest dsrc+                        removeFile src+                        removeFile dst+                        diagnoseFp src' `shouldReturn` Nonexistent+                        diagnoseFp dst' `shouldReturn` Nonexistent+            describe "performCopyDir" $ do+                it "succcesfully copies this directory" $ do+                    withCurrentDir sandbox $ do+                        let src = sandbox </> $(mkRelDir "testdir")+                        let src' = AbsP $ sandbox </> $(mkRelFile "testdir")+                        let dst = sandbox </> $(mkRelDir "testcopy")+                        let dst' = AbsP $ sandbox </> $(mkRelFile "testcopy")+                        ensureDir src+                        diagnoseFp src' `shouldReturn` IsDirectory+                        diagnoseFp dst' `shouldReturn` Nonexistent+                        -- Under test+                        performCopyDir src dst+                        diagnoseFp src' `shouldReturn` IsDirectory+                        diagnoseFp dst' `shouldReturn` IsDirectory+                        dsrc <- diagnoseAbsP src'+                        ddst <- diagnoseAbsP dst'+                        diagnosedHashDigest ddst `shouldBe`+                            diagnosedHashDigest dsrc+                        removeDirRecur src+                        removeDirRecur dst+                        diagnoseFp src' `shouldReturn` Nonexistent+                        diagnoseFp dst' `shouldReturn` Nonexistent+            describe "performLinkFile" $ do+                it "successfully links this file" $ do+                    withCurrentDir sandbox $ do+                        let src = sandbox </> $(mkRelFile "testfile")+                        let src' = AbsP src+                        let dst = sandbox </> $(mkRelFile "testlink")+                        let dst' = AbsP dst+                        diagnoseFp src' `shouldReturn` Nonexistent+                        diagnoseFp dst' `shouldReturn` Nonexistent+                        writeFile src "This is a test."+                        diagnoseFp src' `shouldReturn` IsFile+                        diagnoseFp dst' `shouldReturn` Nonexistent+                        -- Under test+                        performLinkFile src dst+                        diagnoseFp src' `shouldReturn` IsFile+                        diagnoseFp dst' `shouldReturn` IsLinkTo src'+                        removeFile src+                        removeLink $ toFilePath dst+                        diagnoseFp src' `shouldReturn` Nonexistent+                        diagnoseFp dst' `shouldReturn` Nonexistent+            describe "performLinkDir" $ do+                it "successfully links this directory" $ do+                    withCurrentDir sandbox $ do+                        let src = sandbox </> $(mkRelDir "testdir")+                        let src' = AbsP $ sandbox </> $(mkRelFile "testdir")+                        let dst = sandbox </> $(mkRelDir "testlink")+                        let dst' = AbsP $ sandbox </> $(mkRelFile "testlink")+                        diagnoseFp src' `shouldReturn` Nonexistent+                        diagnoseFp dst' `shouldReturn` Nonexistent+                        ensureDir src+                        diagnoseFp src' `shouldReturn` IsDirectory+                        diagnoseFp dst' `shouldReturn` Nonexistent+                        -- Under test+                        performLinkDir src dst+                        diagnoseFp src' `shouldReturn` IsDirectory+                        diagnoseFp dst' `shouldReturn` IsLinkTo src'+                        removeDirRecur src+                        removeLink $ dropTrailingPathSeparator $ toFilePath dst+                        diagnoseFp src' `shouldReturn` Nonexistent+                        diagnoseFp dst' `shouldReturn` Nonexistent
+ test/SuperUserSpark/Diagnose/Gen.hs view
@@ -0,0 +1,37 @@+{-# OPTIONS_GHC -Wno-orphans #-}++module SuperUserSpark.Diagnose.Gen where++import TestImport++import SuperUserSpark.Bake.Gen ()+import SuperUserSpark.Diagnose.Types+import SuperUserSpark.Compiler.Gen ()+import SuperUserSpark.Language.Gen ()++instance GenUnchecked DiagnoseAssignment++instance GenValid DiagnoseAssignment where+    genValid = DiagnoseAssignment <$> genValid <*> genValid++instance GenUnchecked DiagnoseSettings++instance GenValid DiagnoseSettings where+    genValid = DiagnoseSettings <$> genValid++instance GenUnchecked DiagnoseError++instance GenValid DiagnoseError++instance GenUnchecked HashDigest++instance GenValid HashDigest++instance GenUnchecked Diagnostics++instance GenValid Diagnostics++instance GenUnchecked DiagnosedFp++instance GenValid DiagnosedFp where+    genValid = D <$> genValid <*> genValid <*> genValid
+ test/SuperUserSpark/Diagnose/TestUtils.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE TemplateHaskell #-}++module SuperUserSpark.Diagnose.TestUtils where++import TestImport++import SuperUserSpark.Bake.Gen ()+import SuperUserSpark.Bake.Types+import SuperUserSpark.Check.Gen ()+import SuperUserSpark.Check.Internal+import SuperUserSpark.Check.Types+import SuperUserSpark.CoreTypes+import SuperUserSpark.Diagnose.Types+++-- TODO, the code should be able to handle 'genValid', but currenty it can't.+absPathIn :: Path Abs Dir -> Gen AbsP+absPathIn sandbox =+    scale (+ 5) $ do+        fp <- genListOf $ elements $ ['a' .. 'z'] ++ ['A' .. 'Z']+        case parseRelFile fp of+            Nothing -> absPathIn sandbox+            Just p -> pure $ AbsP $ sandbox </> p++absFileIn :: Path Abs Dir -> Gen (Path Abs File, AbsP)+absFileIn sandbox = do+    p <- absPathIn sandbox+    pure (unAbsP p, p)++absDirIn :: Path Abs Dir -> Gen (Path Abs Dir, AbsP)+absDirIn sandbox = do+    p <- absPathIn sandbox+    let u = toPath p+    case parseAbsDir u of+        Nothing -> absDirIn sandbox+        Just ad -> pure (ad, p)
+ test/SuperUserSpark/DiagnoseSpec.hs view
@@ -0,0 +1,270 @@+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TemplateHaskell #-}++module SuperUserSpark.DiagnoseSpec where++import TestImport++import Control.Monad (forM_)+import Data.Hashable+import System.FilePath (dropTrailingPathSeparator)+import System.Posix.Files++import SuperUserSpark.Bake.Types+import SuperUserSpark.Check+import SuperUserSpark.Check.Gen ()+import SuperUserSpark.Check.Internal+import SuperUserSpark.Check.TestUtils+import SuperUserSpark.Check.Types+import SuperUserSpark.Compiler.Types+import SuperUserSpark.CoreTypes+import SuperUserSpark.Diagnose+import SuperUserSpark.Diagnose.Gen ()+import SuperUserSpark.Diagnose.Internal+import SuperUserSpark.Diagnose.TestUtils+import SuperUserSpark.Diagnose.Types+import SuperUserSpark.OptParse.Gen ()+import SuperUserSpark.Parser.Gen ()+import SuperUserSpark.Utils+import TestUtils++spec :: Spec+spec = do+    instanceSpec+    diagnoseSpec+    hashSpec++instanceSpec :: Spec+instanceSpec = do+    eqSpec @CheckSettings+    genValidSpec @CheckSettings+    eqSpec @Diagnostics+    genValidSpec @Diagnostics+    eqSpec @DiagnosedFp+    genValidSpec @DiagnosedFp+    eqSpec @DiagnosedDeployment+    genValidSpec @DiagnosedDeployment++diagnoseSpec :: Spec+diagnoseSpec = do+    describe "formatDiagnoseError" $+        it "always produces valid strings" $ producesValid formatDiagnoseError+    sandbox <- runIO $ resolveDir' "test_sandbox"+    let setup = ensureDir sandbox+    let teardown = removeDirRecur sandbox+    beforeAll_ setup $+        afterAll_ teardown $ do+            describe "diagnoseDeployment" $ do+                it+                    "retains the filepaths and deploymentkind that it diagnoses for valid filepaths" $ do+                    forAll genValid $ \d@(Deployment (Directions srcs dst) kind) -> do+                        (Deployment (Directions dsrcs ddst) dkind) <-+                            diagnoseDeployment d+                        map diagnosedFilePath dsrcs `shouldBe` srcs+                        diagnosedFilePath ddst `shouldBe` dst+                        dkind `shouldBe` kind+                pend+            describe "diagnose" $ do+                it "retains the filepath that it diagnoses for valid AbsPath's" $ do+                    forAll genValid $ \fp -> do+                        (D dfp _ _) <- diagnoseAbsP fp+                        dfp `shouldBe` fp+                pend+            describe "diagnoseFp" $ do+                let expect s ls = do+                        rs <-+                            forM ls $ \(a, b) -> do+                                r <- diagnoseFp a+                                pure (a, r, b)+                        unless (all (\(a, r, b) -> r == b) rs) $+                            let nice (a, r, b) =+                                    unlines+                                        [ unwords+                                              [ "Unexpected results at stage"+                                              , show s+                                              ]+                                        , unwords ["path:", show $ toPath a]+                                        , unwords+                                              [ "stripped:"+                                              , show $+                                                (stripDir sandbox $ unAbsP a :: Maybe (Path Rel File))+                                              ]+                                        , unwords ["expected:", show b]+                                        , unwords ["real:", show r]+                                        ]+                            in expectationFailure $ unlines $ map nice rs+                it "figures out this link that points to something that exists" $ do+                    let file = sandbox </> $(mkRelFile "file")+                    let file' = AbsP file+                    let link = sandbox </> $(mkRelFile "link")+                    let link' = AbsP link+                    expect "before" [(file', Nonexistent), (link', Nonexistent)]+                    writeFile file "This is a test"+                    expect+                        "after file creation"+                        [(file', IsFile), (link', Nonexistent)]+                    createSymbolicLink (toFilePath file) (toFilePath link)+                    expect+                        "after link creation"+                        [(file', IsFile), (link', IsLinkTo file')]+                    removeLink $ toFilePath link+                    expect+                        "after link removal"+                        [(file', IsFile), (link', Nonexistent)]+                    removeFile file+                    expect+                        "after file removal"+                        [(file', Nonexistent), (link', Nonexistent)]+                it+                    "figures out this link that points to something that does not exist" $ do+                    let file = sandbox </> $(mkRelFile "file")+                    let file' = AbsP file+                    let link = sandbox </> $(mkRelFile "link")+                    let link' = AbsP link+                    expect "before" [(file', Nonexistent), (link', Nonexistent)]+                    createSymbolicLink (toFilePath file) (toFilePath link)+                    expect+                        "after link creation"+                        [(file', Nonexistent), (link', IsLinkTo file')]+                    removeLink $ toFilePath link+                    expect "after" [(file', Nonexistent), (link', Nonexistent)]+                it+                    "figures out that a thing in a nonexistent dir is nonexistent" $ do+                    let file = sandbox </> $(mkRelFile "nonexistent/and/file")+                    let file' = AbsP file+                    diagnoseFp file' `shouldReturn` Nonexistent+                it "figures out a file" $ do+                    forAll (absFileIn sandbox) $ \(file, file') -> do+                        diagnoseFp file' `shouldReturn` Nonexistent+                        ensureDir $ parent file+                        writeFile file "This is a test"+                        diagnoseFp file' `shouldReturn` IsFile+                        removeFile file+                        diagnoseFp file' `shouldReturn` Nonexistent+                it "figures out a directory" $ do+                    forAll (absDirIn sandbox) $ \(dir, dir') -> do+                        diagnoseFp dir' `shouldReturn` Nonexistent+                        ensureDir dir+                        diagnoseFp dir' `shouldReturn` IsDirectory+                        removeDirRecur dir+                        diagnoseFp dir' `shouldReturn` Nonexistent+                it "figures out a symbolic link with an existent destination" $ do+                    forAll (absFileIn sandbox) $ \f@(file, file') ->+                        forAll (absFileIn sandbox `suchThat` (/= f)) $ \(link, link') -> do+                            expect+                                "before"+                                [(file', Nonexistent), (link', Nonexistent)]+                            writeFile file "This is a test"+                            expect+                                "after file creation"+                                [(file', IsFile), (link', Nonexistent)]+                            createSymbolicLink+                                (toFilePath file)+                                (toFilePath link)+                            expect+                                "after link creation"+                                [(file', IsFile), (link', IsLinkTo file')]+                            removeLink $ toFilePath link+                            expect+                                "after link removal"+                                [(file', IsFile), (link', Nonexistent)]+                            removeFile file+                            expect+                                "after"+                                [(file', Nonexistent), (link', Nonexistent)]+                it "figures out a symbolic link with a nonexistent destination" $ do+                    forAll (absFileIn sandbox) $ \f@(file, file') ->+                        forAll (absFileIn sandbox `suchThat` (/= f)) $ \(link, link') -> do+                            expect+                                "before"+                                [(file', Nonexistent), (link', Nonexistent)]+                            createSymbolicLink+                                (toFilePath file)+                                (toFilePath link)+                            expect+                                "after link creation"+                                [(file', Nonexistent), (link', IsLinkTo file')]+                            removeLink $ toFilePath link+                            expect+                                "after"+                                [(file', Nonexistent), (link', Nonexistent)]+                it "figures out that /dev/null is weird" $ do+                    diagnoseFp (AbsP $(mkAbsFile "/dev/null")) `shouldReturn`+                        IsWeird+                it "figures out that /dev/random is weird" $ do+                    diagnoseFp (AbsP $(mkAbsFile "/dev/random")) `shouldReturn`+                        IsWeird++checkDeploymentSpec :: Spec+checkDeploymentSpec = do+    describe "checkDeployment" $ do+        it "always produces valid check results" $+            producesValidsOnValids checkDeployment+        it "says 'impossible' for deployments with an empty list of sources" $ do+            forAll genUnchecked $ \dst ->+                forAll genUnchecked $ \kind ->+                    shouldBeImpossible' $ Deployment (Directions [] dst) kind+        it "says 'impossible' for deployments where all singles are impossible" $ do+            forAll+                (genValid `suchThat`+                 (\(Deployment (Directions srcs dst) kind) ->+                      all (\src -> isImpossible $ checkSingle src dst kind) srcs)) $ \dd ->+                shouldBeImpossible' dd+        it+            "gives the same result as bestResult (just with a better error for empty lists)" $ do+            forAll genValid $ \dd@(Deployment (Directions srcs dst) kind) ->+                case ( bestResult (map (\src -> checkSingle src dst kind) srcs)+                     , checkDeployment dd) of+                    (ImpossibleDeployment r1, ImpossibleDeployment r2) ->+                        length r1 `shouldSatisfy` (<= (length r2))+                    (r1, r2) -> r1 `shouldBe` r2+    describe "bestResult" $ do+        it "always produces valid check results" $+            producesValidsOnValids bestResult+        it "says 'impossible' if all checkresults are impossible" $ do+            forAll+                (genValid `suchThat` all isImpossible)+                shouldBeImpossibleDeployment+        it "says 'done' if the first non-impossible in 'done'" $ do+            forAll+                (genValid `suchThat`+                 (any (not . isImpossible) &&&+                  (isDone . head . dropWhile isImpossible))) $ \dd ->+                bestResult dd `shouldSatisfy` deploymentIsDone+        it "says 'dirty' if the first non-impossible in 'dirty'" $ do+            forAll+                (genValid `suchThat`+                 (any (not . isImpossible) &&&+                  (isDirty . head . dropWhile isImpossible))) $ \dd ->+                bestResult dd `shouldSatisfy` dirtyDeployment+        it "says 'ready' if the first non-impossible in 'ready'" $ do+            forAll+                (genValid `suchThat`+                 (any (not . isImpossible) &&&+                  (isReady . head . dropWhile isImpossible))) $ \dd ->+                bestResult dd `shouldSatisfy` deploymentReadyToDeploy++hashSpec :: Spec+hashSpec = do+    tooManyFilesTest++tooManyFilesTest :: Spec+tooManyFilesTest = do+    sandbox <- runIO $ resolveDir' "test_sandbox"+    let setup = ensureDir sandbox+    let teardown = removeDirRecur sandbox+    let aLot = 20000 :: Int+    let setupALotOfFiles = do+            forM_ [1 .. aLot] $ \i -> do+                f <- parseRelFile $ "file" ++ show i+                writeFile (sandbox </> f) $ "This is file " ++ show i ++ ".\n"+    beforeAll_ setup $+        afterAll_ teardown $ do+            describe "hashFilePath" $ do+                beforeAll_ setupALotOfFiles $ do+                    it+                        ("has no problem with hashing a directory of " +++                         show aLot ++ " files") $ do+                        sb <- resolveFile' "test_sandbox"+                        let d = AbsP sb+                        hashFilePath d `shouldNotReturn` HashDigest (hash ())
+ test/SuperUserSpark/EndToEnd/RegressionSpec.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE TemplateHaskell #-}++module SuperUserSpark.EndToEnd.RegressionSpec+    ( spec+    ) where++import TestImport++import System.Directory+import System.Environment (withArgs)+import System.Exit (ExitCode(ExitFailure))+import System.Posix.Files++import SuperUserSpark+import SuperUserSpark.Utils++spec :: Spec+spec = do+    linkThenCopySpec++linkThenCopySpec :: Spec+linkThenCopySpec = do+    here <- runIO getCurrentDir+    let sandbox = here </> $(mkRelDir "test_sandbox")+    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+                        -- Set up the file+                        ensureDir (parent from)+                        writeFile 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]+                        -- 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)
+ test/SuperUserSpark/EndToEndSpec.hs view
@@ -0,0 +1,85 @@+module SuperUserSpark.EndToEndSpec+    ( spec+    ) where++import TestImport hiding ((</>), removeFile, copyFile)++import qualified Prelude as P (writeFile, readFile)++import SuperUserSpark+import SuperUserSpark.Utils+import System.Directory+import System.Environment (withArgs)+import System.Exit (ExitCode(ExitSuccess))+import System.FilePath.Posix ((</>))+import System.Posix.Files++spec :: Spec+spec = do+    helpTextSpec+    regularWorkflowSpec++helpTextSpec :: Spec+helpTextSpec =+    describe "help text test" $ do+        it "shows the help text without crashing" $ do+            withArgs ["--help"] spark `shouldThrow` (== ExitSuccess)++regularWorkflowSpec :: Spec+regularWorkflowSpec = do+    here <- runIO getCurrentDirectory+    let sandbox = here </> "test_sandbox"+    let setup = createDirectoryIfMissing True sandbox+    let teardown = removeDirectoryRecursive sandbox+    let rsc = here </> "test_resources" </> "end-to-end"+    beforeAll_ setup $+        afterAll_ teardown $ do+            describe "standard bash card test" $ do+                let bashrsc = rsc </> "bash.sus"+                let bashrscres = rsc </> "bash.sus.res"+                let cardfile = sandbox </> "bash.sus"+                let up = do+                        copyFile bashrsc cardfile+                        withCurrentDirectory sandbox $ do+                            createDirectoryIfMissing True "bash"+                            withCurrentDirectory "bash" $ do+                                P.writeFile "bash_aliases" "bash_aliases"+                                P.writeFile "bashrc" "bashrc"+                                P.writeFile "bash_profile" "bash_profile"+                let down = do+                        removeFile cardfile+                        withCurrentDirectory sandbox $ do+                            removeDirectoryRecursive "bash"+                beforeAll_ up $+                    afterAll_ down $ do+                        it "parses correcty" $ do+                            withCurrentDirectory sandbox $+                                withArgs ["parse", cardfile] spark `shouldReturn`+                                ()+                        it "compiles correctly" $ do+                            let outfile = sandbox </> "bash.sus.res"+                            withCurrentDirectory sandbox $+                                withArgs+                                    ["compile", cardfile, "--output", outfile]+                                    spark `shouldReturn`+                                ()+                            actual <- P.readFile outfile+                            expected <- P.readFile bashrscres+                            unless (actual == expected) $ expectationFailure $ unlines ["Expected and actual differ:", expected, actual]+                        it "checks without exceptions" $ do+                            withCurrentDirectory sandbox $+                                withArgs ["check", cardfile] spark `shouldReturn`+                                ()+                        it "deploys correctly" $+                            withCurrentDirectory sandbox $ do+                                withArgs ["deploy", cardfile] spark `shouldReturn`+                                    ()+                                let f1 = "subdir" </> ".bashrc"+                                    f2 = "subdir" </> ".bash_aliases"+                                    f3 = "subdir" </> ".bash_profile"+                                P.readFile f1 `shouldReturn` "bashrc"+                                P.readFile f2 `shouldReturn` "bash_aliases"+                                P.readFile f3 `shouldReturn` "bash_profile"+                                removeLink f1+                                removeLink f2+                                removeLink f3
+ test/SuperUserSpark/Language/Gen.hs view
@@ -0,0 +1,64 @@+{-# OPTIONS_GHC -Wno-orphans #-}++module SuperUserSpark.Language.Gen where++import TestImport++import SuperUserSpark.CoreTypes+import SuperUserSpark.Language.Types++instance GenUnchecked SparkFile where+    genUnchecked = SparkFile <$> genUnchecked <*> genUnchecked++instance GenValid SparkFile++instance GenUnchecked Card where+    genUnchecked = Card <$> genUnchecked <*> genUnchecked++instance GenValid Card++instance GenUnchecked Declaration where+    genUnchecked = resize 5 $ sized go+      where+        go 0 =+            oneof+                [ SparkOff <$> genUnchecked+                , Deploy <$> genUnchecked <*> genUnchecked <*> genUnchecked+                , IntoDir <$> genUnchecked+                , OutofDir <$> genUnchecked+                , DeployKindOverride <$> genUnchecked+                , Alternatives <$> genUnchecked+                , Block <$> genUnchecked+                ]+        go n =+            oneof+                [ SparkOff <$> genUnchecked+                , Deploy <$> genUnchecked <*> genUnchecked <*> genUnchecked+                , IntoDir <$> genUnchecked+                , OutofDir <$> genUnchecked+                , DeployKindOverride <$> genUnchecked+                , Alternatives <$> genUnchecked+                , Block <$> listOf (go $ n - 1)+                ]++instance GenValid Declaration++instance GenUnchecked DeploymentKind where+    genUnchecked = elements [LinkDeployment, CopyDeployment]++instance GenValid DeploymentKind++instance GenUnchecked CardNameReference where+    genUnchecked = CardNameReference <$> genUnchecked++instance GenValid CardNameReference++instance GenUnchecked CardFileReference where+    genUnchecked = CardFileReference <$> genUnchecked <*> genUnchecked++instance GenValid CardFileReference++instance GenUnchecked CardReference where+    genUnchecked = oneof [CardFile <$> genUnchecked, CardName <$> genUnchecked]++instance GenValid CardReference
+ test/SuperUserSpark/OptParse/Gen.hs view
@@ -0,0 +1,55 @@+{-# OPTIONS_GHC -Wno-orphans #-}++module SuperUserSpark.OptParse.Gen where++import TestImport++import SuperUserSpark.OptParse.Types++instance GenUnchecked Dispatch++instance GenValid Dispatch++instance GenUnchecked ParseArgs++instance GenValid ParseArgs++instance GenUnchecked CompileArgs++instance GenValid CompileArgs++instance GenUnchecked CompileFlags++instance GenValid CompileFlags++instance GenUnchecked BakeArgs++instance GenValid BakeArgs++instance GenUnchecked BakeFlags++instance GenValid BakeFlags++instance GenUnchecked CheckArgs++instance GenValid CheckArgs++instance GenUnchecked CheckFlags++instance GenValid CheckFlags++instance GenUnchecked DiagnoseArgs++instance GenValid DiagnoseArgs++instance GenUnchecked DiagnoseFlags++instance GenValid DiagnoseFlags++instance GenUnchecked DeployArgs++instance GenValid DeployArgs++instance GenUnchecked DeployFlags++instance GenValid DeployFlags
+ test/SuperUserSpark/Parser/Gen.hs view
@@ -0,0 +1,85 @@+module SuperUserSpark.Parser.Gen where++import TestImport++import Data.List (isSuffixOf)++generateNormalCharacter :: Gen Char+generateNormalCharacter =+    elements $ ['a' .. 'z'] ++ ['A' .. 'Z'] ++ ['0' .. '1']++generateWord :: Gen String+generateWord = listOf1 generateNormalCharacter++generateTab :: Gen Char+generateTab = return '\t'++generateSpace :: Gen Char+generateSpace = return ' '++generateLineFeed :: Gen Char+generateLineFeed = return '\n'++generateCarriageReturn :: Gen Char+generateCarriageReturn = return '\r'++generateLineSpace :: Gen String+generateLineSpace = listOf $ oneof [generateTab, generateSpace]++generateWhiteSpace :: Gen String+generateWhiteSpace =+    listOf $+    oneof [generateTab, generateSpace, generateLineFeed, generateCarriageReturn]++generateWords :: Gen String+generateWords = fmap unwords $ listOf1 generateWord++generateEol :: Gen String+generateEol = elements ["\n", "\r", "\r\n"]++twice :: Gen a -> Gen (a, a)+twice gen = (,) <$> gen <*> gen++trice :: Gen a -> Gen (a, a, a)+trice gen = (,,) <$> gen <*> gen <*> gen++generateCardName :: Gen (String, String)+generateCardName = oneof [generateQuotedIdentifier, generatePlainIdentifier]++generateIdentifier :: Gen (String, String)+generateIdentifier = oneof [generatePlainIdentifier, generateQuotedIdentifier]++generateQuotedIdentifier :: Gen (String, String)+generateQuotedIdentifier = do+    w <- generateWord+    return $ ("\"" ++ w ++ "\"", w)++generatePlainIdentifier :: Gen (String, String)+generatePlainIdentifier = do+    w <- generateWord+    return $ (w, w)++generateFilePath :: Gen (FilePath, FilePath)+generateFilePath =+    generateIdentifier `suchThat` (\(_, f) -> not $ "/" `isSuffixOf` f)++generateDirectory :: Gen (FilePath, FilePath)+generateDirectory = generateFilePath++generateComment :: Gen (String, String)+generateComment = oneof [generateLineComment, generateBlockComment]++generateLineComment :: Gen (String, String)+generateLineComment = do+    ws <- generateWords+    let ws' = "#" ++ ws ++ "\n"+    return (ws', ws)++generateBlockComment :: Gen (String, String)+generateBlockComment = do+    ws <- generateWords+    let ws' = "[[" ++ ws ++ "]]"+    return (ws', ws)++generateDeploymentKindSymbol :: Gen String+generateDeploymentKindSymbol = elements ["l->", "c->", "->"]
+ test/SuperUserSpark/Parser/TestUtils.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE TemplateHaskell #-}++module SuperUserSpark.Parser.TestUtils where++import TestImport hiding (succeeds)++import Data.Either (isRight)+import SuperUserSpark.Parser.Internal+import Text.Parsec+import Text.Parsec.String++shouldSucceed+    :: (Show a, Eq a)+    => Parser a -> String -> IO ()+shouldSucceed parser input = input `shouldSatisfy` succeeds parser++shouldFail+    :: (Show a, Eq a)+    => Parser a -> String -> IO ()+shouldFail parser input = input `shouldNotSatisfy` succeeds parser++succeeds :: Parser a -> String -> Bool+succeeds parser = succeedsWithLeftover $ parser >> eof++succeedsWithLeftover :: Parser a -> String -> Bool+succeedsWithLeftover parser input = isRight $ parseWithoutSource parser input++succeedsAnywhere :: Parser a -> String -> Bool+succeedsAnywhere p s = or $ map (succeedsWithLeftover p) (tails s)+  where+    tails :: [a] -> [[a]]+    tails [] = [[]]+    tails ass@(_:as) = ass : tails as++fails :: Parser a -> String -> Bool+fails parser input = not $ succeeds parser input++testInputSource :: Path Abs File+testInputSource = $(mkAbsFile "/Test/input/file")++parseShouldSucceedAs+    :: (Show a, Eq a)+    => Parser a -> String -> a -> IO ()+parseShouldSucceedAs parser input a =+    parseFromSource parser testInputSource input `shouldBe` Right a++parseShouldBe+    :: (Show a, Eq a)+    => Parser a -> String -> Either ParseError a -> IO ()+parseShouldBe parser input result =+    parseFromSource parser testInputSource input `shouldBe` result++parseWithoutSource :: Parser a -> String -> Either ParseError a+parseWithoutSource parser input = parseFromSource parser testInputSource input
+ test/SuperUserSpark/ParserSpec.hs view
@@ -0,0 +1,528 @@+{-# LANGUAGE TypeApplications #-}++module SuperUserSpark.ParserSpec where++import TestImport hiding (succeeds)++import Data.Either (isLeft, isRight)+import Data.List (intercalate)+import Text.Parsec++import SuperUserSpark.CoreTypes+import SuperUserSpark.Language.Gen ()+import SuperUserSpark.Language.Types+import SuperUserSpark.Parser.Gen+import SuperUserSpark.Parser.Internal+import SuperUserSpark.Parser.TestUtils+import TestUtils++spec :: Spec+spec =+    parallel $ do+        instanceSpec+        blankspaceParserTests+        enclosingCharacterTests+        delimiterTests+        identifierParserTests+        commentParserTests+        pathParserTests+        declarationParserTests+        parserBlackBoxTests+        toplevelParserTests++enclosingCharacterTests :: Spec+enclosingCharacterTests = do+    describe "inBraces" $ do+        it+            "succeeds for cases where we enclose braces around a string without braces" $ do+            forAll+                (listOf1 arbitrary `suchThat` (\c -> c /= "{" && c /= "}"))+                (\word ->+                     parseShouldSucceedAs+                         (inBraces $ string word)+                         ("{" ++ word ++ "}")+                         word)+    describe "inQuotes" $ do+        it+            "succeeds for cases where we enclose quotes around a string without quotes" $ do+            forAll (listOf1 arbitrary `suchThat` (/= "\"")) $ \word ->+                parseShouldSucceedAs+                    (inQuotes $ string word)+                    ("\"" ++ word ++ "\"")+                    word++instanceSpec :: Spec+instanceSpec = do+    eqSpec @Card+    genValidSpec @Card+    eqSpec @Declaration+    genValidSpec @Declaration+    eqSpec @CardNameReference+    genValidSpec @CardNameReference+    eqSpec @CardFileReference+    genValidSpec @CardFileReference+    eqSpec @CardReference+    genValidSpec @CardReference+    eqSpec @SparkFile+    genValidSpec @SparkFile++blankspaceParserTests :: Spec+blankspaceParserTests = do+    describe "eol" $ do+        let s = shouldSucceed eol+        it "succeeds for Linux line endings" $ do s "\n"+        it "succeeds for Windows line endings" $ do s "\r\n"+        it "succeeds for Mac line endings" $ do s "\r"+        let f = shouldFail eol+        it "fails for the empty string" $ do f ""+        it "fails for spaces" $ do forAll (listOf generateSpace) (\ss -> f ss)+        it "fails for tabs" $ do forAll (listOf generateTab) (\ss -> f ss)+        it "fails for linespace" $ do forAll generateLineSpace (\ls -> f ls)+    describe "linespace" $ do+        let s = shouldSucceed linespace+        it "succeeds for spaces" $ do forAll (listOf generateSpace) s+        it "succeeds for tabs" $ do forAll (listOf generateTab) s+        it "succeeds for mixtures of spaces and tabs" $ do+            forAll generateLineSpace s+        let f = shouldSucceed whitespace+        it "fails for line ending characters" $ do+            forAll (listOf $ oneof [generateCarriageReturn, generateLineFeed]) f+        it "fails for any non-linespace, even if there's linespace in it" $+            forAll (listOf1 generateNormalCharacter) $ \ls ->+                forAll generateLineSpace $ \ls1 ->+                    forAll generateLineSpace $ \ls2 ->+                        shouldFail linespace (ls1 ++ ls ++ ls2)+    describe "whitespace" $ do+        let s = shouldSucceed whitespace+        it "succeeds for spaces" $ do forAll (listOf generateSpace) s+        it "succeeds for tabs" $ do forAll (listOf generateTab) s+        it "succeeds carriage returns" $ do+            forAll (listOf generateCarriageReturn) s+        it "succeeds line feeds" $ do forAll (listOf generateLineFeed) s+        it+            "succeeds for mixtures of spaces, tabs, carriage returns and line feeds" $ do+            forAll generateWhiteSpace s+        it "fails for any non-whitespace, even if there's whitespace in it" $ do+            forAll (listOf1 generateNormalCharacter) $ \ls ->+                forAll generateWhiteSpace $ \ws1 ->+                    forAll generateWhiteSpace $ \ws2 ->+                        shouldFail whitespace (ws1 ++ ls ++ ws2)+    describe "inLineSpace" $ do+        it+            "succeeds for cases where we append whitespace to the front and back of non-whitespace" $ do+            forAll generateLineSpace $ \ws1 ->+                forAll generateLineSpace $ \ws2 ->+                    forAll (listOf1 generateNormalCharacter) $ \ls ->+                        parseShouldSucceedAs+                            (inLineSpace $ string ls)+                            (ws1 ++ ls ++ ws2)+                            ls+    describe "inWhiteSpace" $ do+        it+            "succeeds for cases where we append whitespace to the front and back of non-whitespace" $ do+            forAll generateWhiteSpace $ \ws1 ->+                forAll generateWhiteSpace $ \ws2 ->+                    forAll (listOf1 generateNormalCharacter) $ \ls ->+                        parseShouldSucceedAs+                            (inWhiteSpace $ string ls)+                            (ws1 ++ ls ++ ws2)+                            ls++delimiterTests :: Spec+delimiterTests = do+    describe "delim" $ do+        it "succeeds on a semicolon" $ do shouldSucceed delim ";"+        it "succeeds on an eol" $ do+            once $+                forAll (arbitrary `suchThat` succeeds eol) (shouldSucceed delim)++identifierParserTests :: Spec+identifierParserTests = do+    describe "plainIdentifier" $ do+        it "succeeds for generated plain identifiers" $ do+            forAll generatePlainIdentifier $ \(e, a) ->+                parseShouldSucceedAs plainIdentifier e a+        let pti = shouldSucceed plainIdentifier+        it "succeeds for these examples" $ do+            pti "bash"+            pti "card"+            pti ".bashrc"+            pti "xmonad.hs"+        it "fails for generated quoted identifiers" $ do+            forAll generateQuotedIdentifier $ \(e, _) ->+                shouldFail plainIdentifier e+    describe "quotedIdentifier" $ do+        it "succeeds for generated plain identifiers surrounded in quotes" $ do+            forAll generatePlainIdentifier $ \(e, a) ->+                parseShouldSucceedAs quotedIdentifier ("\"" ++ e ++ "\"") a+        it "succeeds for generated quoted identifiers" $ do+            forAll generateQuotedIdentifier $ \(e, a) ->+                parseShouldSucceedAs quotedIdentifier e a+        let pti i = parseShouldSucceedAs quotedIdentifier ("\"" ++ i ++ "\"") i+        it "succeeds for these examples" $ do+            pti "bashrc"+            pti "with spaces"+        it "fails for generated plain identifiers" $ do+            forAll generatePlainIdentifier $ \(e, _) ->+                shouldFail quotedIdentifier e+        it "fails for generated identifiers with just one quote" $ do+            forAll generatePlainIdentifier $ \(e, _) ->+                shouldFail quotedIdentifier ("\"" ++ e) .&&.+                shouldFail quotedIdentifier (e ++ "\"")+    describe "identifier" $ do+        it "succeeds for generated identifiers" $ do+            forAll generateIdentifier $ \(e, a) ->+                parseShouldSucceedAs identifier e a++commentParserTests :: Spec+commentParserTests = do+    describe "eatComments" $ do+        it "should succeed unchanged on anything without comments" $ do+            property $ \s ->+                (not $ succeedsAnywhere comment s) ==>+                parseShouldSucceedAs eatComments s s+        let (-=>) e a = parseShouldSucceedAs eatComments e a+        it "successfully removes comments in these strings" $ do+            "abc#def\nghi" -=> "abcghi"+            "abc# This is a bigger comment \r\nghi" -=> "abcghi"+            "abc[[def]]ghi" -=> "abcghi"+            "abc[[ This is a bigger comment ]]ghi" -=> "abcghi"+            "Heavy[[use]]of#comments\n." -=> "Heavyof."+    describe "notComment" $ do+        it "should succeed for any string that doesn't contain comments" $ do+            property $ \s ->+                (not $ succeedsAnywhere comment s) ==>+                parseShouldSucceedAs notComment s s+    describe "lineComment" $ do+        it "succeeds for generated line comments" $ do+            forAll generateLineComment $ \(e, a) ->+                parseShouldSucceedAs lineComment e a+        it "succeeds for these test cases" $ do+            parseShouldSucceedAs lineComment "#a\n" "a"+            parseShouldSucceedAs+                lineComment+                "# This is a comment\n"+                " This is a comment"+            parseShouldSucceedAs+                lineComment+                "## This is a comment with two comment signs.\n"+                "# This is a comment with two comment signs."+            parseShouldSucceedAs+                lineComment+                "# with other eol\r\n"+                " with other eol"+    describe "blockComment" $ do+        it "succeeds for generated block comments" $ do+            forAll generateBlockComment $ \(e, a) ->+                parseShouldSucceedAs blockComment e a+        it "succeeds of these test cases" $ do+            parseShouldSucceedAs blockComment "[[a]]" "a"+            parseShouldSucceedAs+                blockComment+                "[[ This is a block comment. ]]"+                " This is a block comment. "+            parseShouldSucceedAs+                blockComment+                "[[ [This is a [block] comment containing brackets.] ]]"+                " [This is a [block] comment containing brackets.] "+    describe "comment" $ do+        it "succeeds for generated line comments" $ do+            forAll generateLineComment $ \(e, a) ->+                parseShouldSucceedAs comment e a+        it "succeeds for generated block comments" $ do+            forAll generateBlockComment $ \(e, a) ->+                parseShouldSucceedAs comment e a++pathParserTests :: Spec+pathParserTests = do+    describe "filepath" $ do+        it "succeeds for generated filepaths" $ do+            forAll generateFilePath $ \(e, a) ->+                parseShouldSucceedAs filepath e a+        it "succeeds for this quoted filepath with a space in it" $ do+            parseShouldSucceedAs+                filepath+                "\"/home/user/with spaces\""+                "/home/user/with spaces"+        let s = shouldSucceed filepath+        it "succeeds for this file without an extension" $ do+            s "withoutExtension"+        it "succeeds for this simple file" $ do s "test.txt"+        it "succeeds for this simple file with a long extension" $ do+            s "file.somelongextension"+        it "succeeds for this absolute filepath" $ do s "/home/user/test.txt"+        it "succeeds for this absolute filepath with a long extension" $ do+            s "/home/user/file.somelongextension"+        it "succeeds for this absolute filepath with multiple extensions" $ do+            s "/home/user/test.multiple.extensions"+        it "succeeds for this relative filepath with a double dot" $ do+            s "/home/user/../user/test.txt"+        let f = shouldFail filepath+        it "fails for just a slash" $ do f "/"+        it "fails for strings ending in a slash" $ do+            property $ \s_ -> f (s_ ++ "/")+    describe "directory" $ do+        it "succeeds for generated directories" $ do+            forAll generateDirectory $ \(e, a) ->+                parseShouldSucceedAs directory e a+        let s = shouldSucceed directory+        it "succeeds for the home directory" $ do s "~"+        it "succeeds for this relative directory" $ do s "directory"+        it "succeeds for this absolute directory" $ do s "/home/user"+        it "succeeds for these directories in the home directory" $ do+            s "~/.vim"+            s "~/Dropbox"+            s "~/.xmonad"+        let f = shouldFail directory+        it "fails for just a slash" $ do f "/"+        it "fails for strings ending in a slash" $ do+            property $ \s_ -> f (s_ ++ "/")++declarationParserTests :: Spec+declarationParserTests = do+    describe "cardName" $ do+        it "succeeds on every card name that we generate" $ do+            forAll generateCardName $ \(a, e) ->+                parseShouldSucceedAs cardNameP a e+    describe "card" $ do+        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+            forAll generateCardName $ \(a, e) ->+                parseShouldSucceedAs card ("card" ++ a ++ "{}") $+                Card e (Block [])+        it "succeeds on empty cards with whitespace around the name" $ do+            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+            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+            forAll generateCardName $ \(a, _) ->+                forAll generateWhiteSpace $ \ws ->+                    shouldFail card ("card" ++ a ++ ws)+        it "succeeds on this complicated example" $ do+            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" $+                Block+                    [ Alternatives ["$(HOST)", "shared"]+                    , Deploy "hello" "goodbye" (Just LinkDeployment)+                    , IntoDir "$(HOME)"+                    , OutofDir "depot"+                    , SparkOff (CardName (CardNameReference "othercard"))+                    , DeployKindOverride LinkDeployment+                    , Block+                          [ Deploy "one" "more" (Just CopyDeployment)+                          , Deploy "source" "destination" Nothing+                          , Deploy "file" "file" Nothing+                          ]+                    ]+    describe "declarations" $ do+        it "succeeds for generated declarations'" $ do pending+        let s = parseShouldSucceedAs declarations+        it "succeeds for these cases" $ do+            s "into dir;outof dir" [IntoDir "dir", OutofDir "dir"]+    describe "declaration" $ do+        it "succeeds for generated declarations" $ do pending+        let s = parseShouldSucceedAs declaration+        it "succeeds for these cases" $ do+            s "into directory" (IntoDir "directory")+            s "outof \"other directory\"" (OutofDir "other directory")+            s "{}" (Block [])+            s "{{{};{};{}}}" (Block [Block [Block [], Block [], Block []]])+            s+                "\"hi i'm a file\"c->iamthedestination"+                (Deploy+                     "hi i'm a file"+                     "iamthedestination"+                     (Just CopyDeployment))+    describe "block" $ do+        it "succeeds for empty blocks" $ do+            parseShouldSucceedAs block "{}" (Block [])+        it "succeeds for a doubly nested empty block" $ do+            parseShouldSucceedAs block "{{}}" (Block [Block []])+        it "succeeds for a triply nested empty block" $ do+            parseShouldSucceedAs block "{{{}}}" (Block [Block [Block []]])+        let s = parseShouldSucceedAs block+        it "succeeds for these cases" $ do+            s+                "{into ~;bashrc -> .bashrc}"+                (Block [IntoDir "~", Deploy "bashrc" ".bashrc" Nothing])+            s+                "{\n    into \"~\"\n    \"xmonad\" -> \".xmonad\"\n}"+                (Block [IntoDir "~", Deploy "xmonad" ".xmonad" Nothing])+    describe "sparkOff" $ do+        it "succeeds for generated sparkOff declarations" $ do pending+        let s f g =+                parseShouldSucceedAs+                    sparkOff+                    f+                    (SparkOff $ CardName $ CardNameReference g)+        it "succeeds for these cases" $ do+            s "spark card name" "name"+            s "sparkcardname" "name"+            s "spark card \"name with spaces\"" "name with spaces"+    describe "intoDir" $ do+        it "succeeds for generated into declarations" $ do+            forAll generateLineSpace $ \ls ->+                forAll generateDirectory $ \(d, da) ->+                    parseShouldSucceedAs+                        intoDir+                        ("into" ++ ls ++ d)+                        (IntoDir da)+        let s f g = parseShouldSucceedAs intoDir f (IntoDir g)+        it "succeeds for these cases" $ do+            s "into \"bash\"" "bash"+            s "into\t.xmonad" ".xmonad"+            s "into ~" "~"+    describe "outOfDir" $ do+        it "succeeds for generated outof declarations" $ do+            forAll generateLineSpace $ \ls ->+                forAll generateDirectory $ \(d, da) ->+                    parseShouldSucceedAs+                        outOfDir+                        ("outof" ++ ls ++ d)+                        (OutofDir da)+        let s f g = parseShouldSucceedAs outOfDir f (OutofDir g)+        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+            forAll (listOf1 generateDirectory) $ \ds ->+                let (des, das) = unzip ds+                in parseShouldSucceedAs+                       alternatives+                       ("alternatives" ++ " " ++ intercalate " " 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 ==>+                parseShouldSucceedAs shortDeployment f (Deploy f f Nothing)+        it "succeeds for generated filepaths with an identity deployment" $ do+            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 ==>+                parseShouldSucceedAs shortDeployment f (Deploy f f Nothing)+        it "succeeds for generated directories with an identity deployment" $ do+            forAll generateDirectory $ \(f, g) ->+                parseShouldSucceedAs shortDeployment f (Deploy g g Nothing)+        let s f = parseShouldSucceedAs shortDeployment f (Deploy f f Nothing)+        it "succeeds as-is for these cases" $ do+            s "file.txt"+            s "xmonad.hs"+            s "/home/user/.bashrc"+    describe "longDeployment" $ do+        it "succeeds for generated long deployments with quoted identifiers" $ do+            forAll generateDeploymentKindSymbol $ \dks ->+                forAll generateLineSpace $ \ls1 ->+                    forAll generateLineSpace $ \ls2 ->+                        forAll generateQuotedIdentifier $ \(fp1, fp1a) ->+                            forAll generateQuotedIdentifier $ \(fp2, fp2a) ->+                                case parseWithoutSource deploymentKind dks of+                                    Left _ ->+                                        fail+                                            "There was a problem with parsing the deployment kind"+                                    Right dk ->+                                        parseShouldSucceedAs+                                            longDeployment+                                            (fp1 ++ ls1 ++ dks ++ ls2 ++ fp2)+                                            (Deploy fp1a fp2a dk)+        it+            "succeeds for single-space-separated long deployments with gerenated plain identifiers" $ do+            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)+        it "succeeds for these cases" $ do+            s+                "\"something with spaces\"c->/home/user/test.txt"+                "something with spaces"+                "/home/user/test.txt"+                (Just CopyDeployment)+            s+                "\"xmonad.hs\"l-> /home/user/.xmonad/xmonad.hs"+                "xmonad.hs"+                "/home/user/.xmonad/xmonad.hs"+                (Just LinkDeployment)+            s+                "bashrc\t->\t/home/user/.bashrc"+                "bashrc"+                "/home/user/.bashrc"+                Nothing+    describe "deploymentKind" $ do+        let (-=>) = parseShouldSucceedAs deploymentKind+        it "succeeds for the link deployment kind" $ do+            "l->" -=> Just LinkDeployment+        it "succeeds for the copy deployment kind" $ do+            "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->", "->"]) ==>+                shouldFail deploymentKind s++cardReferenceParserTests :: Spec+cardReferenceParserTests = do+    describe "compilerCardReference" $ do pend+    describe "deployerCardReference" $ do pend+    describe "compiledCardReference" $ do pend+    describe "cardReference" $ do pend+    describe "cardNameReference" $ do+        pend+        let s f g =+                parseShouldSucceedAs cardNameReference f (CardNameReference g)+        it "succeeds for these cases" $ do+            s "card name" "name"+            s "cardname" "name"+            s "card \"name with spaces\"" "name with spaces"+    describe "cardFileReference" $ do+        pend+        let s = parseShouldSucceedAs cardFileReference+        it "succeeds for these cases" $ do+            s "file card.sus" (CardFileReference "card.sus" Nothing)+            s+                "file card.sus name"+                (CardFileReference "card.sus" $ Just $ CardNameReference "name")+    describe "unprefixedCardFileReference" $ do pend++parserBlackBoxTests :: Spec+parserBlackBoxTests = do+    testRecoursesDir <- runIO $ resolveDir' "test_resources"+    describe "Correct succesful parse examples" $ do+        let dirs =+                map+                    (testRecoursesDir </>)+                    [shouldParseDir, shouldCompileDir, shouldNotCompileDir]+        forFileInDirss dirs $+            concerningContents $ \f contents -> do+                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+                it (toFilePath f) $+                    parseCardFile f contents `shouldSatisfy` isLeft++toplevelParserTests :: Spec+toplevelParserTests = do+    describe "sparkFile" $ do+        it "Only ever produces valid SparkFile's" $+            validIfSucceeds2 parseCardFile+        pend+    describe "resetPosition" $ do pend
+ test/SuperUserSpark/PreCompiler/Gen.hs view
@@ -0,0 +1,12 @@+{-# OPTIONS_GHC -Wno-orphans #-}++module SuperUserSpark.PreCompiler.Gen where++import TestImport++import SuperUserSpark.Language.Gen ()+import SuperUserSpark.PreCompiler.Types++instance GenUnchecked PreCompileError++instance GenValid PreCompileError
+ test/TestImport.hs view
@@ -0,0 +1,32 @@+module TestImport+    ( module X+    ) where++import Prelude as X hiding (writeFile, readFile, putStr,putStrLn, appendFile)++import Path as X+import Path.IO as X++import Control.Monad as X+import Control.Monad.Except as X+import Control.Monad.IO.Class as X (MonadIO(..))+import Control.Monad.Identity as X+import Control.Monad.Reader as X+import Control.Monad.State as X+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++import Data.GenValidity as X+import Data.GenValidity.Path as X ()+import Data.Validity as X ()+import Data.Validity.Path as X ()+import Test.Validity as X+import Test.Validity.Aeson as X++import System.FilePath as X (dropTrailingPathSeparator)
+ test/TestUtils.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE TemplateHaskell #-}++module TestUtils where++import TestImport++shouldParseDir :: Path Rel Dir+shouldParseDir = $(mkRelDir "shouldParseDir")++shouldNotParseDir :: Path Rel Dir+shouldNotParseDir = $(mkRelDir "shouldNotParseDir")++shouldCompileDir :: Path Rel Dir+shouldCompileDir = $(mkRelDir "shouldCompileDir")++shouldNotCompileDir :: Path Rel Dir+shouldNotCompileDir = $(mkRelDir "shouldNotCompileDir")++concerningContents :: (Path Abs File -> String -> SpecWith a)+                   -> (Path Abs File -> SpecWith a)+concerningContents func file = (runIO $ readFile file) >>= func file++forFileInDirss :: [Path Abs Dir] -> (Path Abs File -> SpecWith a) -> SpecWith a+forFileInDirss [] _ = return ()+forFileInDirss dirs func =+    forM_ dirs $ \dir -> do+        exists <- runIO $ doesDirExist dir+        when exists $ do+            files <- runIO $ snd <$> listDirRecur dir+            forM_ files func++pend :: SpecWith ()+pend = it "is still missing some tests" pending