{-|
Description : Root of executable
-}
module Main (main) where
import qualified Data.Foldable as Foldable
import qualified Data.Function as Function
import qualified Data.List as List
import qualified Data.Monoid as Monoid
import qualified Language.Haskell.Formatter as Formatter
import qualified Language.Haskell.Formatter.Internal.Newline as Newline
import qualified Language.Haskell.Formatter.Internal.StyleFileFormat
       as StyleFileFormat
import qualified Language.Haskell.Formatter.Internal.TreeFormat as TreeFormat
import qualified Options.Applicative as Applicative
import qualified System.Directory as Directory
import qualified System.Exit as Exit
import qualified System.FilePath as FilePath
import qualified System.IO as IO

data Arguments = Arguments{input :: Maybe FilePath, output :: Maybe FilePath,
                           force :: Bool, styleFile :: Maybe FilePath}
                   deriving (Eq, Ord, Show)

main :: IO ()
main
  = do arguments <- Applicative.execParser utilityUsage
       maybeError <- formatWithUncheckedArguments arguments
       Foldable.mapM_ exitWithError maybeError
  where exitWithError errorMessage
          = putErrorLine errorMessage >> Exit.exitFailure
        putErrorLine = IO.hPutStrLn IO.stderr

utilityUsage :: Applicative.ParserInfo Arguments
utilityUsage = Applicative.info parserWithHelp modifier
  where parserWithHelp = Applicative.helper Applicative.<*> argumentParser
        modifier
          = Monoid.mconcat
              [Applicative.fullDesc, oneLineDescription, description]
        oneLineDescription
          = Applicative.header
              "Haskell Formatter – A Haskell source code formatter"
        description
          = Applicative.progDesc $
              createParagraphs
                [["The Haskell Formatter formats Haskell source code. ",
                  "It is strict in that it fundamentally rearranges code."],
                 ["The source code is read from INPUT, ",
                  "formatted, and written to OUTPUT."]]

argumentParser :: Applicative.Parser Arguments
argumentParser
  = Arguments Applicative.<$> inputOption Applicative.<*> outputOption
      Applicative.<*> forceOption
      Applicative.<*> styleOption
  where inputOption
          = Applicative.optional . Applicative.strOption $
              Monoid.mconcat
                [Applicative.short 'i', Applicative.long "input",
                 Applicative.metavar "INPUT",
                 Applicative.help
                   "Input source code file (default: standard input)"]
        outputOption
          = Applicative.optional . Applicative.strOption $
              Monoid.mconcat
                [Applicative.short 'o', Applicative.long "output",
                 Applicative.metavar "OUTPUT",
                 Applicative.help
                   "Output source code file (default: standard output)"]
        forceOption
          = Applicative.switch $
              Monoid.mconcat
                [Applicative.short forceStandardName, Applicative.long "force",
                 Applicative.help
                   "Allows the output file to overwrite the input file"]
        styleOption
          = Applicative.optional . Applicative.strOption $
              Monoid.mconcat
                [Applicative.short 's', Applicative.long "style",
                 Applicative.metavar "STYLE",
                 Applicative.help "Formatting style file"]

forceStandardName :: Char
forceStandardName = 'f'

createParagraphs :: [[String]] -> String
createParagraphs
  = Newline.joinSeparatedLines . List.intersperse emptyLine . fmap concat
  where emptyLine = ""

formatWithUncheckedArguments :: Arguments -> IO (Maybe String)
formatWithUncheckedArguments arguments
  = do maybeError <- checkArguments arguments
       case maybeError of
           Nothing -> formatWithCheckedArguments arguments
           Just errorMessage -> return $ Just errorMessage

checkArguments :: Arguments -> IO (Maybe String)
checkArguments arguments
  = case (maybeInput, maybeOutput) of
        (Just inputPath, Just outputPath) -> if forceOverwriting then
                                               return Nothing else
                                               do same <- sameExistentPaths
                                                            inputPath
                                                            outputPath
                                                  return $
                                                    if same then
                                                      Just overwritingError else
                                                      Nothing
          where overwritingError
                  = concat
                      ["The output path ", show outputPath,
                       " would overwrite the input path ", show inputPath, ". ",
                       "Either use unequal paths or apply the ",
                       show forceStandardName, " option, please."]
        _ -> return Nothing
  where maybeInput = input arguments
        maybeOutput = output arguments
        forceOverwriting = force arguments

{-| Do both file paths exist and refer to the same file or folder? -}
sameExistentPaths :: FilePath -> FilePath -> IO Bool
sameExistentPaths left right
  = do exist <- bothPathsExist
       if exist then
         liftedOn FilePath.equalFilePath Directory.canonicalizePath left right
         else return False
  where bothPathsExist = liftedOn (&&) pathExists left right
        liftedOn = Function.on . Applicative.liftA2
        pathExists path
          = Applicative.liftA2 (||) (Directory.doesFileExist path) $
              Directory.doesDirectoryExist path

formatWithCheckedArguments :: Arguments -> IO (Maybe String)
formatWithCheckedArguments arguments
  = do maybeConfiguration <- getConfiguration arguments
       case maybeConfiguration of
           Left errorMessage -> return $ Just errorMessage
           Right configuration -> formatWithConfiguration arguments
                                    configuration

getConfiguration :: Arguments -> IO (Either String Formatter.Configuration)
getConfiguration arguments
  = do maybeStyle <- getStyle arguments
       return $
         case maybeStyle of
             Left message -> Left message
             Right style -> Right configuration
               where configuration
                       = defaults{Formatter.configurationStyle = style}
  where defaults
          = Formatter.defaultConfiguration{Formatter.configurationStreamName =
                                             stream}
        stream
          = maybe Formatter.standardInput Formatter.createStreamName maybeInput
        maybeInput = input arguments

getStyle :: Arguments -> IO (Either String Formatter.Style)
getStyle arguments
  = case styleFile arguments of
        Nothing -> return $ Right defaultStyle
        Just file -> TreeFormat.parseYamlFile StyleFileFormat.treeFormat
                       defaultStyle
                       file
  where defaultStyle
          = Formatter.configurationStyle Formatter.defaultConfiguration

formatWithConfiguration ::
                        Arguments ->
                          Formatter.Configuration -> IO (Maybe String)
formatWithConfiguration arguments configuration
  = do inputString <- readInput
       case Formatter.format configuration inputString of
           Left libraryError -> return . Just $ showError libraryError
           Right outputString -> do evaluateString outputString $
                                      writeOutput outputString
                                    return Nothing
  where readInput = maybe getContents readFile maybeInput
        maybeInput = input arguments
        evaluateString string = seq $ length string
        writeOutput = maybe putStr writeFile maybeOutput
        maybeOutput = output arguments

showError :: Formatter.Error -> String
showError libraryError
  = if Formatter.isAssertionError libraryError then assertionError else rawError
  where assertionError
          = createParagraphs
              [["Oops, an error occurred. ", "Feel free to report this, ",
                "because it appears to be a bug. Thanks! ",
                "The specific error message follows."],
               [rawError]]
        rawError = show libraryError