haskell-tools-cli (empty) → 0.2.0.0

raw patch · 6 files changed

+237/−0 lines, 6 filesdep +basedep +containersdep +directorysetup-changed

Dependencies added: base, containers, directory, ghc, ghc-paths, haskell-tools-ast, haskell-tools-prettyprint, haskell-tools-refactor, mtl, references, split

Files

LICENSE +29/−0
Language/Haskell/Tools/Refactor/CLI.hs +144/−0
Language/Haskell/Tools/Refactor/Session.hs +24/−0
Main.hs +8/−0
Setup.hs +2/−0
haskell-tools-cli.cabal +30/−0

+ LICENSE view

@@ -0,0 +1,29 @@+Haskell-Tools is Copyright (c) Boldizsár Németh, 2016, all rights reserved,
+and is distributed as free software under the following license.
+
+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.
+
+- The names of the copyright holders may not be used to endorse or
+promote products derived from this software without specific prior
+written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "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 HOLDERS 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.

+ Language/Haskell/Tools/Refactor/CLI.hs view

@@ -0,0 +1,144 @@+{-# LANGUAGE LambdaCase
+           , TupleSections
+           , FlexibleContexts
+           #-}
+module Language.Haskell.Tools.Refactor.CLI (refactorSession) where
+
+import System.Directory
+import System.IO
+import qualified Data.Map as Map
+import Data.Maybe
+import Data.List
+import Data.List.Split
+import Control.Monad.State
+import Control.Reference
+
+import GHC
+import HscTypes as GHC
+import Module as GHC
+import GHC.Paths ( libdir )
+
+import Language.Haskell.Tools.AST
+import Language.Haskell.Tools.PrettyPrint
+import Language.Haskell.Tools.Refactor
+import Language.Haskell.Tools.Refactor.RefactorBase
+import Language.Haskell.Tools.Refactor.GetModules
+import Language.Haskell.Tools.Refactor.Session
+
+tryOut = refactorSession [ "-dry-run", "-one-shot", "-module-name=Language.Haskell.Tools.AST", "-refactoring=OrganizeImports"
+                         , "-package", "ghc", "src/ast", "src/ast-trf", "src/ast-ghc", "src/ast-ppr", "src/ast-gen", "src/refactor"]
+
+refactorSession :: [String] -> IO ()
+refactorSession args = runGhc (Just libdir) $ flip evalStateT initSession $
+  do lift $ initGhcFlags
+     workingDirsAndHtFlags <- lift $ useFlags args
+     let (htFlags, workingDirs) = partition (\f -> head f == '-') workingDirsAndHtFlags
+     lift $ useDirs workingDirs
+     if null workingDirs then liftIO $ putStrLn usageMessage
+                         else do moduleNames <- initializeSession workingDirs htFlags
+                                 runSession moduleNames htFlags
+     
+  where initializeSession :: [FilePath] -> [String] -> RefactorSession Ghc [(FilePath, String)]
+        initializeSession workingDirs flags = do
+          moduleNames <- liftIO $ concat <$> mapM (\wd -> map (wd,) <$> getModules wd) workingDirs
+          lift $ setTargets (map (\(_,mod) -> (Target (TargetModule (mkModuleName mod)) True Nothing)) moduleNames)
+          liftIO $ putStrLn "Compiling modules. This may take some time. Please wait."
+          lift $ load LoadAllTargets
+          allMods <- lift getModuleGraph
+          mods <- lift $ forM allMods (loadModule moduleNames)
+          liftIO $ putStrLn "All modules loaded. Use 'SelectModule module-name' to select a module"
+          modify $ refSessMods .= Map.fromList mods
+          liftIO $ hSetBuffering stdout NoBuffering
+          when ("-dry-run" `elem` flags) $ modify (dryMode .= True)
+          return moduleNames
+
+        loadModule :: [(String, String)] -> ModSummary -> Ghc ((FilePath, String, IsBoot), TypedModule)
+        loadModule moduleNames ms = 
+          do mm <- parseTyped ms
+             liftIO $ putStrLn ("Loaded module: " ++ (GHC.moduleNameString $ moduleName $ ms_mod ms))
+             let modName = GHC.moduleNameString $ moduleName $ ms_mod ms
+                 Just wd = find ((modName ==) . snd) moduleNames 
+             return ((fst wd, modName, case ms_hsc_src ms of HsSrcFile -> NormalHs; _ -> IsHsBoot), mm)
+
+        runSession :: [(String, String)] -> [String] -> RefactorSession Ghc ()
+        runSession moduleNames flags | "-one-shot" `elem` flags
+          = let modName = catMaybes $ map (\f -> case splitOn "=" f of ["-module-name", mod] -> Just mod; _ -> Nothing) flags
+                refactoring = catMaybes $ map (\f -> case splitOn "=" f of ["-refactoring", ref] -> Just ref; _ -> Nothing) flags
+             in case (modName, refactoring) of 
+                  ([modName],[refactoring]) ->
+                    do performSessionCommand (LoadModule modName)
+                       performSessionCommand =<< readSessionCommand (dropWhile (=='"') $ takeWhile (/='"') $ refactoring)
+                  _ -> liftIO $ putStrLn usageMessage
+        runSession moduleNames _ = runSessionLoop moduleNames
+
+        runSessionLoop :: [(String, String)] -> RefactorSession Ghc ()
+        runSessionLoop moduleNames = do 
+          actualMod <- gets (^. actualMod)
+          liftIO $ putStr (maybe "no-module-selected" (\(_,m,_) -> m) actualMod ++ ">")
+          cmd <- liftIO $ getLine 
+          sessionComm <- readSessionCommand cmd
+          performSessionCommand sessionComm
+          doExit <- gets (^. exiting)
+          when (not doExit) (runSessionLoop moduleNames)
+
+        usageMessage = "Usage: ht-refact [ht-flags, ghc-flags] package-pathes\n"
+                         ++ "ht-flags: -dry-run -one-shot -module-name=modulename -refactoring=\"refactoring\""
+
+data RefactorSessionCommand 
+  = LoadModule String
+  | Exit
+  | RefactorCommand RefactorCommand
+
+readSessionCommand :: Monad m => String -> RefactorSession m RefactorSessionCommand
+readSessionCommand cmd = case splitOn " " cmd of 
+    ["SelectModule", mod] -> return $ LoadModule mod
+    ["Exit"] -> return Exit
+    _ -> do actualMod <- gets (^. actualMod)
+            case actualMod of Just (wd,m,_) -> return $ RefactorCommand $ readCommand (toFileName wd m) cmd
+                              Nothing -> error "Set the actual module first"
+
+performSessionCommand :: RefactorSessionCommand -> RefactorSession Ghc ()
+performSessionCommand (LoadModule mod) = do fnd <- gets (find (\(_,m,hs) -> m == mod && hs == NormalHs) . Map.keys . (^. refSessMods))
+                                            if isJust fnd then modify $ actualMod .= fnd
+                                                          else liftIO $ putStrLn ("Cannot find module: " ++ mod)
+performSessionCommand Exit = modify $ exiting .= True
+performSessionCommand (RefactorCommand cmd) 
+  = do RefactorSessionState { _refSessMods = mods, _actualMod = Just act@(_, mod, _) } <- get
+       res <- lift $ performCommand cmd (mod, mods Map.! act) (map (\((_,m,_),mod) -> (m,mod)) $ Map.assocs (Map.delete act mods))
+       inDryMode <- gets (^. dryMode)
+       case res of Left err -> liftIO $ putStrLn err
+                   Right resMods -> performChanges inDryMode resMods
+                     
+  where performChanges False resMods = do 
+          mss <- forM resMods $ \case 
+            ContentChanged (n,m) -> do
+              let modName = semanticsModule $ m ^. semantics
+              ms <- getModSummary modName (isBootModule $ m ^. semantics)
+              let isBoot = case ms_hsc_src ms of HsSrcFile -> NormalHs; _ -> IsHsBoot
+              Just (workingDir,_,_) <- gets (find (\(_,m,b) -> m == n && b == isBoot) . Map.keys . (^. refSessMods))
+              liftIO $ withBinaryFile ((case isBoot of NormalHs -> toFileName; IsHsBoot -> toBootFileName) workingDir n) 
+                                      WriteMode (`hPutStr` prettyPrint m)
+              return $ Just (n, workingDir, modName, isBoot)
+            ModuleRemoved mod -> do
+              Just (workingDir,_,_) <- gets (find (\(_,m,b) -> m == mod) . Map.keys . (^. refSessMods))
+              liftIO $ removeFile (toFileName workingDir mod)
+              modify $ refSessMods .- Map.delete (workingDir, mod, IsHsBoot) . Map.delete (workingDir, mod, NormalHs)
+              return Nothing
+          lift $ load LoadAllTargets
+          forM_ (catMaybes mss) $ \(n, workingDir, modName, isBoot) -> do
+              -- TODO: add target if module is added as a change
+              ms <- getModSummary modName (isBoot == IsHsBoot)
+              newm <- lift $ parseTyped ms
+              modify $ refSessMods .- Map.insert (workingDir, n, isBoot) newm
+              liftIO $ putStrLn ("Re-loaded module: " ++ n)
+        performChanges True resMods = forM_ resMods $ liftIO . \case 
+          ContentChanged (n,m) -> do
+            putStrLn $ "### Module changed: " ++ n
+            putStrLn $ "### new content:"
+            putStrLn (prettyPrint m)
+          ModuleRemoved mod ->
+            putStrLn $ "### Module removed: " ++ mod
+
+        getModSummary name boot
+          = do allMods <- lift getModuleGraph
+               return $ fromJust $ find (\ms -> ms_mod ms == name && (ms_hsc_src ms == HsSrcFile) /= boot) allMods

+ Language/Haskell/Tools/Refactor/Session.hs view

@@ -0,0 +1,24 @@+{-# LANGUAGE TemplateHaskell #-}
+module Language.Haskell.Tools.Refactor.Session where
+
+import Data.Map as Map
+import Control.Monad.State
+import Control.Reference
+
+import Language.Haskell.Tools.AST (IdDom)
+import Language.Haskell.Tools.Refactor (IsBoot(..))
+import Language.Haskell.Tools.Refactor.RefactorBase (UnnamedModule)
+
+type RefactorSession = StateT RefactorSessionState
+
+data RefactorSessionState
+  = RefactorSessionState { _refSessMods :: Map.Map (String, String, IsBoot) (UnnamedModule IdDom)
+                         , _actualMod :: Maybe (String, String, IsBoot)
+                         , _exiting :: Bool
+                         , _dryMode :: Bool
+                         }
+
+initSession :: RefactorSessionState
+initSession = RefactorSessionState Map.empty Nothing False False
+
+makeReferences ''RefactorSessionState

+ Main.hs view

@@ -0,0 +1,8 @@+module Main where
+
+import System.Environment
+
+import Language.Haskell.Tools.Refactor.CLI
+
+main :: IO ()
+main = refactorSession =<< getArgs

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple
+main = defaultMain

+ haskell-tools-cli.cabal view

@@ -0,0 +1,30 @@+name:                haskell-tools-cli
+version:             0.2.0.0
+synopsis:            Command-line frontend for Haskell-tools Refact
+description:         Command-line frontend for Haskell-tools Refact. Not meant as a final product, only for demonstration purposes.
+homepage:            https://github.com/haskell-tools/haskell-tools
+license:             BSD3
+license-file:        LICENSE
+author:              Boldizsar Nemeth
+maintainer:          nboldi@elte.hu
+category:            Language
+build-type:          Simple
+cabal-version:       >=1.10
+
+executable ht-refact
+  build-depends:       base                      >=4.9 && <5.0
+                     , containers                >=0.5 && <0.6
+                     , mtl                       >=2.2 && <2.3
+                     , split                     >=0.2 && <1.0
+                     , directory                 >=1.2 && <1.3
+                     , ghc                       >=8.0 && <8.1
+                     , ghc-paths                 >=0.1 && <0.2
+                     , references                >=0.3.2 && <1.0
+                     , haskell-tools-ast         >=0.2 && <0.3
+                     , haskell-tools-prettyprint >=0.2 && <0.3
+                     , haskell-tools-refactor    >=0.2 && <0.3
+  main-is:             Main.hs
+  other-modules:       Language.Haskell.Tools.Refactor.CLI
+                     , Language.Haskell.Tools.Refactor.Session
+  default-language:    Haskell2010
+