life-sync (empty) → 1.0
raw patch · 20 files changed
+1482/−0 lines, 20 filesdep +ansi-terminaldep +base-nopreludedep +bytestringsetup-changed
Dependencies added: ansi-terminal, base-noprelude, bytestring, containers, filepath, fmt, hedgehog, life-sync, microlens-platform, optparse-applicative, path, path-io, process, tasty, tasty-hedgehog, text, tomland, universum
Files
- CHANGELOG.md +12/−0
- LICENSE +21/−0
- README.md +153/−0
- Setup.hs +2/−0
- app/Main.hs +24/−0
- app/Options.hs +119/−0
- life-sync.cabal +101/−0
- src/Life/Configuration.hs +178/−0
- src/Life/Github.hs +204/−0
- src/Life/Main/Add.hs +95/−0
- src/Life/Main/Init.hs +114/−0
- src/Life/Main/Pull.hs +39/−0
- src/Life/Main/Push.hs +73/−0
- src/Life/Main/Remove.hs +50/−0
- src/Life/Message.hs +139/−0
- src/Life/Shell.hs +87/−0
- src/Life/Validation.hs +27/−0
- src/Prelude.hs +7/−0
- test/Spec.hs +1/−0
- test/Test/Roundtrip.hs +36/−0
+ CHANGELOG.md view
@@ -0,0 +1,12 @@+Change log+==========++life-sync uses [PVP Versioning][1].+The change log is available [on GitHub][2].++[1]: https://pvp.haskell.org+[2]: https://github.com/kowainik/life-sync/releases++# 1.0++* Initially created.
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2017 Dmitry Kovanikov++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,153 @@+# life-sync++[](https://hackage.haskell.org/package/life-sync)+[](https://travis-ci.org/kowainik/life-sync)+[](https://github.com/kowainik/life-sync/blob/master/LICENSE)+[](http://stackage.org/lts/package/life-sync)+[](http://stackage.org/nightly/package/life-sync)++`life-sync` is a CLI tool that makes it easier to synchronize `dotfiles`+repository with personal configs across multiple machines.++## Motivation++You might have some configuration files with different settings for your system.+For example:++1. Preferred settings for your editors (Spacemacs, Vim, etc.).+2. Useful bash aliases and other miscellaneous shell settings.+3. Git configuration.++And much more! But sometimes you start working from a new fresh machine without+having your settings within touch, like in these situations:++1. You bought a new PC or laptop.+2. You might reinstall your system on your working machine.+3. You were given a new laptop at work.++Every time this happens, you need to walk through the tedious process of copying+your data again. It's a well-known practice to+[store configs in `dotfiles` GitHub repository](https://dotfiles.github.io/).+And `life-sync` makes it much easier to maintain this repository! With a single+command, your can copy every file and directory from `dotfiles` repository to+your machine. Or update your remote `dotfiles` repository after multiple local+changes to different files.++## Installation++Installation process can be done with one simple command:++```shell+$ cabal install life-sync+```++or++```shell+$ stack install life-sync-1.0+```++You can turn on the bash auto-completion by running the following command:++```+$ source <(life --bash-completion-script `which life`)+```++## Usage++> **NOTE:** make sure you configured SSH for your Github. `life-sync` assumes+> that you have SSH configured.++After installing `life-sync` you need to call command `life` with specified options:++```+$ life --help+Usage: life COMMAND+ life-sync synchronize your personal configs++Available options:+ -h,--help Show this help text++Available commands:+ init Initialize GitHub repository named 'dotfiles' if you+ don't have one.+ add Add file or directory to the life configuration.+ remove Remove file or directory from the life configuration.+ push Updates GitHub repository from local state and push+ the latest version.+ pull Updates local state of '.life' and 'dotfiles' from+ GitHub repository.++`life init` usage: life init OWNER+ OWNER Your github user name++`life add` usage: life add ((-f|--file FILE_PATH) | (-d|--dir DIRECTORY_PATH))+ -f,--file FILE_PATH File to add+ -d,--dir FILE_PATH Directory to add++`life remove` usage: life remove ((-f|--file FILE_PATH) | (-d|--dir DIRECTORY_PATH))+ -f,--file FILE_PATH File to remove+ -d,--dir FILE_PATH Directory to remote++`life push` usage: life push++`life pull` usage: life pull OWNER [-f|--no-file FILE_PATH] [-d|--no-dir FILE_PATH]+ OWNER Your github user name+ -f,--no-file FILE_PATH Excluding these specific files from copying+ -d,--no-dir FILE_PATH Excluding these specific directories from copying++```++> **NOTE:** If some command takes a path to a file or a directory as an+> argument, the path should be specifed relative to the home directory.++`life-sync` keeps the structure of your `dotfiles` repository in its own file+called `.life` which is stored in `dotfiles` repository as well.++You can see an example of `dotfiles` repository maintained by `life-sync` here:++* [ChShersh/dotfiles](https://github.com/ChShersh/dotfiles)++## Examples++### Create `dotfiles` repository for the first time++```+$ life init MyGithubName+```++### Track new file or directory++To track a file:++```+$ life add -f path/to/file/relative/from/home+```++To track a directory:++```+$ life add -d path/to/dir/relative/from/home+```++To stop tracking some file, use `life remove` command instead.++### Push all changes to remote repository++```+$ life push+```++### Pull all changes from remote repository++To pull every file and directory:++```+$ life pull ChShersh+```++To pull everything except some files or some directories:++```+$ life pull ChShersh --no-file some/file --no-dir some/dir+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,24 @@+module Main where++import Path (parseRelDir, parseRelFile)++import Life.Main.Add (lifeAdd)+import Life.Main.Init (lifeInit)+import Life.Main.Pull (lifePull)+import Life.Main.Push (lifePush)+import Life.Main.Remove (lifeRemove)++import Options (LifeCommand (..), PathOptions (..), PullOptions (..), parseCommand)++import qualified Data.Set as Set++main :: IO ()+main = parseCommand >>= \case+ Init owner -> lifeInit owner+ Add PathOptions{..} -> lifeAdd pathOptionsPath+ Remove PathOptions{..} -> lifeRemove pathOptionsPath+ Push -> lifePush+ Pull PullOptions{..} -> do+ withoutFiles <- Set.fromList <$> mapM parseRelFile pullOptionsNoFiles+ withoutDirs <- Set.fromList <$> mapM parseRelDir pullOptionsNoDirs+ lifePull pullOptionsOwner withoutFiles withoutDirs
+ app/Options.hs view
@@ -0,0 +1,119 @@+{-# LANGUAGE ApplicativeDo #-}++-- | Command line options for Importify++module Options+ ( LifeCommand (..)+ , PathOptions (..)+ , PullOptions (..)++ , parseCommand+ ) where++import Options.Applicative (Parser, ParserInfo, command, execParser, fullDesc, help, helper, info,+ long, metavar, progDesc, short, strArgument, strOption, subparser)++import Life.Configuration (LifePath (..))+import Life.Github (Owner (..))++-- | Commands to execute+data LifeCommand+ = Init Owner+ | Add PathOptions+ | Remove PathOptions+ | Push+ | Pull PullOptions+ deriving (Show)++---------------------------------------------------------------------------+-- Boilerplate+----------------------------------------------------------------------------++commandParser :: Parser LifeCommand+commandParser = subparser $+ command "init"+ (info (helper <*> fmap Init ownerParser)+ (fullDesc <> progDesc "Initialize GitHub repository named 'dotfiles' if you don't have one."))+ <> command "add"+ (info (helper <*> fmap Add pathOptionsParser)+ (fullDesc <> progDesc "Add file or directory to the life configuration."))+ <> command "remove"+ (info (helper <*> fmap Remove pathOptionsParser)+ (fullDesc <> progDesc "Remove file or directory from the life configuration."))+ <> command "push"+ (info (helper <*> pure Push)+ (fullDesc <> progDesc "Updates GitHub repository from local state and push the latest version."))+ <> command "pull"+ (info (helper <*> fmap Pull pullOptionsParser)+ (fullDesc <> progDesc "Updates local state of '.life' and 'dotfiles' from GitHub repository."))+++optionsInfo :: ParserInfo LifeCommand+optionsInfo = info+ (helper <*> commandParser)+ (fullDesc <> progDesc "life-sync synchronize your personal configs")++parseCommand :: IO LifeCommand+parseCommand = execParser optionsInfo++ownerParser :: Parser Owner+ownerParser = fmap Owner+ $ strArgument+ $ metavar "OWNER"+ <> help "Your github user name"++----------------------------------------------------------------------------+-- life pull+----------------------------------------------------------------------------++data PullOptions = PullOptions+ { pullOptionsOwner :: Owner+ , pullOptionsNoFiles :: [FilePath]+ , pullOptionsNoDirs :: [FilePath]+ } deriving (Show)++pullOptionsParser :: Parser PullOptions+pullOptionsParser = do+ pullOptionsOwner <- ownerParser++ -- TODO: reuse LifePath parser here?...+ pullOptionsNoFiles <- many $ strOption+ $ metavar "FILE_PATH"+ <> long "no-file"+ <> short 'f'+ <> help "Excluding these specific files from copying"++ pullOptionsNoDirs <- many $ strOption+ $ metavar "FILE_PATH"+ <> long "no-dir"+ <> short 'd'+ <> help "Excluding these specific directories from copying"++ pure PullOptions{..}++----------------------------------------------------------------------------+-- life add and remove+----------------------------------------------------------------------------++data PathOptions = PathOptions+ { pathOptionsPath :: LifePath+ } deriving (Show)++pathOptionsParser :: Parser PathOptions+pathOptionsParser = do+ pathOptionsPath <- fileParser <|> dirParser+ pure PathOptions{..}+ where+ fileParser :: Parser LifePath+ fileParser = File <$> strOption+ ( metavar "FILE_PATH"+ <> long "file"+ <> short 'f'+ )++ dirParser :: Parser LifePath+ dirParser = Dir <$> strOption+ ( metavar "DIRECTORY_PATH"+ <> long "dir"+ <> short 'd'+ )
+ life-sync.cabal view
@@ -0,0 +1,101 @@+name: life-sync+version: 1.0+description: Synchronize personal configs across multiple machines+homepage: https://github.com/kowainik/life-sync+bug-reports: https://github.com/kowainik/life-sync/issues+license: MIT+license-file: LICENSE+author: Kowainik+maintainer: xrom.xkov@gmail.com+copyright: 2018 Kowainik+category: Configuration+stability: experimental+build-type: Simple+cabal-version: 2.0+tested-with: GHC == 8.2.2+ , GHC == 8.4.3+extra-doc-files: README.md+ , CHANGELOG.md++source-repository head+ type: git+ location: https://github.com/kowainik/life-sync.git++library+ hs-source-dirs: src++ exposed-modules: Prelude+ Life.Configuration+ Life.Github+ Life.Message+ Life.Shell+ Life.Main.Add+ Life.Main.Init+ Life.Main.Pull+ Life.Main.Push+ Life.Main.Remove+ Life.Validation++ build-depends: base-noprelude >= 4.9 && < 5+ , ansi-terminal+ , bytestring+ , containers+ , fmt+ , microlens-platform+ , path+ , path-io+ , process+ , text >= 1.2+ , tomland >= 0.2.1+ , universum >= 1.2.0++ ghc-options: -Wall+ default-language: Haskell2010++ default-extensions: GeneralizedNewtypeDeriving+ LambdaCase+ OverloadedStrings+ RecordWildCards+ ScopedTypeVariables+ TypeApplications++executable life+ hs-source-dirs: app+ main-is: Main.hs+ other-modules: Options+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N++ build-depends: base-noprelude+ , containers+ , life-sync+ , optparse-applicative+ , path++ default-language: Haskell2010++ default-extensions: LambdaCase+ OverloadedStrings+ RecordWildCards++test-suite life-sync-test+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ other-modules: Test.Roundtrip++ build-tool-depends: tasty-discover:tasty-discover+ build-depends: base-noprelude, life-sync+ , containers+ , filepath+ , hedgehog+ , path+ , tasty+ , tasty-hedgehog++ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+ default-language: Haskell2010++ default-extensions: LambdaCase+ OverloadedStrings+ RecordWildCards+ TypeApplications
+ src/Life/Configuration.hs view
@@ -0,0 +1,178 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++-- | Contains configuration data type.++module Life.Configuration+ ( LifePath (..)++ , LifeConfiguration (..)+ , singleDirConfig+ , singleFileConfig++ , lifeConfigMinus++-- -- * Parsing exceptions+-- , ParseLifeException (..)++ -- * Lenses for 'LifeConfiguration'+ , files+ , directories++ -- * Parse 'LifeConfiguration' under @~/.life@+ , parseHomeLife+ , parseRepoLife+ , parseLifeConfiguration++ -- * Render 'LifeConfiguration' under @~/.life@+ , renderLifeConfiguration+ , writeGlobalLife+ ) where++import Fmt (indentF, unlinesF, (+|), (|+))+import Lens.Micro.Platform (makeFields)+import Path (Dir, File, Path, Rel, fromAbsFile, parseRelDir, parseRelFile, toFilePath, (</>))+import Toml (BiToml, Valuer (..), (.=))++import Life.Shell (lifePath, relativeToHome, repoName)++import qualified Data.Set as Set+import qualified Text.Show as Show+import qualified Toml+++-- | Data type to represent either file or directory.+data LifePath = File FilePath | Dir FilePath+ deriving (Show)++----------------------------------------------------------------------------+-- Life Configuration data type with lenses+----------------------------------------------------------------------------++data LifeConfiguration = LifeConfiguration+ { lifeConfigurationFiles :: Set (Path Rel File)+ , lifeConfigurationDirectories :: Set (Path Rel Dir)+ } deriving (Show, Eq)++makeFields ''LifeConfiguration++----------------------------------------------------------------------------+-- Algebraic instances and utilities+----------------------------------------------------------------------------++instance Semigroup LifeConfiguration where+ life1 <> life2 = LifeConfiguration+ { lifeConfigurationFiles = life1^.files <> life2^.files+ , lifeConfigurationDirectories = life1^.directories <> life2^.directories+ }++instance Monoid LifeConfiguration where+ mempty = LifeConfiguration mempty mempty+ mappend = (<>)++singleFileConfig :: Path Rel File -> LifeConfiguration+singleFileConfig file = mempty & files .~ one file++singleDirConfig :: Path Rel Dir -> LifeConfiguration+singleDirConfig dir = mempty & directories .~ one dir++----------------------------------------------------------------------------+-- LifeConfiguration difference+----------------------------------------------------------------------------++lifeConfigMinus :: LifeConfiguration -- ^ repo .life config+ -> LifeConfiguration -- ^ global config+ -> LifeConfiguration -- ^ configs that are not in global+lifeConfigMinus dotfiles global = LifeConfiguration+ (Set.difference (dotfiles ^. files) (global ^. files))+ (Set.difference (dotfiles ^. directories) (global ^. directories))++----------------------------------------------------------------------------+-- Toml parser for life configuration+----------------------------------------------------------------------------++data CorpseConfiguration = CorpseConfiguration+ { corpseFiles :: [FilePath]+ , corpseDirectories :: [FilePath]+ }++corpseConfiguationT :: BiToml CorpseConfiguration+corpseConfiguationT = CorpseConfiguration+ <$> Toml.arrayOf stringV "files" .= corpseFiles+ <*> Toml.arrayOf stringV "directories" .= corpseDirectories+ where+ stringV :: Valuer 'Toml.TString String+ stringV = Valuer (Toml.matchText >=> pure . toString) (Toml.String . toText)++resurrect :: MonadThrow m => CorpseConfiguration -> m LifeConfiguration+resurrect CorpseConfiguration{..} = do+ filePaths <- mapM parseRelFile corpseFiles+ dirPaths <- mapM parseRelDir corpseDirectories++ pure $ LifeConfiguration+ { lifeConfigurationFiles = Set.fromList filePaths+ , lifeConfigurationDirectories = Set.fromList dirPaths+ }++-- TODO: should tomland one day support this?...+-- | Converts 'LifeConfiguration' into TOML file.+renderLifeConfiguration :: Bool -- ^ True to see empty entries in output+ -> LifeConfiguration+ -> Text+renderLifeConfiguration printIfEmpty LifeConfiguration{..} = mconcat $+ maybeToList (render "directories" lifeConfigurationDirectories)+ ++ [ "\n" ]+ ++ maybeToList (render "files" lifeConfigurationFiles)+ where+ render :: Text -> Set (Path b t) -> Maybe Text+ render key paths = do+ let prefix = key <> " = "+ let array = renderStringArray (length prefix) (map show $ toList paths)++ if not printIfEmpty && null paths+ then Nothing+ else Just $ prefix <> array++ renderStringArray :: Int -> [String] -> Text+ renderStringArray _ [] = "[]"+ renderStringArray n (x:xs) = "[ " +| x |+ "\n"+ +| indentF n (unlinesF (map (", " ++) xs ++ ["]"]))+ |+ ""++writeGlobalLife :: LifeConfiguration -> IO ()+writeGlobalLife config = do+ lifeFilePath <- relativeToHome lifePath+ writeFile (fromAbsFile lifeFilePath) (renderLifeConfiguration True config)++----------------------------------------------------------------------------+-- Life configuration parsing+----------------------------------------------------------------------------++parseLifeConfiguration :: MonadThrow m => Text -> m LifeConfiguration+parseLifeConfiguration tomlText = case Toml.decode corpseConfiguationT tomlText of+ Left err -> throwM $ LoadTomlException (toFilePath lifePath) $ Toml.prettyException err+ Right cfg -> resurrect cfg++parseLife :: Path Rel File -> IO LifeConfiguration+parseLife path = relativeToHome path+ >>= readFile . fromAbsFile+ >>= parseLifeConfiguration++-- | Reads 'LifeConfiguration' from @~\/.life@ file.+parseHomeLife :: IO LifeConfiguration+parseHomeLife = parseLife lifePath++-- | Reads 'LifeConfiguration' from @~\/dotfiles\/.life@ file.+parseRepoLife :: IO LifeConfiguration+parseRepoLife = parseLife (repoName </> lifePath)++data LoadTomlException = LoadTomlException FilePath Text++instance Show.Show LoadTomlException where+ show (LoadTomlException filePath msg) = "Couldnt parse file " ++ filePath ++ ": " ++ show msg++instance Exception LoadTomlException
+ src/Life/Github.hs view
@@ -0,0 +1,204 @@+-- | Utilities to work with GitHub repositories using "hub".++module Life.Github+ ( Owner (..)+ , Repo (..)++ -- * Repository utils+ , checkRemoteSync+ , cloneRepo+ , insideRepo+ , withSynced++ -- * Repository manipulation commands+ , CopyDirection (..)+ , copyLife+ , addToRepo+ , createRepository+ , pullUpdateFromRepo+ , removeFromRepo+ , updateDotfilesRepo+ , updateFromRepo+ ) where++import Control.Exception (throwIO)+import Path (Abs, Dir, File, Path, Rel, toFilePath, (</>))+import Path.IO (copyDirRecur, copyFile, getHomeDir, withCurrentDir)+import System.IO.Error (IOError, isDoesNotExistError)++import Life.Configuration (LifeConfiguration (..), lifeConfigMinus, parseRepoLife)+import Life.Message (chooseYesNo, errorMessage, infoMessage, warningMessage)+import Life.Shell (lifePath, relativeToHome, repoName, ($|))++newtype Owner = Owner { getOwner :: Text } deriving (Show)+newtype Repo = Repo { getRepo :: Text } deriving (Show)++----------------------------------------------------------------------------+-- VSC commands+----------------------------------------------------------------------------++askToPushka :: Text -> IO ()+askToPushka commitMsg = do+ "git" ["add", "."]+ infoMessage "The following changes are going to be pushed:"+ "git" ["diff", "--name-status", "HEAD"]+ continue <- chooseYesNo "Would you like to proceed?"+ if continue+ then pushka commitMsg+ else errorMessage "Abort pushing" >> exitFailure++-- | Make a commit and push it.+pushka :: Text -> IO ()+pushka commitMsg = do+ "git" ["add", "."]+ "git" ["commit", "-m", commitMsg]+ "git" ["push", "-u", "origin", "master"]++-- | Creates repository on GitHub inside given folder.+createRepository :: Owner -> Repo -> IO ()+createRepository (Owner owner) (Repo repo) = do+ let description = ":computer: Configuration files"+ "git" ["init"]+ "hub" ["create", "-d", description, owner <> "/" <> repo]+ pushka "Create the project"++----------------------------------------------------------------------------+-- dotfiles workflow+----------------------------------------------------------------------------++-- | Executes action with 'repoName' set as pwd.+insideRepo :: (MonadIO m, MonadMask m) => m a -> m a+insideRepo action = do+ repoPath <- relativeToHome repoName+ withCurrentDir repoPath action++-- | Commits all changes inside 'repoName' and pushes to remote.+pushRepo :: Text -> IO ()+pushRepo = insideRepo . askToPushka++-- | Clones @dotfiles@ repository assuming it doesn't exist.+cloneRepo :: Owner -> IO ()+cloneRepo (Owner owner) = do+ homeDir <- getHomeDir+ withCurrentDir homeDir $ do+ infoMessage "Using SSH to clone repo..."+ "git" ["clone", "git@github.com:" <> owner <> "/dotfiles.git"]++-- | Returns true if local @dotfiles@ repository is synchronized with remote repo.+checkRemoteSync :: IO Bool+checkRemoteSync = do+ "git" ["fetch", "origin", "master"]+ localHash <- "git" $| ["rev-parse", "master"]+ remoteHash <- "git" $| ["rev-parse", "origin/master"]+ pure $ localHash == remoteHash++withSynced :: IO a -> IO a+withSynced action = insideRepo $ do+ infoMessage "Checking if repo is synchnorized..."+ isSynced <- checkRemoteSync+ if isSynced then do+ infoMessage "Repo is up-to-date"+ action+ else do+ warningMessage "Local version of repository is out of date"+ shouldSync <- chooseYesNo "Do you want to sync repo with remote?"+ if shouldSync then do+ "git" ["rebase", "origin/master"]+ action+ else do+ errorMessage "Aborting current command because repository is not synchronized with remote"+ exitFailure++----------------------------------------------------------------------------+-- File manipulation+----------------------------------------------------------------------------++data CopyDirection = FromHomeToRepo | FromRepoToHome++pullUpdateFromRepo :: LifeConfiguration -> IO ()+pullUpdateFromRepo life = do+ insideRepo $ "git" ["pull", "-r"]+ updateFromRepo life++updateFromRepo :: LifeConfiguration -> IO ()+updateFromRepo excludeLife = insideRepo $ do+ infoMessage "Copying files from repo to local machine..."++ repoLife <- parseRepoLife+ let lifeToLive = lifeConfigMinus repoLife excludeLife++ copyLife FromRepoToHome lifeToLive++updateDotfilesRepo :: Text -> LifeConfiguration -> IO ()+updateDotfilesRepo commitMsg life = do+ copyLife FromHomeToRepo life+ pushRepo commitMsg++copyLife :: CopyDirection -> LifeConfiguration -> IO ()+copyLife direction LifeConfiguration{..} = do+ copyFiles direction (toList lifeConfigurationFiles)+ copyDirs direction (toList lifeConfigurationDirectories)++-- | Copy files to repository and push changes to remote repository.+copyFiles :: CopyDirection -> [Path Rel File] -> IO ()+copyFiles = copyPathList copyFile++-- | Copy dirs to repository.+copyDirs :: CopyDirection -> [Path Rel Dir] -> IO ()+copyDirs = copyPathList copyDirRecur++copyPathList :: (Path Abs t -> Path Abs t -> IO ())+ -- ^ Copying action+ -> CopyDirection+ -- ^ Describes in which direction files should be copied+ -> [Path Rel t]+ -- ^ List of paths to copy+ -> IO ()+copyPathList copyAction direction pathList = do+ homeDir <- getHomeDir+ let repoDir = homeDir </> repoName++ for_ pathList $ \entryPath -> do+ let homePath = homeDir </> entryPath+ let repoPath = repoDir </> entryPath+ case direction of+ FromHomeToRepo -> copyAction homePath repoPath+ FromRepoToHome -> copyAction repoPath homePath++-- | Adds file or directory to the repository and commits+addToRepo :: (Path Abs t -> Path Abs t -> IO ()) -> Path Rel t -> IO ()+addToRepo copyFun path = do+ -- copy file+ sourcePath <- relativeToHome path+ destinationPath <- relativeToHome (repoName </> path)+ copyFun sourcePath destinationPath++ -- update .life file+ lifeFile <- relativeToHome lifePath+ repoLifeFile <- relativeToHome (repoName </> lifePath)+ copyFile lifeFile repoLifeFile++ let commitMsg = "Add: " <> toText (toFilePath path)+ pushRepo commitMsg++-- | Removes file or directory from the repository and commits+removeFromRepo :: (Path Abs t -> IO ()) -> Path Rel t -> IO ()+removeFromRepo removeFun path = do+ absPath <- relativeToHome (repoName </> path)+ catch (removeFun absPath) handleNotExist++ -- update .life file+ lifeFile <- relativeToHome lifePath+ repoLifeFile <- relativeToHome (repoName </> lifePath)+ copyFile lifeFile repoLifeFile++ let commitMsg = "Remove: " <> pathTextName+ pushRepo commitMsg+ where+ pathTextName :: Text+ pathTextName = toText $ toFilePath path++ handleNotExist :: IOError -> IO ()+ handleNotExist e = if isDoesNotExistError e+ then errorMessage ("File/directory " <> pathTextName <> " is not found") >> exitFailure+ else throwIO e
+ src/Life/Main/Add.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE Rank2Types #-}++-- | Functions to add file/directory to your life.++module Life.Main.Add+ ( lifeAdd+ ) where++import Path (Abs, Dir, File, Path, Rel, parent, toFilePath, (</>))+import Path.IO (copyDirRecur, copyFile, doesDirExist, doesFileExist, ensureDir, getHomeDir,+ makeRelative, resolveDir, resolveFile)++import Life.Configuration (LifeConfiguration, LifePath (..), directories, files, parseHomeLife,+ writeGlobalLife)+import Life.Github (addToRepo, withSynced)+import Life.Main.Init (lifeInitQuestion)+import Life.Message (abortCmd, errorMessage, infoMessage, warningMessage)+import Life.Shell (LifeExistence (..), relativeToHome, repoName, whatIsLife)++import qualified Data.ByteString.Lazy as LBS+import qualified Data.Set as Set++-- | Add path to existing life-configuration file.+lifeAdd :: LifePath -> IO ()+lifeAdd lPath = whatIsLife >>= \case+ -- actual life add process+ Both _ _ -> withSynced addingProcess++ -- if one of them is missing -- abort+ OnlyRepo _ -> abortCmd "add" ".life file doesn't exist"+ OnlyLife _ -> abortCmd "add" "dotfiles/ directory doesn't exist"++ -- if both .life and dotfiles doesn't exist go to init process+ NoLife -> lifeInitQuestion "add" addingProcess+ where+ addingProcess :: IO ()+ addingProcess = do+ homeDirPath <- getHomeDir+ case lPath of+ (File path) -> do+ filePath <- resolveFile homeDirPath path+ whenM (doesFileExist filePath) $ do+ relativeFile <- makeRelative homeDirPath filePath+ resolveConfiguration files checkEqualFiles copyFileWithDir relativeFile++ (Dir path) -> do+ dirPath <- resolveDir homeDirPath path+ whenM (doesDirExist dirPath) $ do+ relativeDir <- makeRelative homeDirPath dirPath+ resolveConfiguration directories checkEqualDirs copyDirRecur relativeDir++ -- We didn't find the file+ errorMessage "The file/directory doesn't exist" >> exitFailure++resolveConfiguration :: Lens' LifeConfiguration (Set (Path Rel t))+ -> (Path Rel t -> IO Bool)+ -> (Path Abs t -> Path Abs t -> IO ())+ -> Path Rel t+ -> IO ()+resolveConfiguration confLens checkContent copyFun path = do+ configuration <- parseHomeLife+ let newConfiguration = configuration & confLens %~ Set.insert path++ isSameAsInRepo <- checkContent path+ if isSameAsInRepo then do+ let pathText = toText $ toFilePath path+ infoMessage $ "Path " <> pathText <> " is already latest version in repository"+ else do+ writeGlobalLife newConfiguration+ addToRepo copyFun path++ exitSuccess++checkEqualFiles :: Path Rel File -> IO Bool+checkEqualFiles path = do+ homeFilePath <- relativeToHome path+ repoFilePath <- relativeToHome (repoName </> path)++ isRepoFile <- doesFileExist repoFilePath+ if isRepoFile then do+ originContent <- LBS.readFile $ toFilePath homeFilePath+ repoContent <- LBS.readFile $ toFilePath repoFilePath++ pure $ originContent == repoContent+ else+ pure False++checkEqualDirs :: Path Rel Dir -> IO Bool+checkEqualDirs _ = do+ warningMessage "TODO: check directories to be equal"+ pure True++-- | Just like 'copyFile' but also creates directory for second file.+copyFileWithDir :: Path Abs File -> Path Abs File -> IO ()+copyFileWithDir from to = ensureDir (parent to) >> copyFile from to
+ src/Life/Main/Init.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE TemplateHaskell #-}++-- | Contains function to create repository.++module Life.Main.Init+ ( lifeInit+ , lifeInitQuestion+ ) where++import Path (mkRelFile)+import Path.IO (doesDirExist, doesFileExist)++import Life.Configuration (LifeConfiguration (..), parseHomeLife, renderLifeConfiguration,+ singleFileConfig, writeGlobalLife)+import Life.Github (CopyDirection (..), Owner (..), Repo (Repo), copyLife, createRepository,+ insideRepo)+import Life.Message (abortCmd, chooseYesNo, infoMessage, promptNonEmpty, skipMessage,+ successMessage, warningMessage)+import Life.Shell (LifeExistence (..), createDirInHome, lifePath, relativeToHome, repoName,+ whatIsLife)++import qualified Data.Set as Set++predefinedLifeConfig :: LifeConfiguration+predefinedLifeConfig = mempty+ { lifeConfigurationFiles = Set.fromList+ [ $(mkRelFile ".bash_profile")+ , $(mkRelFile ".profile")+ , $(mkRelFile ".vimrc")+ , $(mkRelFile ".emacs")+ , $(mkRelFile ".spacemacs")+ , $(mkRelFile ".gitconfig")+ , $(mkRelFile ".ghc/ghci.conf")+ , $(mkRelFile ".stylish-haskell.yaml")+ ]+ }++lifeInit :: Owner -> IO ()+lifeInit owner = whatIsLife >>= \case+ NoLife -> createLifeFile >>= createDotfilesDir+ OnlyLife _ -> askCreateLife >>= createDotfilesDir+ OnlyRepo _ -> abortCmd "init" "'~/dotfiles' directory already exist" -- TODO: initialize .life from repo? :thinking_suicide:+ Both _ _ -> abortCmd "init" "'~/.life' file and '~/.dotfiles' directory are already initialized"+ where+ askCreateLife :: IO LifeConfiguration+ askCreateLife = do+ warningMessage ".life file is already exist."+ useIt <- chooseYesNo "Would you like to use it?"+ if useIt then parseHomeLife else createLifeFile++ createLifeFile :: IO LifeConfiguration+ createLifeFile = do+ infoMessage "Checking existence of some commonly used predefined files..."+ (exist, noExist) <- scanConfig predefinedLifeConfig++ unless (noExist == mempty) $ do+ infoMessage "The following files and directories weren't found; they won't be added to '~/.life' file:"+ skipMessage $ renderLifeConfiguration False noExist++ unless (exist == mempty) $ do+ infoMessage "Found the following files and directories:"+ successMessage $ renderLifeConfiguration False exist++ useDiscovered <- chooseYesNo "Would you like to add all discovered existing files and directories to .life configuration?"+ let lifeConfig = singleFileConfig lifePath <> (if useDiscovered then exist else mempty)++ infoMessage "Initializing global .life configuration file..."+ writeGlobalLife lifeConfig+ pure lifeConfig++ createDotfilesDir :: LifeConfiguration -> IO ()+ createDotfilesDir lifeConfig = do+ () <$ createDirInHome repoName+ insideRepo $ do+ copyLife FromHomeToRepo lifeConfig+ createRepository owner (Repo "dotfiles")++{- | Split given configuration into two:++1. All files and directories which exist on machine.+2. Other non-existing files and dirs.+-}+scanConfig :: LifeConfiguration -> IO (LifeConfiguration, LifeConfiguration)+scanConfig LifeConfiguration{..} = do+ (existingFiles, nonExistingFiles) <- partitionM (relativeToHome >=> doesFileExist) lifeConfigurationFiles+ (existingDirs, nonExistingDirs) <- partitionM (relativeToHome >=> doesDirExist) lifeConfigurationDirectories+ pure ( LifeConfiguration (Set.fromList existingFiles) (Set.fromList existingDirs)+ , LifeConfiguration (Set.fromList nonExistingFiles) (Set.fromList nonExistingDirs)+ )++partitionM :: forall f m a . (Monad m, Foldable f) => (a -> m Bool) -> f a -> m ([a], [a])+partitionM check = foldM partitionAction ([], [])+ where+ partitionAction :: ([a], [a]) -> a -> m ([a], [a])+ partitionAction (ifTrue, ifFalse) a = check a >>= \case+ True -> pure (a : ifTrue, ifFalse)+ False -> pure (ifTrue, a : ifFalse)+++-- | If @.life@ and @dotfiles@ are not present you could want+-- to ask one if it needed to be initialised.+lifeInitQuestion :: Text -- ^ Command name+ -> IO () -- ^ Process to do+ -> IO ()+lifeInitQuestion cmd process = do+ warningMessage ".life file and dotfiles/ do not exist"+ toInit <- chooseYesNo "Would you like to proceed initialization process?"+ if toInit then do+ infoMessage "Initialization process starts.."+ skipMessage "Insert your GitHub username:"+ owner <- promptNonEmpty+ lifeInit $ Owner owner+ process+ else abortCmd cmd "'~/.life' file is not initialized"
+ src/Life/Main/Pull.hs view
@@ -0,0 +1,39 @@+-- | Command to update local state from remote state.++module Life.Main.Pull+ ( lifePull+ ) where++import Path (Dir, File, Path, Rel)++import Life.Configuration (LifeConfiguration (..))+import Life.Github (Owner, cloneRepo, pullUpdateFromRepo, updateFromRepo)+import Life.Main.Init (lifeInitQuestion)+import Life.Message (abortCmd, choose, warningMessage)+import Life.Shell (LifeExistence (..), whatIsLife)++lifePull :: Owner -> Set (Path Rel File) -> Set (Path Rel Dir) -> IO ()+lifePull owner withoutFiles withoutDirs = whatIsLife >>= \case+ OnlyRepo _ -> warningMessage ".life file not found" >> pullUpdate+ OnlyLife _ -> warningMessage "dotfiles not found" >> clone >> update+ NoLife -> initOrPull+ Both _ _ -> pullUpdate+ where+ initOrPull :: IO ()+ initOrPull = do+ warningMessage ".life file and dotfiles repo not found"+ action <- choose "Do you want to (F)etch existing repo, (I)nit from scratch or (A)bort operation?"+ ["f", "i", "a"]+ case action of+ "f" -> clone >> update+ "i" -> lifeInitQuestion "pull" pass+ "a" -> abortCmd "pull" "Cannot find .life and dotfiles"+ _ -> error "Impossible choice"++ life :: LifeConfiguration+ life = LifeConfiguration withoutFiles withoutDirs++ clone, update, pullUpdate :: IO ()+ clone = cloneRepo owner+ update = updateFromRepo life+ pullUpdate = pullUpdateFromRepo life
+ src/Life/Main/Push.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE TupleSections #-}++-- | Functions to update remote repository++module Life.Main.Push+ ( lifePush+ ) where++import Path (Abs, Path, Rel, toFilePath, (</>))+import Path.IO (doesDirExist, doesFileExist, removeDirRecur, removeFile)++import Life.Configuration (LifeConfiguration (..), directories, files, lifeConfigMinus,+ parseHomeLife, parseRepoLife)+import Life.Github (updateDotfilesRepo, withSynced)+import Life.Main.Init (lifeInitQuestion)+import Life.Message (abortCmd)+import Life.Shell (LifeExistence (..), relativeToHome, repoName, whatIsLife)+import Life.Validation (Validation (..))++import qualified Data.Set as Set+import qualified Data.Text as Text++lifePush :: IO ()+lifePush = whatIsLife >>= \case+ OnlyRepo _ -> abortCmd "push" ".life file doesn't exist"+ OnlyLife _ -> abortCmd "push" "dotfiles file doesn't exist"+ NoLife -> lifeInitQuestion "push" pushProcess+ Both _ _ -> withSynced pushProcess+ where+ pushProcess :: IO ()+ pushProcess = do+ -- check that all from .life exist+ globalConf <- parseHomeLife+ checkLife globalConf >>= \case+ Failure msgs -> abortCmd "push" $ "Following files/directories are missing:\n"+ <> Text.intercalate "\n" msgs+ Success _ -> do+ -- first, find the difference between repo .life and global .life+ repoConf <- parseRepoLife+ let removeConfig = lifeConfigMinus repoConf globalConf+ -- delete all redundant files from local dotfiles+ removeAll removeConfig++ -- copy from local files to repo including .life+ -- commmit & push+ updateDotfilesRepo "Push updates" globalConf+++ -- | checks if all the files/dirs from global .life exist.+ checkLife :: LifeConfiguration -> IO (Validation [Text] LifeConfiguration)+ checkLife lf = do+ eFiles <- traverse (withExist doesFileExist) $ Set.toList (lf ^. files)+ eDirs <- traverse (withExist doesDirExist) $ Set.toList (lf ^. directories)+ pure $ LifeConfiguration+ <$> checkPaths eFiles+ <*> checkPaths eDirs+ where+ withExist :: (Path Abs f -> IO Bool) -> Path Rel f -> IO (Path Rel f, Bool)+ withExist doesExist path = (path,) <$> (relativeToHome path >>= doesExist)++ checkPaths :: [(Path Rel f, Bool)] -> Validation [Text] (Set (Path Rel f))+ checkPaths = fmap Set.fromList . traverse checkPath++ checkPath :: (Path Rel t, Bool) -> Validation [Text] (Path Rel t)+ checkPath (f, is) = if is then Success f else Failure [toText (toFilePath f)]++ -- | removes all redundant files from repo folder.+ removeAll :: LifeConfiguration -> IO ()+ removeAll conf = do+ for_ (conf ^. files) $ \f ->+ relativeToHome (repoName </> f) >>= removeFile+ for_ (conf ^. directories) $ \d ->+ relativeToHome (repoName </> d) >>= removeDirRecur
+ src/Life/Main/Remove.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE Rank2Types #-}++-- | Functions to remove from your life.++module Life.Main.Remove+ ( lifeRemove+ ) where++import Path (Abs, Path, Rel)+import Path.IO (getHomeDir, makeRelative, removeDirRecur, removeFile, resolveDir, resolveFile)++import Life.Configuration (LifeConfiguration, LifePath (..), directories, files, parseHomeLife,+ writeGlobalLife)+import Life.Github (removeFromRepo, withSynced)+import Life.Message (abortCmd, warningMessage)+import Life.Shell (LifeExistence (..), whatIsLife)++import qualified Data.Set as Set++-- | Remove path from existing life-configuration file.+lifeRemove :: LifePath -> IO ()+lifeRemove lPath = whatIsLife >>= \case+ -- if one of them is missing -- abort+ NoLife -> abortCmd "remove" ".life and docfiles/ do not exist"+ OnlyLife _ -> abortCmd "remove" "dotfiles/ directory doesn't exist"+ OnlyRepo _ -> abortCmd "remove" ".life file doesn't exist"+ -- actual life remove process+ Both _ _ -> withSynced $ do+ homeDirPath <- getHomeDir+ case lPath of+ (File path) -> do+ filePath <- resolveFile homeDirPath path >>= makeRelative homeDirPath+ resolveConfiguration files removeFile filePath+ (Dir path) -> do+ dirPath <- resolveDir homeDirPath path >>= makeRelative homeDirPath+ resolveConfiguration directories removeDirRecur dirPath++resolveConfiguration :: Lens' LifeConfiguration (Set (Path Rel t))+ -> (Path Abs t -> IO ()) -- ^ function to remove object+ -> Path Rel t+ -> IO ()+resolveConfiguration confLens removeFun path = do+ configuration <- parseHomeLife++ let newConfiguration = configuration & confLens %~ Set.delete path+ if configuration == newConfiguration+ then warningMessage "File or directory is not in tracked" >> exitFailure+ else do+ writeGlobalLife newConfiguration+ removeFromRepo removeFun path
+ src/Life/Message.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE ViewPatterns #-}++module Life.Message+ ( beautyPrint+ , boldText+ , prompt+ , promptNonEmpty+ , errorMessage+ , warningMessage+ , successMessage+ , infoMessage+ , skipMessage+ , abortCmd++ -- * Questions+ , choose+ , chooseYesNo+ ) where++import System.Console.ANSI (Color (..), ColorIntensity (Vivid), ConsoleIntensity (BoldIntensity),+ ConsoleLayer (Foreground), SGR (..), setSGR)+import System.IO (hFlush)++import qualified Data.Text as T+import qualified Universum.Unsafe as Unsafe++----------------------------------------------------------------------------+-- Ansi-terminal+----------------------------------------------------------------------------++-- Explicit flush ensures prompt messages are in the correct order on all systems.+putStrFlush :: Text -> IO ()+putStrFlush msg = do+ putText msg+ hFlush stdout++setColor :: Color -> IO ()+setColor color = setSGR [SetColor Foreground Vivid color]++-- | Starts bold printing.+bold :: IO ()+bold = setSGR [SetConsoleIntensity BoldIntensity]++-- | Resets all previous settings.+reset :: IO ()+reset = do+ setSGR [Reset]+ hFlush stdout++-- | Takes list of formatting options, prints text using this format options.+beautyPrint :: [IO ()] -> Text -> IO ()+beautyPrint formats msg = do+ sequence_ formats+ putText msg+ reset++prompt :: IO Text+prompt = do+ setColor Blue+ putStrFlush " ⟳ "+ reset+ getLine++promptNonEmpty :: IO Text+promptNonEmpty = do+ res <- T.strip <$> prompt+ if null res+ then warningMessage "The answer shouldn't be empty" >> promptNonEmpty+ else pure res+++boldText :: Text -> IO ()+boldText message = bold >> putStrFlush message >> reset++boldDefault :: Text -> IO ()+boldDefault message = boldText (" [" <> message <> "]")++colorMessage :: Color -> Text -> IO ()+colorMessage color message = do+ setColor color+ putTextLn $ " " <> message+ reset++errorMessage, warningMessage, successMessage, infoMessage, skipMessage :: Text -> IO ()+errorMessage = colorMessage Red+warningMessage = colorMessage Yellow+successMessage = colorMessage Green+infoMessage = colorMessage Blue+skipMessage = colorMessage Cyan++-- | Print message and abort current process.+abortCmd :: Text -> Text -> IO ()+abortCmd cmd msg = do+ warningMessage msg+ errorMessage $ "Aborting 'life " <> cmd <> "' command."+ exitFailure++----------------------------------------------------------------------------+-- Questions+----------------------------------------------------------------------------++printQuestion :: Text -> [Text] -> IO ()+printQuestion question (def:rest) = do+ let restSlash = T.intercalate "/" rest+ putStrFlush question+ boldDefault def+ putTextLn $ "/" <> restSlash+printQuestion question [] = putTextLn question++choose :: Text -> [Text] -> IO Text+choose question choices = do+ printQuestion question choices+ answer <- prompt+ if | T.null answer -> pure (Unsafe.head choices)+ | T.toLower answer `elem` choices -> pure answer+ | otherwise -> do+ errorMessage "This wasn't a valid choice."+ choose question choices++data Answer = Y | N++yesOrNo :: Text -> Maybe Answer+yesOrNo (T.toLower -> answer )+ | T.null answer = Just Y+ | answer `elem` ["yes", "y", "ys"] = Just Y+ | answer `elem` ["no", "n"] = Just N+ | otherwise = Nothing++chooseYesNo :: Text -> IO Bool+chooseYesNo q = do+ printQuestion q ["y", "n"]+ answer <- yesOrNo <$> prompt+ case answer of+ Nothing -> do+ errorMessage "This wasn't a valid choice."+ chooseYesNo q+ Just Y -> pure True+ Just N -> pure False
+ src/Life/Shell.hs view
@@ -0,0 +1,87 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++-- | This module contains utility functions to work with shell.++-- TODO: rename this module to Life.Path ?++module Life.Shell+ ( -- * Constants+ lifePath+ , repoName++ -- * Functions+ , LifeExistence (..)+ , createDirInHome+ , relativeToHome+ , whatIsLife+ , ($|)+ ) where++import Path (Abs, Dir, File, Path, Rel, mkRelDir, mkRelFile, (</>))+import Path.IO (createDirIfMissing, doesDirExist, doesFileExist, getHomeDir)+import System.Process (callCommand, readProcess, showCommandForUser)++----------------------------------------------------------------------------+-- Global constants+----------------------------------------------------------------------------++-- | Name for life configuration file.+lifePath :: Path Rel File+lifePath = $(mkRelFile ".life")++-- TODO: consistent naming with @lifePath@ ?+-- | Default repository name for life configuration files.+repoName :: Path Rel Dir+repoName = $(mkRelDir "dotfiles/")++----------------------------------------------------------------------------+-- Shell interface+----------------------------------------------------------------------------++-- This is needed to be able to call commands by writing strings.+instance (a ~ Text, b ~ ()) => IsString ([a] -> IO b) where+ fromString cmd args = do+ let cmdStr = showCommandForUser cmd (map toString args)+ putStrLn $ "⚙ " ++ cmdStr+ callCommand cmdStr++-- | Run shell command with given options and return stdout of executed command.+infix 5 $|+($|) :: FilePath -> [Text] -> IO String+cmd $| args = readProcess cmd (map toString args) ""++-- | Creates directory with name "folder" under "~/folder".+createDirInHome :: Path Rel Dir -> IO (Path Abs Dir)+createDirInHome dirName = do+ newDir <- relativeToHome dirName+ newDir <$ createDirIfMissing False newDir++-- | Creates path relative to home directory+relativeToHome :: MonadIO m => Path Rel t -> m (Path Abs t)+relativeToHome path = do+ homeDir <- getHomeDir+ pure $ homeDir </> path++data LifeExistence+ = NoLife+ | OnlyLife (Path Abs File)+ | OnlyRepo (Path Abs Dir)+ | Both (Path Abs File) (Path Abs Dir)++whatIsLife :: IO LifeExistence+whatIsLife = do+ lifeFile <- relativeToHome lifePath+ repoDir <- relativeToHome repoName++ isFile <- doesFileExist lifeFile+ isDir <- doesDirExist repoDir++ pure $ case (isFile, isDir) of+ (False, False) -> NoLife+ (True, False) -> OnlyLife lifeFile+ (False, True) -> OnlyRepo repoDir+ (True, True) -> Both lifeFile repoDir
+ src/Life/Validation.hs view
@@ -0,0 +1,27 @@+module Life.Validation+ ( Validation (..)+ ) where++-- | 'Validation' is 'Either' with a Left that is a 'Monoid'+data Validation e a+ = Failure e+ | Success a+ deriving (Eq, Ord, Show)++instance Functor (Validation e) where+ fmap _ (Failure e) = Failure e+ fmap f (Success a) = Success (f a)++instance Semigroup e => Semigroup (Validation e a) where+ Failure e1 <> Failure e2 = Failure (e1 <> e2)+ Failure _ <> Success a2 = Success a2+ Success a1 <> Failure _ = Success a1+ Success a1 <> Success _ = Success a1++instance Semigroup e => Applicative (Validation e) where+ pure = Success++ Failure e1 <*> Failure e2 = Failure (e1 <> e2)+ Failure e1 <*> Success _ = Failure e1+ Success _ <*> Failure e2 = Failure e2+ Success f <*> Success a = Success (f a)
+ src/Prelude.hs view
@@ -0,0 +1,7 @@+-- | Uses @universum@ as default prelude.++module Prelude+ ( module Universum+ ) where++import Universum
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF tasty-discover #-}
+ test/Test/Roundtrip.hs view
@@ -0,0 +1,36 @@+module Test.Roundtrip where++import Hedgehog (Gen, Property, forAll, property, tripping)+import Path.Internal (Path (Path))+import System.FilePath (pathSeparator, (</>))++import Life.Configuration (LifeConfiguration (..), parseLifeConfiguration, renderLifeConfiguration)++import qualified Data.Set as Set+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++hprop_ConfigurationRoundtrip :: Property+hprop_ConfigurationRoundtrip = property $ do+ cfg <- forAll genLifeConfiguration+ tripping cfg (renderLifeConfiguration True) (parseLifeConfiguration @Maybe)++genLifeConfiguration :: Gen LifeConfiguration+genLifeConfiguration = do+ lifeConfigurationFiles <- genPathSet genFilePath+ lifeConfigurationDirectories <- genPathSet genDirPath+ pure LifeConfiguration{..}++-- it's safe to use 'Path' constructor here even if such things are not recommended by API+-- our generators should be safe; and if not - this will be caught by test later+genPathSet :: Gen FilePath -> Gen (Set (Path b t))+genPathSet gen = Set.fromList . fmap Path <$> Gen.list (Range.constant 0 30) gen++genDirPath :: Gen FilePath+genDirPath = (++ [pathSeparator]) <$> genFilePath++genFilePath :: Gen FilePath+genFilePath = foldr1 (</>) <$> Gen.nonEmpty (Range.constant 1 10) genFilePathPiece++genFilePathPiece :: Gen String+genFilePathPiece = Gen.string (Range.constant 1 10) Gen.alphaNum