diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Siddharth Bhat (c) 2015, Vanessa McHale (c) 2017 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,50 @@ +# Teleport + +A fork of [teleport](https://github.com/bollu/teleport) with a focus on clean, +functional code. + +## Use + +Unfortunately, since we can't change the directory of the user (possibly an +upstream bug), we have to wrap `teleport-hask` in a bash script, so put +`bash/teleport` on your `PATH` somewhere. + +I also put the following in my `~/.bashrc` so that `teleport` would run in the +correct shell: + +```bash +alias go="source $HOME/.local/bin/teleport" +``` + +## Code + +[tokei](https://github.com/Aaronepower/tokei) output for previous package: + +``` +------------------------------------------------------------------------------- + Language Files Lines Code Comments Blanks +------------------------------------------------------------------------------- + Cabal 1 60 53 1 6 + Haskell 4 383 248 51 84 + Markdown 2 22 22 0 0 + Shell 1 11 7 3 1 + YAML 1 29 5 16 8 +------------------------------------------------------------------------------- + Total 9 505 335 71 99 +------------------------------------------------------------------------------- +``` + +For the forked package: + +``` +------------------------------------------------------------------------------- + Language Files Lines Code Comments Blanks +------------------------------------------------------------------------------- + Cabal 1 51 48 0 3 + Haskell 3 213 167 9 37 + Markdown 1 23 23 0 0 + YAML 1 6 6 0 0 +------------------------------------------------------------------------------- + Total 6 293 244 9 40 +------------------------------------------------------------------------------- +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import Teleport + +main :: IO () +main = exec diff --git a/bash/teleport b/bash/teleport new file mode 100644 --- /dev/null +++ b/bash/teleport @@ -0,0 +1,9 @@ +#!/bin/bash +OUTPUT=`teleport-hask $@` +# return code 2 is used to indicate that the shell script +# should use the output to warp to +if [[ $? -eq 2 ]]; then + cd "$OUTPUT" +else + echo "$OUTPUT" +fi diff --git a/shift.cabal b/shift.cabal new file mode 100644 --- /dev/null +++ b/shift.cabal @@ -0,0 +1,51 @@ +name: shift +version: 0.1.0.0 +synopsis: A tool to quickly switch between directories +description: Please see README.md for details +homepage: https://github.com/vmchale/teleport#readme +license: MIT +license-file: LICENSE +author: Siddharth Bhat, Vanessa McHale +maintainer: vamchale@gmail.com +copyright: 2010 Siddharth Bhat, 2017 Vanessa McHale +category: Tools +build-type: Simple +bug-reports: https://github.com/vmchale/teleport/issues +stability: unstable +cabal-version: >=1.10 +extra-source-files: README.md + , stack.yaml + , bash/teleport + +library + hs-source-dirs: src + exposed-modules: Teleport + other-modules: Paths_shift + build-depends: base >= 4.7 && < 5 + , turtle + , optparse-applicative + , system-filepath + , text + , aeson + , composition + , lens + , bytestring + , ansi-terminal + , system-fileio + , data-default + default-language: Haskell2010 + default-extensions: DeriveAnyClass + , DeriveGeneric + ghc-options: -fwarn-unused-imports + +executable teleport-hask + hs-source-dirs: app + main-is: Main.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: base + , shift + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/vmchale/teleport diff --git a/src/Teleport.hs b/src/Teleport.hs new file mode 100644 --- /dev/null +++ b/src/Teleport.hs @@ -0,0 +1,209 @@ +{-# 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 + +-- | options for 'warp add' +data AddOptions = AddOptions { folderPath :: Maybe String, + addname :: String } + +-- | options for 'warp remove' +newtype RemoveOptions = RemoveOptions { removename :: String } + +-- | options for 'warp goto' +newtype GotoOptions = GotoOptions { gotoname :: String } + +-- | 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) + +-- the main data that is loaded from JSON +newtype WarpData = WarpData { _warpPoints :: [WarpPoint] } deriving (Default, Generic) + +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 + where versionInfo = infoOption ("teleport version: " ++ showVersion version) (short 'v' <> long "version" <> help "Show version") + opts = info (helper <*> versionInfo <*> parseCommand) + (fullDesc + <>progDesc "use warp to quickly setup warp points and move between them" + <> header "Warp: move around your filesystem") + +dieJSONParseError :: FilePath -> String -> IO WarpData +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 + +loadWarpData :: FilePath -> IO WarpData +loadWarpData jsonFilePath = testfile jsonFilePath >>= \exists -> + if exists then decodeWarpData jsonFilePath + else saveWarpData jsonFilePath def >> pure def + +saveWarpData :: FilePath -> WarpData -> IO () +saveWarpData jsonFilePath warpData = touch jsonFilePath >> + let dataBytestring = A.encode warpData in + BSL.writeFile (encodeString jsonFilePath) dataBytestring + +warpDataPath :: IO FilePath +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) + +warpnameParser :: Parser String +warpnameParser = argument str + (metavar "NAME" + <> help "name of the warp point") + +parseAddCommand :: Parser Command +parseAddCommand = Add .* AddOptions <$> folderParser <*> warpnameParser + +folderParser :: Parser (Maybe String) +folderParser = optional $ strOption + (long "path" + <> short 'p' + <> metavar "FOLDER" + <> help "path to the folder to warp to") + +parseRemoveCommand :: Parser Command +parseRemoveCommand = Remove . RemoveOptions <$> warpnameParser + +parseGotoCommand :: Parser Command +parseGotoCommand = Goto . GotoOptions <$> warpnameParser + +parseCommand :: Parser Command +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] + +colorWhen :: IO () -> IO () +colorWhen act = do + useColor <- fromMaybe "1" <$> lookupEnv "CLICOLOR" + if useColor /= "0" then act else pure def + +warpPointPrint :: WarpPoint -> IO () +warpPointPrint warpPoint = do + colorWhen $ setSGR [SetColor Foreground Dull White] + putStr (_name warpPoint) + colorWhen $ setSGR [SetColor Foreground Vivid Blue] + putStr $ "\t" <> _absFolderPath warpPoint <> "\n" + +folderNotFoundError :: FilePath -> IO () +folderNotFoundError path = setErrorColor >> + (die . T.pack $ ("unable to find folder: " ++ show path)) + +needFolderNotFileError :: FilePath -> IO () +needFolderNotFileError path = setErrorColor >> + (die . T.pack $ "expected folder, not file: " ++ show path) + +dieIfFolderNotFound :: FilePath -> IO () +dieIfFolderNotFound path = foldr (>>) (pure def) + [ flip when (needFolderNotFileError path) =<< testfile path + , flip unless (folderNotFoundError path) =<< testdir path ] + +dieWarpPointExists :: WarpPoint -> IO () +dieWarpPointExists warpPoint = foldr (>>) (pure def) + [ setErrorColor + , putStrLn $ "warp point " <> _name warpPoint <> " already exists:\n" + , warpPointPrint warpPoint ] + +runAdd :: AddOptions -> IO () +runAdd AddOptions{..} = do + dieIfFolderNotFound . P.decode . encodeUtf8 . T.pack . fromMaybe "./" $ folderPath + print "folder exists, loading warp data..." + warpData <- loadWarpData =<< warpDataPath + _absFolderPath <- realpath . P.decode . encodeUtf8 . T.pack . fromMaybe "./" $ folderPath + let existingWarpPoint = find ((==addname) . _name) (_warpPoints warpData) + case existingWarpPoint of + Just warpPoint -> dieWarpPointExists warpPoint + Nothing -> do + putStrLn "creating warp point: \n" + let newWarpPoint = def & name .~ addname & absFolderPath .~ 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") + +runRemove :: RemoveOptions -> IO () +runRemove RemoveOptions{..} = do + warpPath <- warpDataPath + warp <- loadWarpData warpPath + let wantedWarpPoint = find ((/= removename) . _name) (_warpPoints warp) + case wantedWarpPoint of + Nothing -> dieWarpPointNotFound removename + Just _ -> saveWarpData warpPath + (over warpPoints (filter ((/= removename) . _name)) warp) + +runGoto :: GotoOptions -> IO () +runGoto GotoOptions{..} = do + warpPath <- warpDataPath + warp <- loadWarpData warpPath + let wantedWarpPoint = find ((== gotoname) . _name) (_warpPoints warp) + case wantedWarpPoint of + Nothing -> dieWarpPointNotFound gotoname + Just warpPoint -> do + echo (unsafeTextToLine . T.pack . _absFolderPath $ warpPoint) + cd . fromString $ _absFolderPath warpPoint + setWorkingDirectory . fromString . _absFolderPath $ warpPoint + exit (ExitFailure 2) + +run :: Command -> IO () +run (Add addOpt) = runAdd addOpt +run Display = runDisplay +run (Remove removeOpt) = runRemove removeOpt +run (Goto gotoOpt) = runGoto gotoOpt diff --git a/stack.yaml b/stack.yaml new file mode 100644 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,6 @@ +resolver: lts-8.13 +packages: +- '.' +extra-deps: [] +flags: {} +extra-package-dbs: []