diff --git a/shift.cabal b/shift.cabal --- a/shift.cabal +++ b/shift.cabal @@ -1,7 +1,7 @@ name: shift -version: 0.1.0.0 +version: 0.2.0.0 synopsis: A tool to quickly switch between directories -description: Please see README.md for details +description: This is a command-line tool to "teleport" between directories homepage: https://github.com/vmchale/teleport#readme license: MIT license-file: LICENSE @@ -26,7 +26,7 @@ , optparse-applicative , system-filepath , text - , aeson + , binary , composition , lens , bytestring diff --git a/src/Teleport.hs b/src/Teleport.hs --- a/src/Teleport.hs +++ b/src/Teleport.hs @@ -1,30 +1,32 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} module Teleport where -import Control.Monad -import Data.Maybe -import Data.List -import Prelude hiding (FilePath) -import qualified Data.Text as T -import Data.Text.Encoding -import Options.Applicative -import Data.Monoid -import Filesystem.Path.CurrentOS as P -import Turtle hiding (header, find) -import Data.Aeson as A -import qualified Data.ByteString.Lazy as BSL -import System.Console.ANSI -import Filesystem as P -import System.Environment -import Paths_shift -import Data.Version -import Data.Default -import Control.Lens hiding (argument) -import Data.Composition -import GHC.Generics +import Control.Lens hiding (argument) +import Control.Monad +import Data.Binary +import qualified Data.ByteString.Lazy as BSL +import Data.Composition +import Data.Default +import Data.List +import Data.Maybe +import Data.Monoid +import qualified Data.Text as T +import Data.Text.Encoding +import Data.Version +import Filesystem as P +import qualified Filesystem.Path.CurrentOS as P +import GHC.Generics +import Options.Applicative +import Paths_shift +import Prelude hiding (FilePath) +import System.Console.ANSI +import System.Environment +import Turtle hiding (find, header) -- | options for 'warp add' data AddOptions = AddOptions { folderPath :: Maybe String, @@ -36,26 +38,21 @@ -- | options for 'warp goto' newtype GotoOptions = GotoOptions { gotoname :: String } --- | data type for command +-- | data type for command data Command = Display | Add AddOptions | Remove RemoveOptions | Goto GotoOptions -- an abstract entity representing a point to which we can warp to data WarpPoint = WarpPoint { _name :: String, - _absFolderPath :: String } deriving (Default, Generic) + _absFolderPath :: String } deriving (Default, Generic, Binary) --- the main data that is loaded from JSON -newtype WarpData = WarpData { _warpPoints :: [WarpPoint] } deriving (Default, Generic) +-- the main data that is loaded from JSON +newtype WarpData = WarpData { _warpPoints :: [WarpPoint] } deriving (Default, Generic, Binary) makeLenses ''WarpData makeLenses ''WarpPoint -instance FromJSON WarpPoint where -instance ToJSON WarpPoint where -instance FromJSON WarpData where -instance ToJSON WarpData where - exec :: IO () -exec = execParser opts >>= run +exec = execParser opts >>= run where versionInfo = infoOption ("teleport version: " ++ showVersion version) (short 'v' <> long "version" <> help "Show version") opts = info (helper <*> versionInfo <*> parseCommand) (fullDesc @@ -63,16 +60,13 @@ <> header "Warp: move around your filesystem") dieJSONParseError :: FilePath -> String -> IO WarpData -dieJSONParseError path err = die . T.pack . foldr (<>) mempty $ - ["parse error in: " - , show path +dieJSONParseError path err = die . T.pack . foldr (<>) mempty $ + ["parse error in: " + , show path , "\nerror: \n" <> err ] decodeWarpData :: FilePath -> IO WarpData -decodeWarpData path = (fmap eitherDecode' . BSL.readFile . encodeString) path >>= \x -> - case x of - Left err -> dieJSONParseError path err - Right json -> pure json +decodeWarpData = fmap decode . BSL.readFile . P.encodeString loadWarpData :: FilePath -> IO WarpData loadWarpData jsonFilePath = testfile jsonFilePath >>= \exists -> @@ -81,16 +75,16 @@ saveWarpData :: FilePath -> WarpData -> IO () saveWarpData jsonFilePath warpData = touch jsonFilePath >> - let dataBytestring = A.encode warpData in - BSL.writeFile (encodeString jsonFilePath) dataBytestring + let dataBytestring = encode warpData in + BSL.writeFile (P.encodeString jsonFilePath) dataBytestring warpDataPath :: IO FilePath -warpDataPath = home >>= \homeFolder -> +warpDataPath = home >>= \homeFolder -> pure (homeFolder ".warpdata") readFolderPath :: String -> ReadM FilePath readFolderPath = f . fromText . T.pack - where f path = if valid path then pure path else readerError ("invalid path: " <> show path) + where f path = if P.valid path then pure path else readerError ("invalid path: " <> show path) warpnameParser :: Parser String warpnameParser = argument str @@ -114,14 +108,14 @@ parseGotoCommand = Goto . GotoOptions <$> warpnameParser parseCommand :: Parser Command -parseCommand = hsubparser +parseCommand = hsubparser (command "add" (info parseAddCommand (progDesc "add a warp point")) <> (command "list" (info (pure Display) (progDesc "list all warp points"))) <> (command "del" (info parseRemoveCommand (progDesc "delete a warp point"))) <> (command "to" (info parseGotoCommand (progDesc "go to a created warp point")))) setErrorColor :: IO () -setErrorColor = setSGR [SetColor Foreground Vivid Red] +setErrorColor = setSGR [SetColor Foreground Vivid Red] colorWhen :: IO () -> IO () colorWhen act = do @@ -136,7 +130,7 @@ putStr $ "\t" <> _absFolderPath warpPoint <> "\n" folderNotFoundError :: FilePath -> IO () -folderNotFoundError path = setErrorColor >> +folderNotFoundError path = setErrorColor >> (die . T.pack $ ("unable to find folder: " ++ show path)) needFolderNotFileError :: FilePath -> IO () @@ -149,7 +143,7 @@ , flip unless (folderNotFoundError path) =<< testdir path ] dieWarpPointExists :: WarpPoint -> IO () -dieWarpPointExists warpPoint = foldr (>>) (pure def) +dieWarpPointExists warpPoint = foldr (>>) (pure def) [ setErrorColor , putStrLn $ "warp point " <> _name warpPoint <> " already exists:\n" , warpPointPrint warpPoint ] @@ -165,16 +159,16 @@ Just warpPoint -> dieWarpPointExists warpPoint Nothing -> do putStrLn "creating warp point: \n" - let newWarpPoint = def & name .~ addname & absFolderPath .~ encodeString _absFolderPath + let newWarpPoint = def & name .~ addname & absFolderPath .~ P.encodeString _absFolderPath warpPointPrint newWarpPoint let newWarpData = over warpPoints (newWarpPoint:) warpData flip saveWarpData newWarpData =<< warpDataPath - + runDisplay :: IO () runDisplay = do warpData <- loadWarpData =<< warpDataPath forM_ (_warpPoints warpData) warpPointPrint - + dieWarpPointNotFound :: String ->IO () dieWarpPointNotFound w = setErrorColor >> (die . T.pack) (w <> " warp point not found") @@ -186,7 +180,7 @@ let wantedWarpPoint = find ((/= removename) . _name) (_warpPoints warp) case wantedWarpPoint of Nothing -> dieWarpPointNotFound removename - Just _ -> saveWarpData warpPath + Just _ -> saveWarpData warpPath (over warpPoints (filter ((/= removename) . _name)) warp) runGoto :: GotoOptions -> IO () @@ -201,9 +195,9 @@ cd . fromString $ _absFolderPath warpPoint setWorkingDirectory . fromString . _absFolderPath $ warpPoint exit (ExitFailure 2) - + run :: Command -> IO () -run (Add addOpt) = runAdd addOpt -run Display = runDisplay +run (Add addOpt) = runAdd addOpt +run Display = runDisplay run (Remove removeOpt) = runRemove removeOpt -run (Goto gotoOpt) = runGoto gotoOpt +run (Goto gotoOpt) = runGoto gotoOpt diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-8.13 +resolver: lts-8.23 packages: - '.' extra-deps: []