module HsDev.Tools.ClearImports (
	dumpMinimalImports, waitImports, cleanTmpImports,
	findMinimalImports,
	groupImports, splitImport,
	clearImports,

	module Control.Monad.Except
	) where

import Control.Arrow
import Control.Concurrent (threadDelay)
import Control.Exception
import Control.Monad.Except
import Data.Char
import Data.List
import Data.Maybe (mapMaybe)
import Data.Text (unpack)
import System.Directory
import System.FilePath
import qualified Language.Haskell.Exts as Exts

import GHC
import GHC.Paths (libdir)

import HsDev.Util
import HsDev.Tools.Ghc.Compat

-- | Dump minimal imports
dumpMinimalImports :: [String] -> FilePath -> ExceptT String IO String
dumpMinimalImports :: [String] -> String -> ExceptT String IO String
dumpMinimalImports [String]
opts String
f = do
	String
cur <- IO String -> ExceptT String IO String
forall (m :: * -> *) a. MonadCatch m => m a -> ExceptT String m a
liftE IO String
getCurrentDirectory
	String
file <- IO String -> ExceptT String IO String
forall (m :: * -> *) a. MonadCatch m => m a -> ExceptT String m a
liftE (IO String -> ExceptT String IO String)
-> IO String -> ExceptT String IO String
forall a b. (a -> b) -> a -> b
$ String -> IO String
canonicalizePath String
f
	String
cts <- IO String -> ExceptT String IO String
forall (m :: * -> *) a. MonadCatch m => m a -> ExceptT String m a
liftE (IO String -> ExceptT String IO String)
-> IO String -> ExceptT String IO String
forall a b. (a -> b) -> a -> b
$ (Text -> String) -> IO Text -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> String
unpack (IO Text -> IO String) -> IO Text -> IO String
forall a b. (a -> b) -> a -> b
$ String -> IO Text
readFileUtf8 String
file

	String
mname <- case ParseMode -> String -> ParseResult (Module SrcSpanInfo)
Exts.parseFileContentsWithMode (String -> ParseMode
pmode String
file) String
cts of
		Exts.ParseFailed SrcLoc
loc String
err -> String -> ExceptT String IO String
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> ExceptT String IO String)
-> String -> ExceptT String IO String
forall a b. (a -> b) -> a -> b
$
			String
"Failed to parse file at " String -> String -> String
forall a. [a] -> [a] -> [a]
++
			SrcLoc -> String
forall a. Pretty a => a -> String
Exts.prettyPrint SrcLoc
loc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err
		Exts.ParseOk (Exts.Module SrcSpanInfo
_ (Just (Exts.ModuleHead SrcSpanInfo
_ (Exts.ModuleName SrcSpanInfo
_ String
mname) Maybe (WarningText SrcSpanInfo)
_ Maybe (ExportSpecList SrcSpanInfo)
_)) [ModulePragma SrcSpanInfo]
_ [ImportDecl SrcSpanInfo]
_ [Decl SrcSpanInfo]
_) -> String -> ExceptT String IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
mname
		ParseResult (Module SrcSpanInfo)
_ -> String -> ExceptT String IO String
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"Error"

	ExceptT String IO SuccessFlag -> ExceptT String IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT String IO SuccessFlag -> ExceptT String IO ())
-> ExceptT String IO SuccessFlag -> ExceptT String IO ()
forall a b. (a -> b) -> a -> b
$ IO SuccessFlag -> ExceptT String IO SuccessFlag
forall (m :: * -> *) a. MonadCatch m => m a -> ExceptT String m a
liftE (IO SuccessFlag -> ExceptT String IO SuccessFlag)
-> IO SuccessFlag -> ExceptT String IO SuccessFlag
forall a b. (a -> b) -> a -> b
$ Maybe String -> Ghc SuccessFlag -> IO SuccessFlag
forall a. Maybe String -> Ghc a -> IO a
runGhc (String -> Maybe String
forall a. a -> Maybe a
Just String
libdir) (Ghc SuccessFlag -> IO SuccessFlag)
-> Ghc SuccessFlag -> IO SuccessFlag
forall a b. (a -> b) -> a -> b
$ do
		DynFlags
df <- Ghc DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
		let
			df' :: DynFlags
