HaRe-0.8.3.0: src/MainHaRe.hs
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell #-}
import Control.Exception
import Control.Monad.Writer.Lazy
import Data.List
import Data.Version
import Development.GitRev (gitCommitCount)
import Distribution.System (buildArch)
import Distribution.Text (display)
import Language.Haskell.Refact.API
import Language.Haskell.Refact.HaRe
import Options.Applicative.Simple
import qualified Language.Haskell.GhcMod as GM
import qualified Paths_HaRe as Meta
-- temporary until exposed by ghc-mod
-- import Options
import Language.Haskell.GhcMod.Options.Options
main :: IO ()
main = do
-- Version code from stack. Maybe move this stuff into optparse-simple ?
let commitCount = $gitCommitCount
versionString' = concat $ concat
[ [$(simpleVersion Meta.version)]
-- Leave out number of commits for --depth=1 clone
-- See https://github.com/commercialhaskell/stack/issues/792
, [" (" ++ commitCount ++ " commits)" | commitCount /= ("1"::String) &&
commitCount /= ("UNKNOWN" :: String)]
, [" ", display buildArch]
]
numericVersion :: Parser (a -> a)
numericVersion =
infoOption
(showVersion Meta.version)
(long "numeric-version" <>
help "Show only version number")
-- Parse the options and run the specified command.
(global, run) <-
simpleOptions
versionString'
"HaRe - the haskell refactorer"
""
-- (numericVersion <*> globalOptsParser) $
(numericVersion <*> allOptsParser) $
do
addCommand "demote"
"Demote a declaration"
runCmd
demoteCmdOpts
addCommand "dupdef"
"Duplicate a definition"
runCmd
dupDefCmdOpts
addCommand "iftocase"
"Convert an if statement to a case statement"
runCmd
ifToCaseCmdOpts
addCommand "liftOneLevel"
"Lift a definition up one level"
runCmd
liftOneLevelCmdOpts
addCommand "liftToTopLevel"
"Lift a definition to the top level"
runCmd
liftToTopLevelCmdOpts
addCommand "rename"
"Rename an identifier"
runCmd
renameCmdOpts
addCommand "addOneParam"
"Add a new parameter to a function in first position"
runCmd
addOneParamCmdOpts
addCommand "rmOneParam"
"Remove a new parameter from a function"
runCmd
rmOneParamCmdOpts
run global
-- ---------------------------------------------------------------------
type Row = Int
type Col = Int
data HareParams = DemoteCmd FilePath Row Col
| DupDefCmd FilePath String Row Col
| IfToCaseCmd FilePath Row Col Row Col
| LiftOneLevel FilePath Row Col
| LiftToTopLevel FilePath Row Col
| RenameCmd FilePath String Row Col
| AddOneParam FilePath String Row Col
| RmOneParam FilePath Row Col
deriving Show
runCmd :: HareParams -> (RefactSettings,GM.Options) -> IO ()
runCmd (DemoteCmd fileName r c) (opt, gOpt)
= runFunc $ demote opt gOpt fileName (r,c)
runCmd (DupDefCmd fileName newname r c) (opt, gOpt)
= runFunc $ duplicateDef opt gOpt fileName newname (r,c)
runCmd (IfToCaseCmd fileName sr sc er ec) (opt, gOpt)
= runFunc $ ifToCase opt gOpt fileName (sr,sc) (er,ec)
runCmd (LiftOneLevel fileName r c) (opt, gOpt)
= runFunc $ liftOneLevel opt gOpt fileName (r,c)
runCmd (LiftToTopLevel fileName r c) (opt, gOpt)
= runFunc $ liftToTopLevel opt gOpt fileName (r,c)
runCmd (RenameCmd fileName newname r c) (opt, gOpt)
= runFunc $ rename opt gOpt fileName newname (r,c)
runCmd (AddOneParam fileName newname r c) (opt, gOpt)
= runFunc $ addOneParameter opt gOpt fileName newname (r,c)
runCmd (RmOneParam fileName r c) (opt, gOpt)
= runFunc $ rmOneParameter opt gOpt fileName (r,c)
-- ---------------------------------------------------------------------
rmOneParamCmdOpts :: Parser HareParams
rmOneParamCmdOpts =
LiftOneLevel
<$> strArgument
( metavar "FILE"
<> help "Specify Haskell file to process"
)
<*> argument auto
( metavar "line"
<> help "The line the function name is on")
<*> argument auto
( metavar "col"
<> help "The col the function name starts at")
-- ---------------------------------------------------------------------
addOneParamCmdOpts :: Parser HareParams
addOneParamCmdOpts =
AddOneParam
<$> strArgument
( metavar "FILE"
<> help "Specify Haskell file to process"
)
<*> strArgument
( metavar "NAME"
<> help "The name for the parameter"
)
<*> argument auto
( metavar "line"
<> help "The line the function name is on")
<*> argument auto
( metavar "col"
<> help "A col inside the function name name")
-- ---------------------------------------------------------------------
renameCmdOpts :: Parser HareParams
renameCmdOpts =
RenameCmd
<$> strArgument
( metavar "FILE"
<> help "Specify Haskell file to process"
)
<*> strArgument
( metavar "NEWNAME"
<> help "The new name for the identifier"
)
<*> argument auto
( metavar "line"
<> help "The line the identifier is on")
<*> argument auto
( metavar "col"
<> help "A col inside the identifier name")
-- ---------------------------------------------------------------------
liftToTopLevelCmdOpts :: Parser HareParams
liftToTopLevelCmdOpts =
LiftOneLevel
<$> strArgument
( metavar "FILE"
<> help "Specify Haskell file to process"
)
<*> argument auto
( metavar "line"
<> help "The line the declaration is on")
<*> argument auto
( metavar "col"
<> help "The col the declaration starts at")
-- ---------------------------------------------------------------------
liftOneLevelCmdOpts :: Parser HareParams
liftOneLevelCmdOpts =
LiftOneLevel
<$> strArgument
( metavar "FILE"
<> help "Specify Haskell file to process"
)
<*> argument auto
( metavar "line"
<> help "The line the declaration is on")
<*> argument auto
( metavar "col"
<> help "The col the declaration starts at")
-- ---------------------------------------------------------------------
ifToCaseCmdOpts :: Parser HareParams
ifToCaseCmdOpts =
IfToCaseCmd
<$> strArgument
( metavar "FILE"
<> help "Specify Haskell file to process"
)
<*> argument auto
( metavar "startline"
<> help "The line the if statement starts on")
<*> argument auto
( metavar "startcol"
<> help "The col the if statement starts at")
<*> argument auto
( metavar "endline"
<> help "The line the if statement ends on")
<*> argument auto
( metavar "endcol"
<> help "The col the if statement ends at")
-- ---------------------------------------------------------------------
demoteCmdOpts :: Parser HareParams
demoteCmdOpts =
DemoteCmd
<$> strArgument
( metavar "FILE"
<> help "Specify Haskell file to process"
)
<*> argument auto
( metavar "line"
<> help "The line the declaration is on")
<*> argument auto
( metavar "col"
<> help "The col the declaration starts at")
-- ---------------------------------------------------------------------
dupDefCmdOpts :: Parser HareParams
dupDefCmdOpts =
DupDefCmd
<$> strArgument
( metavar "FILE"
<> help "Specify Haskell file to process"
)
<*> strArgument
( metavar "NEWNAME"
<> help "The name for the new definition"
)
<*> argument auto
( metavar "line"
<> help "The line the definition is on")
<*> argument auto
( metavar "col"
<> help "A col inside the definition name")
-- ---------------------------------------------------------------------
allOptsParser :: Parser (RefactSettings,GM.Options)
allOptsParser = (,) <$> globalOptsParser <*> globalArgSpec
globalOptsParser :: Parser RefactSettings
globalOptsParser = mkRefSet
<$> ((\b -> if b then Debug else Normal) <$> switch
( long "debug"
<> short 'd'
<> help "Generate debug output" ))
where
mkRefSet v = RefSet v (True,True,True,True)
-- ---------------------------------------------------------------------
-- | Return the result of an Either as a sexp for emacs etc.
runFunc :: IO [String] -> IO ()
runFunc f = do
r <- catchException f
let ret = case r of
Left s -> "(error " ++ (show s) ++ ")"
Right mfs -> "(ok " ++ showLisp mfs ++ ")"
putStrLn ret
showLisp :: [String] -> String
showLisp xs = "(" ++ (intercalate " " $ map show xs) ++ ")"
catchException :: (IO t) -> IO (Either String t)
catchException f = do
res <- handle handler (f >>= \r -> return $ Right r)
return res
where
handler:: SomeException -> IO (Either String t)
handler e = return (Left (stripCallStack $ show e))