Main.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

-- | Main entry point to floskell.
module Main ( main ) where

import           Control.Applicative          ( many, optional )
import           Control.Exception            ( catch, throw )

import qualified Data.Aeson.Encode.Pretty     as JSON ( encodePretty )
import qualified Data.ByteString.Lazy         as BL
import           Data.List                    ( sort )
import           Data.Maybe                   ( isJust )
import           Data.Monoid                  ( (<>) )
import qualified Data.Text                    as T
import qualified Data.Text.Lazy               as TL
import qualified Data.Text.Lazy.IO            as TIO
import           Data.Version                 ( showVersion )

import           Floskell
                 ( AppConfig(..), Style(..), defaultAppConfig, findAppConfig
                 , readAppConfig, reformat, setExtensions, setFixities
                 , setLanguage, setStyle, styles )
import           Floskell.ConfigFile          ( showFixity )
import           Floskell.Fixities            ( packageFixities )

import           Foreign.C.Error              ( Errno(..), eXDEV )

import           GHC.IO.Exception             ( ioe_errno )

import           Language.Haskell.Exts
                 ( Extension(..), knownExtensions, knownLanguages )

import           Options.Applicative
                 ( ParseError(..), abortOption, argument, execParser, footerDoc
                 , fullDesc, header, help, helper, hidden, info, long, metavar
                 , option, progDesc, short, str, switch )

import           Paths_floskell               ( version )

import           System.Directory
                 ( copyFile, copyPermissions, getTemporaryDirectory, removeFile
                 , renameFile )
import           System.IO
                 ( FilePath, hClose, hFlush, openTempFile, stdout )

import qualified Text.PrettyPrint.ANSI.Leijen as PP

-- | Program options.
data Options = Options { optStyle         :: Maybe String
                       , optLanguage      :: Maybe String
                       , optExtensions    :: [String]
                       , optFixities      :: [String]
                       , optConfig        :: Maybe FilePath
                       , optPrintConfig   :: Bool
                       , optPrintFixities :: Bool
                       , optFiles         :: [FilePath]
                       }

-- | Main entry point.
main :: IO ()
main = do
    opts <- execParser parser
    mconfig <- case optConfig opts of
        Just c -> return $ Just c
        Nothing ->
            if isJust (optStyle opts) then return Nothing else findAppConfig
    baseConfig <- case mconfig of
        Just path -> readAppConfig path
        Nothing -> return defaultAppConfig
    let config = mergeAppConfig baseConfig opts
    if optPrintFixities opts
        then PP.displayIO stdout . PP.renderPretty 1.0 80 $
            docFixities packageFixities <> PP.linebreak
        else if optPrintConfig opts
             then BL.putStr $ JSON.encodePretty config
             else run config (optFiles opts)
  where
    parser = info (helper <*> versioner <*> options)
                  (fullDesc
                   <> progDesc "Floskell reformats one or more Haskell modules."
                   <> header "floskell - A Haskell Source Code Pretty Printer"
                   <> footerDoc (Just (footerStyles PP.<$$> footerLanguages
                                       PP.<$$> footerExtensions)))

    versioner = abortOption (InfoMsg $ "floskell " ++ showVersion version)
                            (long "version"
                             <> help "Display program version number" <> hidden)

    options = Options
        <$> optional (option str
                             (long "style" <> short 's' <> metavar "STYLE"
                              <> help "Formatting style"))
        <*> optional (option str
                             (long "language" <> short 'L' <> metavar "LANGUAGE"
                              <> help "Select base language"))
        <*> many (option str
                         (long "extension" <> short 'X' <> metavar "EXTENSION"
                          <> help "Enable or disable language extensions"))
        <*> many (option str
                         (long "fixity" <> short 'F' <> metavar "FIXITY"
                          <> help "Add fixity declaration"))
        <*> optional (option str
                             (long "config" <> short 'c' <> metavar "FILE"
                              <> help "Configuration file"))
        <*> switch (long "print-config" <> help "Print configuration")
        <*> switch (long "print-fixities"
                    <> help "Print all built-in fixity declarations")
        <*> many (argument str
                           (metavar "FILES"
                            <> help "Input files (will be replaced)"))

    footerStyles =
        makeFooter "Supported styles:" (map (T.unpack . styleName) styles)

    footerLanguages =
        makeFooter "Supported languages:" (map show knownLanguages)

    footerExtensions =
        makeFooter "Supported extensions:"
                   [ show e | EnableExtension e <- knownExtensions ]

    makeFooter hdr xs =
        PP.empty PP.<$$> PP.text hdr PP.<$$> (PP.indent 2 . PP.fillSep
                                              . PP.punctuate PP.comma
                                              . map PP.text $ sort xs)

    docFixities = PP.vcat . PP.punctuate PP.linebreak
        . map (uncurry docPackageFixities)

    docPackageFixities p fs = PP.text (p ++ ":")
        PP.<$$> (PP.indent 2 . PP.fillSep . PP.punctuate PP.comma
                 . map (PP.text . showFixity) $ sort fs)

-- | Reformat files or stdin based on provided configuration.
run :: AppConfig -> [FilePath] -> IO ()
run config files = case files of
    [] -> reformatStdin config
    _ -> mapM_ (reformatFile config) files

-- | Reformat stdin according to Style, Language, and Extensions.
reformatStdin :: AppConfig -> IO ()
reformatStdin config = TIO.interact $ reformatText config Nothing

-- | Reformat a file according to Style, Language, and Extensions.
reformatFile :: AppConfig -> FilePath -> IO ()
reformatFile config file = do
    text <- TIO.readFile file
    tmpDir <- getTemporaryDirectory
    (fp, h) <- openTempFile tmpDir "floskell.hs"
    TIO.hPutStr h $ reformatText config (Just file) text
    hFlush h
    hClose h
    let exdev e = if ioe_errno e == Just ((\(Errno a) -> a) eXDEV)
                  then copyFile fp file >> removeFile fp
                  else throw e
    copyPermissions file fp
    renameFile fp file `catch` exdev

-- | Reformat a Text according to Style, Language, and Extensions.
reformatText :: AppConfig -> Maybe FilePath -> TL.Text -> TL.Text
reformatText config mpath text = either error id $ reformat config mpath text

-- | Update the program configuration from the program options.
mergeAppConfig :: AppConfig -> Options -> AppConfig
mergeAppConfig cfg Options{..} =
    cfg `setStyle` optStyle `setLanguage` optLanguage
    `setExtensions` optExtensions `setFixities` optFixities