df' = DynFlags
df {
				ghcLink :: GhcLink
ghcLink = GhcLink
NoLink,
				hscTarget :: HscTarget
hscTarget = HscTarget
HscNothing,
				dumpDir :: Maybe String
dumpDir = String -> Maybe String
forall a. a -> Maybe a
Just String
cur,
				stubDir :: Maybe String
stubDir = String -> Maybe String
forall a. a -> Maybe a
Just String
cur,
				objectDir :: Maybe String
objectDir = String -> Maybe String
forall a. a -> Maybe a
Just String
cur,
				hiDir :: Maybe String
hiDir = String -> Maybe String
forall a. a -> Maybe a
Just String
cur }
		(DynFlags
df'', [Located String]
_, [Warn]
_) <- DynFlags
-> [Located String] -> Ghc (DynFlags, [Located String], [Warn])
forall (m :: * -> *).
MonadIO m =>
DynFlags
-> [Located String] -> m (DynFlags, [Located String], [Warn])
parseDynamicFlags DynFlags
df' ((String -> Located String) -> [String] -> [Located String]
forall a b. (a -> b) -> [a] -> [b]
map String -> Located String
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (String
"-ddump-minimal-imports" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
opts))
		[InstalledUnitId]
_ <- DynFlags -> Ghc [InstalledUnitId]
forall (m :: * -> *). GhcMonad m => DynFlags -> m [InstalledUnitId]
setSessionDynFlags DynFlags
df''
		DynFlags -> Ghc SuccessFlag -> Ghc SuccessFlag
forall (m :: * -> *) a. DynFlags -> m a -> m a
cleanupHandler DynFlags
df'' (Ghc SuccessFlag -> Ghc SuccessFlag)
-> Ghc SuccessFlag -> Ghc SuccessFlag
forall a b. (a -> b) -> a -> b
$ do
			Target
t <- String -> Maybe Phase -> Ghc Target
forall (m :: * -> *).
GhcMonad m =>
String -> Maybe Phase -> m Target
guessTarget String
file Maybe Phase
forall a. Maybe a
Nothing
			[Target] -> Ghc ()
forall (m :: * -> *). GhcMonad m => [Target] -> m ()
setTargets [Target
t]
			LoadHowMuch -> Ghc SuccessFlag
forall (m :: * -> *). GhcMonad m => LoadHowMuch -> m SuccessFlag
load LoadHowMuch
LoadAllTargets

	String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
mname Int -> ExceptT String IO String -> ExceptT String IO String
`seq` String -> ExceptT String IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
mname
	where
		pmode :: FilePath -> Exts.ParseMode
		pmode :: String -> ParseMode
pmode String
f' = ParseMode
Exts.defaultParseMode {
			parseFilename :: String
Exts.parseFilename = String
f',
			baseLanguage :: Language
Exts.baseLanguage = Language
Exts.Haskell2010,
			extensions :: [Extension]
Exts.extensions = [Extension]
Exts.glasgowExts [Extension] -> [Extension] -> [Extension]
forall a. [a] -> [a] -> [a]
++ (String -> Extension) -> [String] -> [Extension]
forall a b. (a -> b) -> [a] -> [b]
map String -> Extension
Exts.parseExtension [String]
exts,
			fixities :: Maybe [Fixity]
Exts.fixities = [Fixity] -> Maybe [Fixity]
forall a. a -> Maybe a
Just [Fixity]
Exts.baseFixities }
		exts :: [String]
exts = (String -> Maybe String) -> [String] -> [String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
"-X") [String]
opts

