diff --git a/exe/Main.hs b/exe/Main.hs new file mode 100644 --- /dev/null +++ b/exe/Main.hs @@ -0,0 +1,14 @@ + +module Main where + +import System.Exit (exitFailure, exitSuccess) +import System.IO (hPutStrLn, stderr) +import HsImport + +main :: IO () +main = do + args <- hsImportArgs + maybeSpec <- hsImportSpec args + case maybeSpec of + Left error -> hPutStrLn stderr ("hsimport: " ++ error) >> exitFailure + Right spec -> hsImport spec >> exitSuccess diff --git a/hsimport.cabal b/hsimport.cabal --- a/hsimport.cabal +++ b/hsimport.cabal @@ -1,5 +1,5 @@ name: hsimport -version: 0.2.10 +version: 0.2.11 cabal-version: >=1.9.2 build-type: Simple license: BSD3 @@ -19,7 +19,7 @@ library build-depends: base >=3 && <5, cmdargs >=0.10.5 && <0.11, - haskell-src-exts >=1.14.0 && <1.15, lens >=3.9.2 && <4.1, + haskell-src-exts >=1.14.0 && <1.15, lens >=3.9.2 && <4.2, mtl >=2.1.2 && <2.2, text >=0.11.3.1 && <1.2, split >=0.2.2 && <0.3, attoparsec >=0.10.4.0 && <0.12, directory >=1.2.0.1 && <1.3 @@ -28,22 +28,16 @@ exposed: True buildable: True cpp-options: -DCABAL - hs-source-dirs: src + hs-source-dirs: lib other-modules: HsImport.ImportChange HsImport.Parse Paths_hsimport ghc-options: -W executable hsimport - build-depends: base >=3 && <5, cmdargs >=0.10.5 && <0.11, - haskell-src-exts >=1.14.0 && <1.15, lens >=3.9.2 && <4.1, - mtl >=2.1.2 && <2.2, text >=0.11.3.1 && <1.2, - split >=0.2.2 && <0.3, attoparsec >=0.10.4.0 && <0.12, - directory >=1.2.0.1 && <1.3 + build-depends: base >=3 && <5, hsimport -any main-is: Main.hs buildable: True cpp-options: -DCABAL - hs-source-dirs: src - other-modules: HsImport HsImport.Args HsImport.ImportSpec - HsImport.ImportChange HsImport.Parse HsImport.Main Paths_hsimport + hs-source-dirs: exe ghc-options: -W test-suite hsimport-tests @@ -51,7 +45,8 @@ tasty-golden >=2.2.0.1 && <2.3, filepath >=1.3.0.1 && <1.4, hsimport -any type: exitcode-stdio-1.0 - main-is: tests/Main.hs + hs-source-dirs: tests + main-is: Main.hs buildable: True ghc-options: -W diff --git a/lib/HsImport.hs b/lib/HsImport.hs new file mode 100644 --- /dev/null +++ b/lib/HsImport.hs @@ -0,0 +1,11 @@ + +module HsImport + ( HsImportArgs + , hsImportArgs + , module HsImport.ImportSpec + , module HsImport.Main + ) where + +import HsImport.Args +import HsImport.ImportSpec +import HsImport.Main diff --git a/lib/HsImport/Args.hs b/lib/HsImport/Args.hs new file mode 100644 --- /dev/null +++ b/lib/HsImport/Args.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE DeriveDataTypeable, CPP #-} + +module HsImport.Args + ( HsImportArgs(..) + , hsImportArgs + ) where + +import System.Console.CmdArgs + +#ifdef CABAL +import Data.Version (showVersion) +import Paths_hsimport (version) +#endif + +data HsImportArgs = HsImportArgs + { moduleName :: String + , symbolName :: String + , qualifiedName :: String + , inputSrcFile :: FilePath + , outputSrcFile :: FilePath + } deriving (Data, Typeable, Show, Eq) + + +hsImportArgs :: IO HsImportArgs +hsImportArgs = cmdArgs $ HsImportArgs + { moduleName = def &= help "The module to import" + , symbolName = def &= help "The symbol to import, if empty, the entire module is imported" + , qualifiedName = def &= help "The name to use for a qualified module import" + , outputSrcFile = def &= help "Save modified source file to file, if empty, the source file is modified inplace" &= typFile + , inputSrcFile = def &= args &= typ "SOURCEFILE" + } + &= program "hsimport" + &= summary summaryInfo + &= help "A command line program for extending the import list of a Haskell source file." + &= helpArg [explicit, name "help", name "h"] + &= versionArg [explicit, name "version", name "v", summary versionInfo] + where + summaryInfo = "" + + +versionInfo :: String +versionInfo = +#ifdef CABAL + "hsimport version " ++ showVersion version +#else + "hsimport version unknown (not built with cabal)" +#endif diff --git a/lib/HsImport/ImportChange.hs b/lib/HsImport/ImportChange.hs new file mode 100644 --- /dev/null +++ b/lib/HsImport/ImportChange.hs @@ -0,0 +1,257 @@ +{-# Language PatternGuards #-} + +module HsImport.ImportChange + ( ImportChange(..) + , importChanges + ) where + +import Data.Maybe +import Data.List (find) +import Data.List.Split (splitOn) +import Control.Lens +import qualified Language.Haskell.Exts as HS +import qualified Data.Attoparsec.Text as A + +type SrcLine = Int +type ImportString = String + +data ImportChange = ReplaceImportAt SrcLine ImportString + | AddImportAfter SrcLine ImportString + | AddImportAtEnd ImportString + | NoImportChange + deriving (Show) + + +importChanges :: String -> Maybe String -> Maybe String -> HS.Module -> [ImportChange] +importChanges moduleName (Just symbolName) (Just qualifiedName) module_ = + [ importModuleWithSymbol moduleName symbolName module_ + , importQualifiedModule moduleName qualifiedName module_ + ] + +importChanges moduleName (Just symbolName) Nothing module_ = + [ importModuleWithSymbol moduleName symbolName module_ ] + +importChanges moduleName Nothing (Just qualifiedName) module_ = + [ importQualifiedModule moduleName qualifiedName module_ ] + +importChanges moduleName Nothing Nothing module_ = + [ importModule moduleName module_ ] + + +importModule :: String -> HS.Module -> ImportChange +importModule moduleName module_ + | matching@(_:_) <- matchingImports moduleName module_ = + if any entireModuleImported matching + then NoImportChange + else AddImportAfter (srcLine . last $ matching) (HS.prettyPrint $ importDecl moduleName) + + | Just bestMatch <- bestMatchingImport moduleName module_ = + AddImportAfter (srcLine bestMatch) (HS.prettyPrint $ importDecl moduleName) + + | otherwise = + case srcLineForNewImport module_ of + Just srcLine -> AddImportAfter srcLine (HS.prettyPrint $ importDecl moduleName) + Nothing -> AddImportAtEnd (HS.prettyPrint $ importDecl moduleName) + + +importModuleWithSymbol :: String -> String -> HS.Module -> ImportChange +importModuleWithSymbol moduleName symbolName module_ + | matching@(_:_) <- matchingImports moduleName module_ = + if any entireModuleImported matching || any (symbolImported symbolName) matching + then NoImportChange + else case find hasImportedSymbols matching of + Just impDecl -> + ReplaceImportAt (srcLine impDecl) (HS.prettyPrint $ addSymbol impDecl symbolName) + + Nothing -> + AddImportAfter (srcLine . last $ matching) + (HS.prettyPrint $ importDeclWithSymbol moduleName symbolName) + + | Just bestMatch <- bestMatchingImport moduleName module_ = + AddImportAfter (srcLine bestMatch) (HS.prettyPrint $ importDeclWithSymbol moduleName symbolName) + + | otherwise = + case srcLineForNewImport module_ of + Just srcLine -> AddImportAfter srcLine (HS.prettyPrint $ importDeclWithSymbol moduleName symbolName) + Nothing -> AddImportAtEnd (HS.prettyPrint $ importDeclWithSymbol moduleName symbolName) + where + addSymbol (id@HS.ImportDecl {HS.importSpecs = specs}) symbolName = + id {HS.importSpecs = specs & _Just . _2 %~ (++ [HS.IVar $ hsName symbolName])} + + +importQualifiedModule :: String -> String -> HS.Module -> ImportChange +importQualifiedModule moduleName qualifiedName module_ + | matching@(_:_) <- matchingImports moduleName module_ = + if any (hasQualifiedImport qualifiedName) matching + then NoImportChange + else AddImportAfter (srcLine . last $ matching) (HS.prettyPrint $ qualifiedImportDecl moduleName qualifiedName) + + | Just bestMatch <- bestMatchingImport moduleName module_ = + AddImportAfter (srcLine bestMatch) (HS.prettyPrint $ qualifiedImportDecl moduleName qualifiedName) + + | otherwise = + case srcLineForNewImport module_ of + Just srcLine -> AddImportAfter srcLine (HS.prettyPrint $ qualifiedImportDecl moduleName qualifiedName) + Nothing -> AddImportAtEnd (HS.prettyPrint $ qualifiedImportDecl moduleName qualifiedName) + + +matchingImports :: String -> HS.Module -> [HS.ImportDecl] +matchingImports moduleName (HS.Module _ _ _ _ _ imports _) = + [ i + | i@HS.ImportDecl {HS.importModule = HS.ModuleName name} <- imports + , moduleName == name + ] + + +bestMatchingImport :: String -> HS.Module -> Maybe HS.ImportDecl +bestMatchingImport moduleName (HS.Module _ _ _ _ _ imports _) = + case ifoldl' computeMatches Nothing splittedMods of + Just (idx, _) -> Just $ imports !! idx + _ -> Nothing + where + computeMatches :: Int -> Maybe (Int, Int) -> [String] -> Maybe (Int, Int) + computeMatches idx matches mod = + let num' = numMatches splittedMod mod + in case matches of + Just (_, num) | num' >= num -> Just (idx, num') + | otherwise -> matches + + Nothing | num' > 0 -> Just (idx, num') + | otherwise -> Nothing + where + numMatches = loop 0 + where + loop num (a:as) (b:bs) + | a == b = loop (num + 1) as bs + | otherwise = num + + loop num [] _ = num + loop num _ [] = num + + splittedMod = splitOn "." moduleName + splittedMods = [ splitOn "." name + | HS.ImportDecl {HS.importModule = HS.ModuleName name} <- imports + ] + + +entireModuleImported :: HS.ImportDecl -> Bool +entireModuleImported import_ = + not (HS.importQualified import_) && isNothing (HS.importSpecs import_) + + +hasQualifiedImport :: String -> HS.ImportDecl -> Bool +hasQualifiedImport qualifiedName import_ + | HS.importQualified import_ + , Just (HS.ModuleName importAs) <- HS.importAs import_ + , importAs == qualifiedName + = True + + | otherwise = False + + +symbolImported :: String -> HS.ImportDecl -> Bool +symbolImported symbol import_ + | Just (False, symbols) <- HS.importSpecs import_ + , any (== symbol) (symbolStrings symbols) + = True + + | otherwise = False + where + symbolStrings = map symbolString + + symbolString (HS.IVar name) = nameString name + symbolString (HS.IAbs name) = nameString name + symbolString (HS.IThingAll name) = nameString name + symbolString (HS.IThingWith name _) = nameString name + + nameString (HS.Ident id) = id + nameString (HS.Symbol sym) = sym + + +hasImportedSymbols :: HS.ImportDecl -> Bool +hasImportedSymbols import_ + | Just (False, _:_) <- HS.importSpecs import_ = True + | otherwise = False + + +importDecl :: String -> HS.ImportDecl +importDecl moduleName = HS.ImportDecl + { HS.importLoc = HS.SrcLoc "" 0 0 + , HS.importModule = HS.ModuleName moduleName + , HS.importQualified = False + , HS.importSrc = False + , HS.importPkg = Nothing + , HS.importAs = Nothing + , HS.importSpecs = Nothing + } + + +importDeclWithSymbol :: String -> String -> HS.ImportDecl +importDeclWithSymbol moduleName symbolName = + (importDecl moduleName) { HS.importSpecs = Just (False, [HS.IVar $ hsName symbolName]) } + + +qualifiedImportDecl :: String -> String -> HS.ImportDecl +qualifiedImportDecl moduleName qualifiedName = + (importDecl moduleName) { HS.importQualified = True + , HS.importAs = if moduleName /= qualifiedName + then Just $ HS.ModuleName qualifiedName + else Nothing + } + + +hsName :: String -> HS.Name +hsName symbolName + | isSymbol = HS.Symbol symbolName + | otherwise = HS.Ident symbolName + where + isSymbol = any (A.notInClass "a-zA-Z0-9_'") symbolName + + +srcLineForNewImport :: HS.Module -> Maybe SrcLine +srcLineForNewImport (HS.Module modSrcLoc _ _ _ _ imports decls) + | not $ null imports = Just (srcLine $ last imports) + + | (decl:_) <- decls + , Just sLoc <- declSrcLoc decl + , HS.srcLine sLoc >= HS.srcLine modSrcLoc + = Just $ max 0 (HS.srcLine sLoc - 1) + + | otherwise = Nothing + + +srcLine :: HS.ImportDecl -> SrcLine +srcLine = HS.srcLine . HS.importLoc + + +declSrcLoc :: HS.Decl -> Maybe HS.SrcLoc +declSrcLoc decl = + case decl of + HS.TypeDecl srcLoc _ _ _ -> Just srcLoc + HS.TypeFamDecl srcLoc _ _ _ -> Just srcLoc + HS.DataDecl srcLoc _ _ _ _ _ _ -> Just srcLoc + HS.GDataDecl srcLoc _ _ _ _ _ _ _ -> Just srcLoc + HS.DataFamDecl srcLoc _ _ _ _ -> Just srcLoc + HS.TypeInsDecl srcLoc _ _ -> Just srcLoc + HS.DataInsDecl srcLoc _ _ _ _ -> Just srcLoc + HS.GDataInsDecl srcLoc _ _ _ _ _ -> Just srcLoc + HS.ClassDecl srcLoc _ _ _ _ _ -> Just srcLoc + HS.InstDecl srcLoc _ _ _ _ -> Just srcLoc + HS.DerivDecl srcLoc _ _ _ -> Just srcLoc + HS.InfixDecl srcLoc _ _ _ -> Just srcLoc + HS.DefaultDecl srcLoc _ -> Just srcLoc + HS.SpliceDecl srcLoc _ -> Just srcLoc + HS.TypeSig srcLoc _ _ -> Just srcLoc + HS.FunBind _ -> Nothing + HS.PatBind srcLoc _ _ _ _ -> Just srcLoc + HS.ForImp srcLoc _ _ _ _ _ -> Just srcLoc + HS.ForExp srcLoc _ _ _ _ -> Just srcLoc + HS.RulePragmaDecl srcLoc _ -> Just srcLoc + HS.DeprPragmaDecl srcLoc _ -> Just srcLoc + HS.WarnPragmaDecl srcLoc _ -> Just srcLoc + HS.InlineSig srcLoc _ _ _ -> Just srcLoc + HS.InlineConlikeSig srcLoc _ _ -> Just srcLoc + HS.SpecSig srcLoc _ _ _ -> Just srcLoc + HS.SpecInlineSig srcLoc _ _ _ _ -> Just srcLoc + HS.InstSig srcLoc _ _ _ -> Just srcLoc + HS.AnnPragma srcLoc _ -> Just srcLoc diff --git a/lib/HsImport/ImportSpec.hs b/lib/HsImport/ImportSpec.hs new file mode 100644 --- /dev/null +++ b/lib/HsImport/ImportSpec.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE TemplateHaskell, PatternGuards #-} + +module HsImport.ImportSpec + ( ImportSpec(..) + , sourceFile + , parsedSrcFile + , moduleToImport + , symbolToImport + , qualifiedName + , saveToFile + , hsImportSpec + ) where + +import Control.Lens +import qualified Language.Haskell.Exts as HS +import qualified HsImport.Args as Args +import HsImport.Args (HsImportArgs) +import HsImport.Parse (parseFile) + +data ImportSpec = ImportSpec + { _sourceFile :: FilePath + , _parsedSrcFile :: HS.Module + , _moduleToImport :: String + , _symbolToImport :: Maybe String + , _qualifiedName :: Maybe String + , _saveToFile :: Maybe FilePath + } deriving (Show) + +makeLenses ''ImportSpec + + +type Error = String +hsImportSpec :: HsImportArgs -> IO (Either Error ImportSpec) +hsImportSpec args + | Just error <- checkArgs args = return $ Left error + | otherwise = do + result <- parseFile $ Args.inputSrcFile args + case result of + Right (HS.ParseOk modul) -> return $ Right $ + ImportSpec (Args.inputSrcFile args) modul + (Args.moduleName args) symbolName + qualifiedName saveToFile + + Right (HS.ParseFailed srcLoc error) -> return $ Left (show srcLoc ++ error) + + Left error -> return $ Left error + + where + symbolName = + case Args.symbolName args of + "" -> Nothing + sym -> Just sym + + qualifiedName = + case Args.qualifiedName args of + "" -> Nothing + qn -> Just qn + + saveToFile = + case Args.outputSrcFile args of + "" -> Nothing + fp -> Just fp + + checkArgs args + | null . Args.inputSrcFile $ args = Just "Missing source file!" + | null . Args.moduleName $ args = Just "Missing module name!" + | otherwise = Nothing diff --git a/lib/HsImport/Main.hs b/lib/HsImport/Main.hs new file mode 100644 --- /dev/null +++ b/lib/HsImport/Main.hs @@ -0,0 +1,50 @@ +{-# Language PatternGuards #-} + +module HsImport.Main + ( hsImport + ) where + +import Control.Lens +import Control.Applicative ((<$>)) +import Control.Monad (when) +import Data.Maybe (isJust) +import Data.List (foldl') +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import HsImport.ImportChange +import HsImport.ImportSpec + + +hsImport :: ImportSpec -> IO () +hsImport spec = do + let impChanges = importChanges (spec ^. moduleToImport) + (spec ^. symbolToImport) + (spec ^. qualifiedName) + (spec ^. parsedSrcFile) + + srcLines <- lines . T.unpack <$> TIO.readFile (spec ^. sourceFile) + let srcLines' = applyChanges srcLines impChanges + when (srcLines' /= srcLines || isJust (spec ^. saveToFile)) $ + TIO.writeFile (outputFile spec) (T.pack $ unlines srcLines') + + where + applyChanges = foldl' applyChange + + applyChange srcLines (ReplaceImportAt srcLine importStr) = + let numDrops = srcLine + numTakes = max 0 (numDrops - 1) + in take numTakes srcLines ++ [importStr] ++ drop numDrops srcLines + + applyChange srcLines (AddImportAfter srcLine importStr) = + let numTakes = srcLine + numDrops = numTakes + in take numTakes srcLines ++ [importStr] ++ drop numDrops srcLines + + applyChange srcLines (AddImportAtEnd importStr) = + srcLines ++ [importStr] + + applyChange srcLines NoImportChange = srcLines + + outputFile spec + | Just file <- spec ^. saveToFile = file + | otherwise = spec ^. sourceFile diff --git a/lib/HsImport/Parse.hs b/lib/HsImport/Parse.hs new file mode 100644 --- /dev/null +++ b/lib/HsImport/Parse.hs @@ -0,0 +1,64 @@ +{-# Language ScopedTypeVariables #-} + +module HsImport.Parse + ( parseFile + ) where + +import qualified Data.Text.IO as TIO +import qualified Data.Text as T +import Data.Maybe (fromMaybe) +import Data.List (isPrefixOf) +import qualified Language.Haskell.Exts as HS +import Control.Applicative ((<$>)) +import Control.Exception (catch, SomeException) + +type Error = String + +parseFile :: FilePath -> IO (Either Error (HS.ParseResult HS.Module)) +parseFile file = do + srcFile <- unlines. replaceCPPByComment . lines . T.unpack <$> TIO.readFile file + catch (do let result = parseFileContents srcFile + case result of + HS.ParseOk _ -> return $ Right result + + HS.ParseFailed srcLoc _ -> do + srcResult <- parseInvalidSource (lines srcFile) 0 (HS.srcLine srcLoc) + return $ Right $ fromMaybe result srcResult) + + (\(e :: SomeException) -> do + let srcLines = lines srcFile + srcResult <- parseInvalidSource srcLines 0 (length srcLines) + return $ maybe (Left $ show e) Right srcResult) + where + -- | replace CPP directives by a fake comment + replaceCPPByComment = map $ \line -> + if "#" `isPrefixOf` line + then "-- fake hsimport comment" + else line + + +-- | tries to find the maximal part of the source file (from the beginning) that contains +-- valid/complete Haskell code +parseInvalidSource :: [String] -> Int -> Int -> IO (Maybe (HS.ParseResult HS.Module)) +parseInvalidSource srcLines lastValidLine firstInvalidLine + | null srcLines || lastValidLine >= firstInvalidLine = return Nothing + | otherwise = + catch (case parseFileContents source of + result@(HS.ParseOk _) + | (nextLine + 1) == firstInvalidLine -> + return $ Just result + | otherwise -> + parseInvalidSource srcLines nextLine firstInvalidLine + + HS.ParseFailed _ _ -> parseInvalidSource srcLines lastValidLine nextLine) + + (\(_ :: SomeException) -> parseInvalidSource srcLines lastValidLine nextLine) + where + source = unlines $ take (nextLine + 1) srcLines + nextLine = lastValidLine + (floor ((realToFrac (firstInvalidLine - lastValidLine) / 2) :: Double) :: Int) + + +parseFileContents :: String -> HS.ParseResult HS.Module +parseFileContents = HS.parseFileContentsWithMode parseMode + where + parseMode = HS.defaultParseMode { HS.fixities = Just [] } diff --git a/src/HsImport.hs b/src/HsImport.hs deleted file mode 100644 --- a/src/HsImport.hs +++ /dev/null @@ -1,11 +0,0 @@ - -module HsImport - ( HsImportArgs - , hsImportArgs - , module HsImport.ImportSpec - , module HsImport.Main - ) where - -import HsImport.Args -import HsImport.ImportSpec -import HsImport.Main diff --git a/src/HsImport/Args.hs b/src/HsImport/Args.hs deleted file mode 100644 --- a/src/HsImport/Args.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable, CPP #-} - -module HsImport.Args - ( HsImportArgs(..) - , hsImportArgs - ) where - -import System.Console.CmdArgs - -#ifdef CABAL -import Data.Version (showVersion) -import Paths_hsimport (version) -#endif - -data HsImportArgs = HsImportArgs - { moduleName :: String - , symbolName :: String - , qualifiedName :: String - , inputSrcFile :: FilePath - , outputSrcFile :: FilePath - } deriving (Data, Typeable, Show, Eq) - - -hsImportArgs :: IO HsImportArgs -hsImportArgs = cmdArgs $ HsImportArgs - { moduleName = def &= help "The module to import" - , symbolName = def &= help "The symbol to import, if empty, the entire module is imported" - , qualifiedName = def &= help "The name to use for a qualified module import" - , outputSrcFile = def &= help "Save modified source file to file, if empty, the source file is modified inplace" &= typFile - , inputSrcFile = def &= args &= typ "SOURCEFILE" - } - &= program "hsimport" - &= summary summaryInfo - &= help "A command line program for extending the import list of a Haskell source file." - &= helpArg [explicit, name "help", name "h"] - &= versionArg [explicit, name "version", name "v", summary versionInfo] - where - summaryInfo = "" - - -versionInfo :: String -versionInfo = -#ifdef CABAL - "hsimport version " ++ showVersion version -#else - "hsimport version unknown (not built with cabal)" -#endif diff --git a/src/HsImport/ImportChange.hs b/src/HsImport/ImportChange.hs deleted file mode 100644 --- a/src/HsImport/ImportChange.hs +++ /dev/null @@ -1,257 +0,0 @@ -{-# Language PatternGuards #-} - -module HsImport.ImportChange - ( ImportChange(..) - , importChanges - ) where - -import Data.Maybe -import Data.List (find) -import Data.List.Split (splitOn) -import Control.Lens -import qualified Language.Haskell.Exts as HS -import qualified Data.Attoparsec.Text as A - -type SrcLine = Int -type ImportString = String - -data ImportChange = ReplaceImportAt SrcLine ImportString - | AddImportAfter SrcLine ImportString - | AddImportAtEnd ImportString - | NoImportChange - deriving (Show) - - -importChanges :: String -> Maybe String -> Maybe String -> HS.Module -> [ImportChange] -importChanges moduleName (Just symbolName) (Just qualifiedName) module_ = - [ importModuleWithSymbol moduleName symbolName module_ - , importQualifiedModule moduleName qualifiedName module_ - ] - -importChanges moduleName (Just symbolName) Nothing module_ = - [ importModuleWithSymbol moduleName symbolName module_ ] - -importChanges moduleName Nothing (Just qualifiedName) module_ = - [ importQualifiedModule moduleName qualifiedName module_ ] - -importChanges moduleName Nothing Nothing module_ = - [ importModule moduleName module_ ] - - -importModule :: String -> HS.Module -> ImportChange -importModule moduleName module_ - | matching@(_:_) <- matchingImports moduleName module_ = - if any entireModuleImported matching - then NoImportChange - else AddImportAfter (srcLine . last $ matching) (HS.prettyPrint $ importDecl moduleName) - - | Just bestMatch <- bestMatchingImport moduleName module_ = - AddImportAfter (srcLine bestMatch) (HS.prettyPrint $ importDecl moduleName) - - | otherwise = - case srcLineForNewImport module_ of - Just srcLine -> AddImportAfter srcLine (HS.prettyPrint $ importDecl moduleName) - Nothing -> AddImportAtEnd (HS.prettyPrint $ importDecl moduleName) - - -importModuleWithSymbol :: String -> String -> HS.Module -> ImportChange -importModuleWithSymbol moduleName symbolName module_ - | matching@(_:_) <- matchingImports moduleName module_ = - if any entireModuleImported matching || any (symbolImported symbolName) matching - then NoImportChange - else case find hasImportedSymbols matching of - Just impDecl -> - ReplaceImportAt (srcLine impDecl) (HS.prettyPrint $ addSymbol impDecl symbolName) - - Nothing -> - AddImportAfter (srcLine . last $ matching) - (HS.prettyPrint $ importDeclWithSymbol moduleName symbolName) - - | Just bestMatch <- bestMatchingImport moduleName module_ = - AddImportAfter (srcLine bestMatch) (HS.prettyPrint $ importDeclWithSymbol moduleName symbolName) - - | otherwise = - case srcLineForNewImport module_ of - Just srcLine -> AddImportAfter srcLine (HS.prettyPrint $ importDeclWithSymbol moduleName symbolName) - Nothing -> AddImportAtEnd (HS.prettyPrint $ importDeclWithSymbol moduleName symbolName) - where - addSymbol (id@HS.ImportDecl {HS.importSpecs = specs}) symbolName = - id {HS.importSpecs = specs & _Just . _2 %~ (++ [HS.IVar $ hsName symbolName])} - - -importQualifiedModule :: String -> String -> HS.Module -> ImportChange -importQualifiedModule moduleName qualifiedName module_ - | matching@(_:_) <- matchingImports moduleName module_ = - if any (hasQualifiedImport qualifiedName) matching - then NoImportChange - else AddImportAfter (srcLine . last $ matching) (HS.prettyPrint $ qualifiedImportDecl moduleName qualifiedName) - - | Just bestMatch <- bestMatchingImport moduleName module_ = - AddImportAfter (srcLine bestMatch) (HS.prettyPrint $ qualifiedImportDecl moduleName qualifiedName) - - | otherwise = - case srcLineForNewImport module_ of - Just srcLine -> AddImportAfter srcLine (HS.prettyPrint $ qualifiedImportDecl moduleName qualifiedName) - Nothing -> AddImportAtEnd (HS.prettyPrint $ qualifiedImportDecl moduleName qualifiedName) - - -matchingImports :: String -> HS.Module -> [HS.ImportDecl] -matchingImports moduleName (HS.Module _ _ _ _ _ imports _) = - [ i - | i@HS.ImportDecl {HS.importModule = HS.ModuleName name} <- imports - , moduleName == name - ] - - -bestMatchingImport :: String -> HS.Module -> Maybe HS.ImportDecl -bestMatchingImport moduleName (HS.Module _ _ _ _ _ imports _) = - case ifoldl' computeMatches Nothing splittedMods of - Just (idx, _) -> Just $ imports !! idx - _ -> Nothing - where - computeMatches :: Int -> Maybe (Int, Int) -> [String] -> Maybe (Int, Int) - computeMatches idx matches mod = - let num' = numMatches splittedMod mod - in case matches of - Just (_, num) | num' >= num -> Just (idx, num') - | otherwise -> matches - - Nothing | num' > 0 -> Just (idx, num') - | otherwise -> Nothing - where - numMatches = loop 0 - where - loop num (a:as) (b:bs) - | a == b = loop (num + 1) as bs - | otherwise = num - - loop num [] _ = num - loop num _ [] = num - - splittedMod = splitOn "." moduleName - splittedMods = [ splitOn "." name - | HS.ImportDecl {HS.importModule = HS.ModuleName name} <- imports - ] - - -entireModuleImported :: HS.ImportDecl -> Bool -entireModuleImported import_ = - not (HS.importQualified import_) && isNothing (HS.importSpecs import_) - - -hasQualifiedImport :: String -> HS.ImportDecl -> Bool -hasQualifiedImport qualifiedName import_ - | HS.importQualified import_ - , Just (HS.ModuleName importAs) <- HS.importAs import_ - , importAs == qualifiedName - = True - - | otherwise = False - - -symbolImported :: String -> HS.ImportDecl -> Bool -symbolImported symbol import_ - | Just (False, symbols) <- HS.importSpecs import_ - , any (== symbol) (symbolStrings symbols) - = True - - | otherwise = False - where - symbolStrings = map symbolString - - symbolString (HS.IVar name) = nameString name - symbolString (HS.IAbs name) = nameString name - symbolString (HS.IThingAll name) = nameString name - symbolString (HS.IThingWith name _) = nameString name - - nameString (HS.Ident id) = id - nameString (HS.Symbol sym) = sym - - -hasImportedSymbols :: HS.ImportDecl -> Bool -hasImportedSymbols import_ - | Just (False, _:_) <- HS.importSpecs import_ = True - | otherwise = False - - -importDecl :: String -> HS.ImportDecl -importDecl moduleName = HS.ImportDecl - { HS.importLoc = HS.SrcLoc "" 0 0 - , HS.importModule = HS.ModuleName moduleName - , HS.importQualified = False - , HS.importSrc = False - , HS.importPkg = Nothing - , HS.importAs = Nothing - , HS.importSpecs = Nothing - } - - -importDeclWithSymbol :: String -> String -> HS.ImportDecl -importDeclWithSymbol moduleName symbolName = - (importDecl moduleName) { HS.importSpecs = Just (False, [HS.IVar $ hsName symbolName]) } - - -qualifiedImportDecl :: String -> String -> HS.ImportDecl -qualifiedImportDecl moduleName qualifiedName = - (importDecl moduleName) { HS.importQualified = True - , HS.importAs = if moduleName /= qualifiedName - then Just $ HS.ModuleName qualifiedName - else Nothing - } - - -hsName :: String -> HS.Name -hsName symbolName - | isSymbol = HS.Symbol symbolName - | otherwise = HS.Ident symbolName - where - isSymbol = any (A.notInClass "a-zA-Z0-9_'") symbolName - - -srcLineForNewImport :: HS.Module -> Maybe SrcLine -srcLineForNewImport (HS.Module modSrcLoc _ _ _ _ imports decls) - | not $ null imports = Just (srcLine $ last imports) - - | (decl:_) <- decls - , Just sLoc <- declSrcLoc decl - , HS.srcLine sLoc >= HS.srcLine modSrcLoc - = Just $ max 0 (HS.srcLine sLoc - 1) - - | otherwise = Nothing - - -srcLine :: HS.ImportDecl -> SrcLine -srcLine = HS.srcLine . HS.importLoc - - -declSrcLoc :: HS.Decl -> Maybe HS.SrcLoc -declSrcLoc decl = - case decl of - HS.TypeDecl srcLoc _ _ _ -> Just srcLoc - HS.TypeFamDecl srcLoc _ _ _ -> Just srcLoc - HS.DataDecl srcLoc _ _ _ _ _ _ -> Just srcLoc - HS.GDataDecl srcLoc _ _ _ _ _ _ _ -> Just srcLoc - HS.DataFamDecl srcLoc _ _ _ _ -> Just srcLoc - HS.TypeInsDecl srcLoc _ _ -> Just srcLoc - HS.DataInsDecl srcLoc _ _ _ _ -> Just srcLoc - HS.GDataInsDecl srcLoc _ _ _ _ _ -> Just srcLoc - HS.ClassDecl srcLoc _ _ _ _ _ -> Just srcLoc - HS.InstDecl srcLoc _ _ _ _ -> Just srcLoc - HS.DerivDecl srcLoc _ _ _ -> Just srcLoc - HS.InfixDecl srcLoc _ _ _ -> Just srcLoc - HS.DefaultDecl srcLoc _ -> Just srcLoc - HS.SpliceDecl srcLoc _ -> Just srcLoc - HS.TypeSig srcLoc _ _ -> Just srcLoc - HS.FunBind _ -> Nothing - HS.PatBind srcLoc _ _ _ _ -> Just srcLoc - HS.ForImp srcLoc _ _ _ _ _ -> Just srcLoc - HS.ForExp srcLoc _ _ _ _ -> Just srcLoc - HS.RulePragmaDecl srcLoc _ -> Just srcLoc - HS.DeprPragmaDecl srcLoc _ -> Just srcLoc - HS.WarnPragmaDecl srcLoc _ -> Just srcLoc - HS.InlineSig srcLoc _ _ _ -> Just srcLoc - HS.InlineConlikeSig srcLoc _ _ -> Just srcLoc - HS.SpecSig srcLoc _ _ _ -> Just srcLoc - HS.SpecInlineSig srcLoc _ _ _ _ -> Just srcLoc - HS.InstSig srcLoc _ _ _ -> Just srcLoc - HS.AnnPragma srcLoc _ -> Just srcLoc diff --git a/src/HsImport/ImportSpec.hs b/src/HsImport/ImportSpec.hs deleted file mode 100644 --- a/src/HsImport/ImportSpec.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-# LANGUAGE TemplateHaskell, PatternGuards #-} - -module HsImport.ImportSpec - ( ImportSpec(..) - , sourceFile - , parsedSrcFile - , moduleToImport - , symbolToImport - , qualifiedName - , saveToFile - , hsImportSpec - ) where - -import Control.Lens -import qualified Language.Haskell.Exts as HS -import qualified HsImport.Args as Args -import HsImport.Args (HsImportArgs) -import HsImport.Parse (parseFile) - -data ImportSpec = ImportSpec - { _sourceFile :: FilePath - , _parsedSrcFile :: HS.Module - , _moduleToImport :: String - , _symbolToImport :: Maybe String - , _qualifiedName :: Maybe String - , _saveToFile :: Maybe FilePath - } deriving (Show) - -makeLenses ''ImportSpec - - -type Error = String -hsImportSpec :: HsImportArgs -> IO (Either Error ImportSpec) -hsImportSpec args - | Just error <- checkArgs args = return $ Left error - | otherwise = do - result <- parseFile $ Args.inputSrcFile args - case result of - Right (HS.ParseOk modul) -> return $ Right $ - ImportSpec (Args.inputSrcFile args) modul - (Args.moduleName args) symbolName - qualifiedName saveToFile - - Right (HS.ParseFailed srcLoc error) -> return $ Left (show srcLoc ++ error) - - Left error -> return $ Left error - - where - symbolName = - case Args.symbolName args of - "" -> Nothing - sym -> Just sym - - qualifiedName = - case Args.qualifiedName args of - "" -> Nothing - qn -> Just qn - - saveToFile = - case Args.outputSrcFile args of - "" -> Nothing - fp -> Just fp - - checkArgs args - | null . Args.inputSrcFile $ args = Just "Missing source file!" - | null . Args.moduleName $ args = Just "Missing module name!" - | otherwise = Nothing diff --git a/src/HsImport/Main.hs b/src/HsImport/Main.hs deleted file mode 100644 --- a/src/HsImport/Main.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-# Language PatternGuards #-} - -module HsImport.Main - ( hsImport - ) where - -import Control.Lens -import Control.Applicative ((<$>)) -import Control.Monad (when) -import Data.Maybe (isJust) -import Data.List (foldl') -import qualified Data.Text as T -import qualified Data.Text.IO as TIO -import HsImport.ImportChange -import HsImport.ImportSpec - - -hsImport :: ImportSpec -> IO () -hsImport spec = do - let impChanges = importChanges (spec ^. moduleToImport) - (spec ^. symbolToImport) - (spec ^. qualifiedName) - (spec ^. parsedSrcFile) - - srcLines <- lines . T.unpack <$> TIO.readFile (spec ^. sourceFile) - let srcLines' = applyChanges srcLines impChanges - when (srcLines' /= srcLines || isJust (spec ^. saveToFile)) $ - TIO.writeFile (outputFile spec) (T.pack $ unlines srcLines') - - where - applyChanges = foldl' applyChange - - applyChange srcLines (ReplaceImportAt srcLine importStr) = - let numDrops = srcLine - numTakes = max 0 (numDrops - 1) - in take numTakes srcLines ++ [importStr] ++ drop numDrops srcLines - - applyChange srcLines (AddImportAfter srcLine importStr) = - let numTakes = srcLine - numDrops = numTakes - in take numTakes srcLines ++ [importStr] ++ drop numDrops srcLines - - applyChange srcLines (AddImportAtEnd importStr) = - srcLines ++ [importStr] - - applyChange srcLines NoImportChange = srcLines - - outputFile spec - | Just file <- spec ^. saveToFile = file - | otherwise = spec ^. sourceFile diff --git a/src/HsImport/Parse.hs b/src/HsImport/Parse.hs deleted file mode 100644 --- a/src/HsImport/Parse.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# Language ScopedTypeVariables #-} - -module HsImport.Parse - ( parseFile - ) where - -import qualified Data.Text.IO as TIO -import qualified Data.Text as T -import Data.Maybe (fromMaybe) -import Data.List (isPrefixOf) -import qualified Language.Haskell.Exts as HS -import Control.Applicative ((<$>)) -import Control.Exception (catch, SomeException) - -type Error = String - -parseFile :: FilePath -> IO (Either Error (HS.ParseResult HS.Module)) -parseFile file = do - srcFile <- unlines. replaceCPPByComment . lines . T.unpack <$> TIO.readFile file - catch (do let result = parseFileContents srcFile - case result of - HS.ParseOk _ -> return $ Right result - - HS.ParseFailed srcLoc _ -> do - srcResult <- parseInvalidSource (lines srcFile) 0 (HS.srcLine srcLoc) - return $ Right $ fromMaybe result srcResult) - - (\(e :: SomeException) -> do - let srcLines = lines srcFile - srcResult <- parseInvalidSource srcLines 0 (length srcLines) - return $ maybe (Left $ show e) Right srcResult) - where - -- | replace CPP directives by a fake comment - replaceCPPByComment = map $ \line -> - if "#" `isPrefixOf` line - then "-- fake hsimport comment" - else line - - --- | tries to find the maximal part of the source file (from the beginning) that contains --- valid/complete Haskell code -parseInvalidSource :: [String] -> Int -> Int -> IO (Maybe (HS.ParseResult HS.Module)) -parseInvalidSource srcLines lastValidLine firstInvalidLine - | null srcLines || lastValidLine >= firstInvalidLine = return Nothing - | otherwise = - catch (case parseFileContents source of - result@(HS.ParseOk _) - | (nextLine + 1) == firstInvalidLine -> - return $ Just result - | otherwise -> - parseInvalidSource srcLines nextLine firstInvalidLine - - HS.ParseFailed _ _ -> parseInvalidSource srcLines lastValidLine nextLine) - - (\(_ :: SomeException) -> parseInvalidSource srcLines lastValidLine nextLine) - where - source = unlines $ take (nextLine + 1) srcLines - nextLine = lastValidLine + (floor ((realToFrac (firstInvalidLine - lastValidLine) / 2) :: Double) :: Int) - - -parseFileContents :: String -> HS.ParseResult HS.Module -parseFileContents = HS.parseFileContentsWithMode parseMode - where - parseMode = HS.defaultParseMode { HS.fixities = Just [] } diff --git a/src/Main.hs b/src/Main.hs deleted file mode 100644 --- a/src/Main.hs +++ /dev/null @@ -1,14 +0,0 @@ - -module Main where - -import System.Exit (exitFailure, exitSuccess) -import System.IO (hPutStrLn, stderr) -import HsImport - -main :: IO () -main = do - args <- hsImportArgs - maybeSpec <- hsImportSpec args - case maybeSpec of - Left error -> hPutStrLn stderr ("hsimport: " ++ error) >> exitFailure - Right spec -> hsImport spec >> exitSuccess