{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | Haskell indenter.
module HIndent
  ( -- * The entry point.
    hindent
  , -- * Formatting functions.
    reformat
  , -- * Config
    Config(..)
  , defaultConfig
  , getConfig
  , -- * Extension
    Extension(..)
  , -- * Error
    ParseError(..)
  , prettyParseError
  , -- * Testing
    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

-- | Runs HIndent with the given commandline options.
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

-- | Format the given source.
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

-- | Generate an AST from the given module for debugging.
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

-- | Print the module.
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)