-- | Read imports from file
waitImports :: FilePath -> IO [String]
waitImports :: String -> IO [String]
waitImports String
f = Int -> IO [String] -> IO [String]
forall (m :: * -> *) a.
(MonadPlus m, MonadIO m) =>
Int -> m a -> m a
retry Int
1000 (IO [String] -> IO [String]) -> IO [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ do
	[String]
is <- (String -> [String]) -> IO String -> IO [String]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM String -> [String]
lines (IO String -> IO [String]) -> IO String -> IO [String]
forall a b. (a -> b) -> a -> b
$ String -> IO String
readFile String
f
	[String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
is Int -> IO [String] -> IO [String]
`seq` [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String]
is

-- | Clean temporary files
cleanTmpImports :: FilePath -> IO ()
cleanTmpImports :: String -> IO ()
cleanTmpImports String
dir = do
	[String]
dumps <- ([String] -> [String]) -> IO [String] -> IO [String]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
".imports") (String -> Bool) -> (String -> String) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
takeExtension)) (IO [String] -> IO [String]) -> IO [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ String -> IO [String]
directoryContents String
dir
	[String] -> (String -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [String]
dumps ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ (IOException -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle IOException -> IO ()
ignoreIO' (IO () -> IO ()) -> (String -> IO ()) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> IO () -> IO ()
forall (m :: * -> *) a.
(MonadPlus m, MonadIO m) =>
Int -> m a -> m a
retry Int
1000 (IO () -> IO ()) -> (String -> IO ()) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
removeFile
	where
		ignoreIO' :: IOException -> IO ()
		ignoreIO' :: IOException -> IO ()
ignoreIO' IOException
_ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Dump and read imports
findMinimalImports :: [String] -> FilePath -> ExceptT String IO [String]
findMinimalImports :: [String] -> String -> ExceptT String IO [String]
findMinimalImports [String]
opts String
f = do
	String
file <- IO String -> ExceptT String IO String
forall (m :: * -> *) a. MonadCatch m => m a -> ExceptT String m a
liftE (IO String -> ExceptT String IO String)
-> IO String -> ExceptT String IO String
forall a b. (a -> b) -> a -> b
$ String -> IO String
canonicalizePath String
f
	String
mname <- [String] -> String -> ExceptT String IO String
dumpMinimalImports [String]
opts String
file
	[String]
is <- IO [String] -> ExceptT String IO [String]
forall (m :: * -> *) a. MonadCatch m => m a -> ExceptT String m a
liftE (IO [String] -> ExceptT String IO [String])
-> IO [String] -> ExceptT String IO [String]
forall a b. (a -> b) -> a -> b
$ String -> IO [String]
waitImports (String
mname String -> String -> String
<.> String
"imports")
	String
tmp <- IO String -> ExceptT String IO String
forall (m :: * -> *) a. MonadCatch m => m a -> ExceptT String m a
liftE IO String
getCurrentDirectory
	IO () -> ExceptT String IO ()
forall (m :: * -> *) a. MonadCatch m => m a -> ExceptT String m a
liftE (IO () -> ExceptT String IO ()) -> IO () -> ExceptT String IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
cleanTmpImports String
tmp
	[String] -> ExceptT String IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String]
is

-- | Groups several lines related to one import by indents
groupImports :: [String] -> [[String]]
groupImports :: [String] -> [[String]]
groupImports = ([String] -> Maybe ([String], [String])) -> [String] -> [[String]]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr [String] -> Maybe ([String], [String])
getPack where
	getPack :: [String] -> Maybe ([String], [String])
getPack [] = Maybe ([String], [String])
forall a. Maybe a
Nothing
	getPack (String
s:[String]
ss) = ([String], [String]) -> Maybe ([String], [String])
forall a. a -> Maybe a
Just (([String], [String]) -> Maybe ([String], [String]))
-> ([String], [String]) -> Maybe ([String], [String])
forall a b. (a -> b) -> a -> b
$ ([String] -> [String])
-> ([String], [String]) -> ([String], [String])
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (String
sString -> [String] -> [String]
forall a. a -> [a] -> [a]
:) (([String], [String]) -> ([String], [String]))
-> ([String], [String]) -> ([String], [String])
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> ([String], [String])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (String -> Bool) -> (String -> String) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
isSpace) [String]
ss

-- | Split import to import and import-list
splitImport :: [String] -> (String, String)
splitImport :: [String] -> (String, String)
splitImport = String -> (String, String)
splitBraces (String -> (String, String))
-> ([String] -> String) -> [String] -> (String, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unwords ([String] -> String)
-> ([String] -> [String]) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
trim where
	cut :: [a] -> [a]
cut = ([a] -> [a]) -> [a] -> [a]
forall b. (b -> b) -> b -> b
twice (([a] -> [a]) -> [a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ [a] -> [a]
forall a. [a] -> [a]
reverse ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
1
	twice :: (b -> b) -> b -> b
twice b -> b
f = b -> b
f (b -> b) -> (b -> b) -> b -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> b
f
	splitBraces :: String -> (String, String)
splitBraces = (String -> String
trim (String -> String)
-> (String -> String) -> (String, String) -> (String, String)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** (String -> String
trim (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. [a] -> [a]
cut)) ((String, String) -> (String, String))
-> (String -> (String, String)) -> String -> (String, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'(')

-- | Returns minimal imports for file specified
clearImports :: [String] -> FilePath -> ExceptT String IO [(String, String)]
clearImports :: [String] -> String -> ExceptT String IO [(String, String)]
clearImports [String]
opts = ([String] -> [(String, String)])
-> ExceptT String IO [String]
-> ExceptT String IO [(String, String)]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (([String] -> (String, String)) -> [[String]] -> [(String, String)]
forall a b. (a -> b) -> [a] -> [b]
map [String] -> (String, String)
splitImport ([[String]] -> [(String, String)])
-> ([String] -> [[String]]) -> [String] -> [(String, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [[String]]
groupImports) (ExceptT String IO [String]
 -> ExceptT String IO [(String, String)])
-> (String -> ExceptT String IO [String])
-> String
-> ExceptT String IO [(String, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String -> ExceptT String IO [String]
findMinimalImports [String]
opts

-- | Retry action on fail
retry :: (MonadPlus m, MonadIO m) => Int -> m a -> m a
retry :: Int -> m a -> m a
retry Int
dt m a
act = [m a] -> m a
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([m a] -> m a) -> [m a] -> m a
forall a b. (a -> b) -> a -> b
$ m a
act m a -> [m a] -> [m a]
forall a. a -> [a] -> [a]
: m a -> [m a]
forall a. a -> [a]
repeat ((IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Int -> IO ()
threadDelay Int
dt) m () -> m a -> m a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>) m a
act)