{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module HIndent
(
hindent
,
reformat
,
Config(..)
, defaultConfig
, getConfig
,
Extension(..)
,
ParseError(..)
, prettyParseError
,
testAst
, HsModule'
) where
import Control.Exception
import Control.Monad
import Data.ByteString (ByteString)
import qualified Data.ByteString as S
import Data.ByteString.Builder (Builder)
import qualified Data.ByteString.Builder as S
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.UTF8 as UTF8
import Data.Char
import Data.Maybe
import Data.Version
import Foreign.C
import GHC.IO.Exception
import GHC.Parser.Lexer hiding (buffer, options)
import GHC.Types.SrcLoc
import HIndent.ByteString
import HIndent.CabalFile
import HIndent.CodeBlock
import HIndent.CommandlineOptions
import HIndent.Config
import HIndent.Error
import HIndent.GhcLibParserWrapper.GHC.Hs
import HIndent.LanguageExtension
import qualified HIndent.LanguageExtension.Conversion as CE
import HIndent.LanguageExtension.Types
import HIndent.ModulePreprocessing
import HIndent.Parse
import HIndent.Pretty
import HIndent.Printer
import Options.Applicative hiding (ParseError, action, style)
import Paths_hindent
import qualified System.Directory as IO
import System.Exit
import qualified System.IO as IO
hindent :: [String] -> IO ()
hindent :: [FilePath] -> IO ()
hindent [FilePath]
args = do
Config
config <- IO Config
getConfig
RunMode
runMode <-
ParserResult RunMode -> IO RunMode
forall a. ParserResult a -> IO a
handleParseResult
(ParserResult RunMode -> IO RunMode)
-> ParserResult RunMode -> IO RunMode
forall a b. (a -> b) -> a -> b
$ ParserPrefs
-> ParserInfo RunMode -> [FilePath] -> ParserResult RunMode
forall a.
ParserPrefs -> ParserInfo a -> [FilePath] -> ParserResult a
execParserPure
ParserPrefs
defaultPrefs
(Parser RunMode -> InfoMod RunMode -> ParserInfo RunMode
forall a. Parser a -> InfoMod a -> ParserInfo a
info
(Config -> Parser RunMode
options Config
config Parser RunMode -> Parser (RunMode -> RunMode) -> Parser RunMode
forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> Parser (RunMode -> RunMode)
forall a. Parser (a -> a)
helper)
(FilePath -> InfoMod RunMode
forall a. FilePath -> InfoMod a
header FilePath
"hindent - Reformat Haskell source code"))
[FilePath]
args
case RunMode
runMode of
RunMode
ShowVersion -> FilePath -> IO ()
putStrLn (FilePath
"hindent " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Version -> FilePath
showVersion Version
version)
Run Config
style [Extension]
exts Action
action [FilePath]
paths ->
if [FilePath] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
paths
then (ByteString -> ByteString) -> IO ()
S8.interact
((ParseError -> ByteString)
-> (ByteString -> ByteString)
-> Either ParseError ByteString
-> ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (FilePath -> ByteString
forall a. HasCallStack => FilePath -> a
error (FilePath -> ByteString)
-> (ParseError -> FilePath) -> ParseError -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError -> FilePath
prettyParseError) ByteString -> ByteString
forall a. a -> a
id
(Either ParseError ByteString -> ByteString)
-> (ByteString -> Either ParseError ByteString)
-> ByteString
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config
-> [Extension]
-> Maybe FilePath
-> ByteString
-> Either ParseError ByteString
reformat Config
style [Extension]
exts Maybe FilePath
forall a. Maybe a
Nothing)
else [FilePath] -> (FilePath -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FilePath]
paths ((FilePath -> IO ()) -> IO ()) -> (FilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \FilePath
filepath -> do
[Extension]
cabalexts <- FilePath -> IO [Extension]
getCabalExtensionsForSourcePath FilePath
filepath
ByteString
text <- FilePath -> IO ByteString
S.readFile FilePath
filepath
case Config
-> [Extension]
-> Maybe FilePath
-> ByteString
-> Either ParseError ByteString
reformat Config
style ([Extension]
cabalexts [Extension] -> [Extension] -> [Extension]
forall a. [a] -> [a] -> [a]
++ [Extension]
exts) (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
filepath) ByteString
text of
Left ParseError
e -> FilePath -> IO ()
forall a. HasCallStack => FilePath -> a
error (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ ParseError -> FilePath
prettyParseError ParseError
e
Right ByteString
out ->
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString
text ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
out)
(IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ case Action
action of
Action
Validate -> do
FilePath -> IO ()
IO.putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
filepath FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" is not formatted"
ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1)
Action
Reformat -> do
FilePath
tmpDir <- IO FilePath
IO.getTemporaryDirectory
(FilePath
fp, Handle
h) <- FilePath -> FilePath -> IO (FilePath, Handle)
IO.openTempFile FilePath
tmpDir FilePath
"hindent.hs"
Handle -> ByteString -> IO ()
S8.hPutStr Handle
h ByteString
out
Handle -> IO ()
IO.hFlush Handle
h
Handle -> IO ()
IO.hClose Handle
h
let exdev :: IOException -> IO ()
exdev IOException
e =
if IOException -> Maybe CInt
ioe_errno IOException
e
Maybe CInt -> Maybe CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt -> Maybe CInt
forall a. a -> Maybe a
Just ((\(Errno CInt
a) -> CInt
a) Errno
eXDEV)
then FilePath -> FilePath -> IO ()
IO.copyFile FilePath
fp FilePath
filepath
IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FilePath -> IO ()
IO.removeFile FilePath
fp
else IOException -> IO ()
forall a e. Exception e => e -> a
throw IOException
e
FilePath -> FilePath -> IO ()
IO.copyPermissions FilePath
filepath FilePath
fp
FilePath -> FilePath -> IO ()
IO.renameFile FilePath
fp FilePath
filepath IO () -> (IOException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` IOException -> IO ()
exdev
reformat ::
Config
-> [Extension]
-> Maybe FilePath
-> ByteString
-> Either ParseError ByteString
reformat :: Config
-> [Extension]
-> Maybe FilePath
-> ByteString
-> Either ParseError ByteString
reformat Config
config [Extension]
mexts Maybe FilePath
mfilepath ByteString
rawCode =
(ByteString -> Either ParseError ByteString)
-> ByteString -> Either ParseError ByteString
forall {m :: * -> *}.
Monad m =>
(ByteString -> m ByteString) -> ByteString -> m ByteString
preserveTrailingNewline
(([ByteString] -> ByteString)
-> Either ParseError [ByteString] -> Either ParseError ByteString
forall a b. (a -> b) -> Either ParseError a -> Either ParseError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [ByteString] -> ByteString
unlines' (Either ParseError [ByteString] -> Either ParseError ByteString)
-> (ByteString -> Either ParseError [ByteString])
-> ByteString
-> Either ParseError ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CodeBlock -> Either ParseError ByteString)
-> [CodeBlock] -> Either ParseError [ByteString]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM CodeBlock -> Either ParseError ByteString
processBlock ([CodeBlock] -> Either ParseError [ByteString])
-> (ByteString -> [CodeBlock])
-> ByteString
-> Either ParseError [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [CodeBlock]
cppSplitBlocks)
ByteString
rawCode
where
processBlock :: CodeBlock -> Either ParseError ByteString
processBlock :: CodeBlock -> Either ParseError ByteString
processBlock (Shebang ByteString
text) = ByteString -> Either ParseError ByteString
forall a b. b -> Either a b
Right ByteString
text
processBlock (CPPDirectives ByteString
text) = ByteString -> Either ParseError ByteString
forall a b. b -> Either a b
Right ByteString
text
processBlock (HaskellSource Int
yPos ByteString
text) =
let ls :: [ByteString]
ls = ByteString -> [ByteString]
S8.lines ByteString
text
prefix :: ByteString
prefix = [ByteString] -> ByteString
findPrefix [ByteString]
ls
code :: ByteString
code = [ByteString] -> ByteString
unlines' ((ByteString -> ByteString) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> ByteString
stripPrefixIfNotNull [ByteString]
ls)
stripPrefixIfNotNull :: ByteString -> ByteString
stripPrefixIfNotNull ByteString
s =
if ByteString -> Bool
S.null ByteString
s
then ByteString
s
else ByteString -> ByteString -> ByteString
stripPrefix ByteString
prefix ByteString
s
in case Maybe FilePath -> [Extension] -> FilePath -> ParseResult HsModule'
parseModule Maybe FilePath
mfilepath [Extension]
allExts (ByteString -> FilePath
UTF8.toString ByteString
code) of
POk PState
_ HsModule'
m ->
ByteString -> Either ParseError ByteString
forall a b. b -> Either a b
Right
(ByteString -> Either ParseError ByteString)
-> ByteString -> Either ParseError ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> ByteString
addPrefix ByteString
prefix
(ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
L.toStrict
(ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
S.toLazyByteString
(Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ Config -> HsModule' -> Builder
prettyPrint Config
config HsModule'
m
PFailed PState
st ->
let rawErrLoc :: RealSrcLoc
rawErrLoc = PsLoc -> RealSrcLoc
psRealLoc (PsLoc -> RealSrcLoc) -> PsLoc -> RealSrcLoc
forall a b. (a -> b) -> a -> b
$ PState -> PsLoc
loc PState
st
in ParseError -> Either ParseError ByteString
forall a b. a -> Either a b
Left
(ParseError -> Either ParseError ByteString)
-> ParseError -> Either ParseError ByteString
forall a b. (a -> b) -> a -> b
$ ParseError
{ errorLine :: Int
errorLine = RealSrcLoc -> Int
srcLocLine RealSrcLoc
rawErrLoc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
yPos
, errorCol :: Int
errorCol = RealSrcLoc -> Int
srcLocCol RealSrcLoc
rawErrLoc
, errorFile :: FilePath
errorFile = FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe FilePath
"<interactive>" Maybe FilePath
mfilepath
}
preserveTrailingNewline :: (ByteString -> m ByteString) -> ByteString -> m ByteString
preserveTrailingNewline ByteString -> m ByteString
f ByteString
x
| ByteString -> Bool
S8.null ByteString
x Bool -> Bool -> Bool
|| (Char -> Bool) -> ByteString -> Bool
S8.all Char -> Bool
isSpace ByteString
x = ByteString -> m ByteString
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
forall a. Monoid a => a
mempty
| ByteString -> Bool
hasTrailingLine ByteString
x Bool -> Bool -> Bool
|| Config -> Bool
configTrailingNewline Config
config =
(ByteString -> ByteString) -> m ByteString -> m ByteString
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
(\ByteString
x' ->
if ByteString -> Bool
hasTrailingLine ByteString
x'
then ByteString
x'
else ByteString
x' ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\n")
(ByteString -> m ByteString
f ByteString
x)
| Bool
otherwise = ByteString -> m ByteString
f ByteString
x
allExts :: [Extension]
allExts =
[Extension] -> [Extension]
CE.uniqueExtensions
([Extension] -> [Extension]) -> [Extension] -> [Extension]
forall a b. (a -> b) -> a -> b
$ (Extension -> [Extension]) -> [Extension] -> [Extension]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Extension
x -> Extension
x Extension -> [Extension] -> [Extension]
forall a. a -> [a] -> [a]
: Extension -> [Extension]
extensionImplies Extension
x)
([Extension] -> [Extension]) -> [Extension] -> [Extension]
forall a b. (a -> b) -> a -> b
$ [Extension]
mexts [Extension] -> [Extension] -> [Extension]
forall a. [a] -> [a] -> [a]
++ Config -> [Extension]
configExtensions Config
config [Extension] -> [Extension] -> [Extension]
forall a. [a] -> [a] -> [a]
++ [Extension]
allExtsFromCode
allExtsFromCode :: [Extension]
allExtsFromCode = (CodeBlock -> [Extension]) -> [CodeBlock] -> [Extension]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap CodeBlock -> [Extension]
f [CodeBlock]
codeBlocks
where
f :: CodeBlock -> [Extension]
f (HaskellSource Int
_ ByteString
text) =
FilePath -> [Extension]
collectLanguageExtensionsFromSource (FilePath -> [Extension]) -> FilePath -> [Extension]
forall a b. (a -> b) -> a -> b
$ ByteString -> FilePath
UTF8.toString ByteString
text
f CodeBlock
_ = []
codeBlocks :: [CodeBlock]
codeBlocks = ByteString -> [CodeBlock]
cppSplitBlocks ByteString
rawCode
testAst :: ByteString -> Either ParseError HsModule'
testAst :: ByteString -> Either ParseError HsModule'
testAst ByteString
x =
case Maybe FilePath -> [Extension] -> FilePath -> ParseResult HsModule'
parseModule Maybe FilePath
forall a. Maybe a
Nothing [Extension]
exts (ByteString -> FilePath
UTF8.toString ByteString
x) of
POk PState
_ HsModule'
m -> HsModule' -> Either ParseError HsModule'
forall a b. b -> Either a b
Right (HsModule' -> Either ParseError HsModule')
-> HsModule' -> Either ParseError HsModule'
forall a b. (a -> b) -> a -> b
$ HsModule' -> HsModule'
modifyASTForPrettyPrinting HsModule'
m
PFailed PState
st ->
ParseError -> Either ParseError HsModule'
forall a b. a -> Either a b
Left
(ParseError -> Either ParseError HsModule')
-> ParseError -> Either ParseError HsModule'
forall a b. (a -> b) -> a -> b
$ Int -> Int -> FilePath -> ParseError
ParseError (Int -> Int -> FilePath -> ParseError)
-> (RealSrcLoc -> Int)
-> RealSrcLoc
-> Int
-> FilePath
-> ParseError
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RealSrcLoc -> Int
srcLocLine (RealSrcLoc -> Int -> FilePath -> ParseError)
-> (RealSrcLoc -> Int) -> RealSrcLoc -> FilePath -> ParseError
forall a b.
(RealSrcLoc -> a -> b) -> (RealSrcLoc -> a) -> RealSrcLoc -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RealSrcLoc -> Int
srcLocCol (RealSrcLoc -> FilePath -> ParseError)
-> (RealSrcLoc -> FilePath) -> RealSrcLoc -> ParseError
forall a b.
(RealSrcLoc -> a -> b) -> (RealSrcLoc -> a) -> RealSrcLoc -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FilePath -> RealSrcLoc -> FilePath
forall a. a -> RealSrcLoc -> a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
"<interactive>"
(RealSrcLoc -> ParseError) -> RealSrcLoc -> ParseError
forall a b. (a -> b) -> a -> b
$ PsLoc -> RealSrcLoc
psRealLoc
(PsLoc -> RealSrcLoc) -> PsLoc -> RealSrcLoc
forall a b. (a -> b) -> a -> b
$ PState -> PsLoc
loc PState
st
where
exts :: [Extension]
exts =
[Extension] -> [Extension]
CE.uniqueExtensions
([Extension] -> [Extension]) -> [Extension] -> [Extension]
forall a b. (a -> b) -> a -> b
$ FilePath -> [Extension]
collectLanguageExtensionsFromSource
(FilePath -> [Extension]) -> FilePath -> [Extension]
forall a b. (a -> b) -> a -> b
$ ByteString -> FilePath
UTF8.toString ByteString
x
prettyPrint :: Config -> HsModule' -> Builder
prettyPrint :: Config -> HsModule' -> Builder
prettyPrint Config
config HsModule'
m =
Config -> Printer () -> Builder
runPrinterStyle Config
config (HsModule' -> Printer ()
forall a. Pretty a => a -> Printer ()
pretty (HsModule' -> Printer ()) -> HsModule' -> Printer ()
forall a b. (a -> b) -> a -> b
$ HsModule' -> HsModule'
modifyASTForPrettyPrinting HsModule'
m)