{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Language.Haskell.Brittany.Main where

import Control.Monad (zipWithM)
import qualified Control.Monad.Trans.Except as ExceptT
import qualified Data.Either
import qualified Data.List.Extra
import qualified Data.Monoid
import qualified Data.Text.IO as Text.IO
import GHC (GenLocated(L))
import qualified GHC
import qualified GHC.OldList as List
import GHC.Utils.Outputable (Outputable(..), showSDocUnsafe)
import Language.Haskell.Brittany.Internal
import Language.Haskell.Brittany.Internal.Config.Config
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Utils
import Paths_brittany
import qualified System.Directory as Directory
import qualified System.Environment as Environment
import qualified System.Exit
import qualified System.FilePath.Posix as FilePath
import qualified System.IO
import qualified Text.ParserCombinators.ReadP as ReadP
import qualified Text.ParserCombinators.ReadPrec as ReadPrec
import qualified Text.PrettyPrint as PP
import Text.Read (Read(..))
import UI.Butcher.Monadic



data WriteMode = Display | Inplace

instance Read WriteMode where
  readPrec = val "display" Display <|> val "inplace" Inplace
    where val iden v = ReadPrec.lift $ ReadP.string iden >> return v

instance Show WriteMode where
  show Display = "display"
  show Inplace = "inplace"


main :: IO ()
main = do
  progName <- Environment.getProgName
  args <- Environment.getArgs
  mainWith progName args

testMain :: IO ()
testMain = do
  h <- System.IO.openFile "local/sample-folder/err.txt" System.IO.WriteMode
  let cmdlineR =
        runCmdParser
            Nothing
            (InputArgs
              [ "--output-on-errors"
              , "--dump-ast-full"
              , "--omit-output-check"
              -- , "--dump-bridoc-alt"
              , "--dump-bridoc-floating"
              -- , "--dump-bridoc-par"
              -- , "--dump-bridoc-columns"
              , "--dump-bridoc-final"
              ]
            )
          $ do
              reorderStart
              c <- cmdlineConfigParser
              reorderStop
              addCmdImpl c
  let cmdlineConfig = case _ppi_value cmdlineR of
        Left  err       -> error (show err)
        Right (Nothing) -> error "could not parse config"
        Right (Just r ) -> r
  configsToLoad <-
    maybeToList <$> (Directory.getCurrentDirectory >>= findLocalConfigPath)
  config <- runMaybeT (readConfigs cmdlineConfig configsToLoad)
        -- (readConfigsWithUserConfig cmdlineConfig configsToLoad)
                                                                >>= \case
    Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 53)
    Just x  -> return x
  System.IO.hPutStrLn h $ showConfigYaml config
  e <- coreIO (System.IO.hPutStrLn h)
              config
              False
              False
              (Just "local/sample-folder/Test.hs")
              (Just "local/sample-folder/out.txt")
  case e of
    Left  i         -> print i
    Right Changes   -> putStrLn "Changes"
    Right NoChanges -> putStrLn "NoChanges"

mainWith :: String -> [String] -> IO ()
mainWith progName args =
  Environment.withProgName progName
    . Environment.withArgs args
    $ mainFromCmdParser mainCmdParser

helpDoc :: PP.Doc
helpDoc = PP.vcat $ List.intersperse
  (PP.text "")
  [ parDocW
    [ "Reformats one or more haskell modules."
    , "Currently affects only the module head (imports/exports), type"
    , "signatures and function bindings;"
    , "everything else is left unmodified."
    , "Based on ghc-exactprint, thus (theoretically) supporting all"
    , "that ghc does."
    ]
  , parDoc $ "Example invocations:"
  , PP.hang (PP.text "") 2 $ PP.vcat
    [ PP.text "brittany"
    , PP.nest 2 $ PP.text "read from stdin, output to stdout"
    ]
  , PP.hang (PP.text "") 2 $ PP.vcat
    [ PP.text "brittany --indent=4 --write-mode=inplace *.hs"
    , PP.nest 2 $ PP.vcat
      [ PP.text "run on all modules in current directory (no backup!)"
      , PP.text "4 spaces indentation"
      ]
    ]
  , parDocW
    [ "This program is written carefully and contains safeguards to ensure"
    , "the output is syntactically valid and that no comments are removed."
    , "Nonetheless, this is a young project, and there will always be bugs,"
    , "and ensuring that the transformation never changes semantics of the"
    , "transformed source is currently not possible."
    , "Please do check the output and do not let brittany override your large"
    , "codebase without having backups."
    ]
  , parDoc $ "There is NO WARRANTY, to the extent permitted by law."
  , parDocW
    [ "This program is free software released under the AGPLv3."
    , "For details use the --license flag."
    ]
  , parDoc $ "See https://github.com/lspitzner/brittany"
  , parDoc
  $ "Please report bugs at"
  ++ " https://github.com/lspitzner/brittany/issues"
  ]

licenseDoc :: PP.Doc
licenseDoc = PP.vcat $ List.intersperse
  (PP.text "")
  [ parDoc $ "Copyright (C) 2016-2019 Lennart Spitzner"
  , parDoc $ "Copyright (C) 2019 PRODA LTD"
  , parDocW
    [ "This program is free software: you can redistribute it and/or modify"
    , "it under the terms of the GNU Affero General Public License,"
    , "version 3, as published by the Free Software Foundation."
    ]
  , parDocW
    [ "This program is distributed in the hope that it will be useful,"
    , "but WITHOUT ANY WARRANTY; without even the implied warranty of"
    , "MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the"
    , "GNU Affero General Public License for more details."
    ]
  , parDocW
    [ "You should have received a copy of the GNU Affero General Public"
    , "License along with this program.  If not, see"
    , "<http://www.gnu.org/licenses/>."
    ]
  ]


mainCmdParser :: CmdParser Identity (IO ()) ()
mainCmdParser = do
  helpDesc <- peekCmdDesc
  addCmdSynopsis "haskell source pretty printer"
  addCmdHelp $ helpDoc
  -- addCmd "debugArgs" $ do
  addHelpCommand helpDesc
  addCmd "license" $ addCmdImpl $ print $ licenseDoc
  -- addButcherDebugCommand
  reorderStart
  printHelp <- addSimpleBoolFlag "h" ["help"] mempty
  printVersion <- addSimpleBoolFlag "" ["version"] mempty
  printLicense <- addSimpleBoolFlag "" ["license"] mempty
  noUserConfig <- addSimpleBoolFlag "" ["no-user-config"] mempty
  configPaths <- addFlagStringParams
    ""
    ["config-file"]
    "PATH"
    (flagHelpStr "path to config file") -- TODO: allow default on addFlagStringParam ?
  cmdlineConfig <- cmdlineConfigParser
  suppressOutput <- addSimpleBoolFlag
    ""
    ["suppress-output"]
    (flagHelp $ parDoc
      "suppress the regular output, i.e. the transformed haskell source"
    )
  _verbosity <- addSimpleCountFlag
    "v"
    ["verbose"]
    (flagHelp $ parDoc "[currently without effect; TODO]")
  checkMode <- addSimpleBoolFlag
    "c"
    ["check-mode"]
    (flagHelp
      (PP.vcat
        [ PP.text "check for changes but do not write them out"
        , PP.text "exits with code 0 if no changes necessary, 1 otherwise"
        , PP.text "and print file path(s) of files that have changes to stdout"
        ]
      )
    )
  writeMode <- addFlagReadParam
    ""
    ["write-mode"]
    "(display|inplace)"
    (flagHelp
        (PP.vcat
          [ PP.text "display: output for any input(s) goes to stdout"
          , PP.text "inplace: override respective input file (without backup!)"
          ]
        )
    Data.Monoid.<> flagDefault Display
    )
  inputParams <- addParamNoFlagStrings
    "PATH"
    (paramHelpStr "paths to input/inout haskell source files")
  reorderStop
  addCmdImpl $ void $ do
    when printLicense $ do
      print licenseDoc
      System.Exit.exitSuccess
    when printVersion $ do
      do
        putStrLn $ "brittany version " ++ showVersion version
        putStrLn $ "Copyright (C) 2016-2019 Lennart Spitzner"
        putStrLn $ "Copyright (C) 2019 PRODA LTD"
        putStrLn $ "There is NO WARRANTY, to the extent permitted by law."
      System.Exit.exitSuccess
    when printHelp $ do
      liftIO
        $ putStrLn
        $ PP.renderStyle PP.style { PP.ribbonsPerLine = 1.0 }
        $ ppHelpShallow helpDesc
      System.Exit.exitSuccess

    let
      inputPaths = if null inputParams then [Nothing] else map Just inputParams
    let
      outputPaths = case writeMode of
        Display -> repeat Nothing
        Inplace -> inputPaths

    configsToLoad <- liftIO $ if null configPaths
      then
        maybeToList <$> (Directory.getCurrentDirectory >>= findLocalConfigPath)
      else pure configPaths

    config <-
      runMaybeT
          (if noUserConfig
            then readConfigs cmdlineConfig configsToLoad
            else readConfigsWithUserConfig cmdlineConfig configsToLoad
          )
        >>= \case
              Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 53)
              Just x -> return x
    when (config & _conf_debug & _dconf_dump_config & confUnpack)
      $ trace (showConfigYaml config)
      $ return ()

    results <- zipWithM
      (coreIO putStrErrLn config suppressOutput checkMode)
      inputPaths
      outputPaths

    if checkMode
      then when (Changes `elem` (Data.Either.rights results))
        $ System.Exit.exitWith (System.Exit.ExitFailure 1)
      else case results of
        xs | all Data.Either.isRight xs -> pure ()
        [Left x] -> System.Exit.exitWith (System.Exit.ExitFailure x)
        _ -> System.Exit.exitWith (System.Exit.ExitFailure 1)

data ChangeStatus = Changes | NoChanges
  deriving (Eq)

-- | The main IO parts for the default mode of operation, and after commandline
-- and config stuff is processed.
coreIO
  :: (String -> IO ()) -- ^ error output function. In parallel operation, you
                       -- may want serialize the different outputs and
                       -- consequently not directly print to stderr.
  -> Config -- ^ global program config.
  -> Bool   -- ^ whether to supress output (to stdout). Purely IO flag, so
            -- currently not part of program config.
  -> Bool   -- ^ whether we are (just) in check mode.
  -> Maybe FilePath.FilePath -- ^ input filepath; stdin if Nothing.
  -> Maybe FilePath.FilePath -- ^ output filepath; stdout if Nothing.
  -> IO (Either Int ChangeStatus)      -- ^ Either an errorNo, or the change status.
coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
  ExceptT.runExceptT $ do
    let putErrorLn = liftIO . putErrorLnIO :: String -> ExceptT.ExceptT e IO ()

    inputVal <- case inputPathM of
      Nothing -> do
        inputString <- liftIO System.IO.getContents
        pure $ Right inputString
      Just p -> pure $ Left p
    let
      printErrorsAndWarnings errsWarns = do
        let
          customErrOrder ErrorInput{} = 4
          customErrOrder LayoutWarning{} = -1 :: Int
          customErrOrder ErrorOutputCheck{} = 1
          customErrOrder ErrorUnusedComment{} = 2
          customErrOrder ErrorUnusedComments{} = 3
          customErrOrder ErrorUnknownNode{} = -2 :: Int
          customErrOrder ErrorMacroConfig{} = 5
        unless (null errsWarns) $ do
          let
            groupedErrsWarns =
              Data.List.Extra.groupOn customErrOrder
                $ List.sortOn customErrOrder
                $ errsWarns
          groupedErrsWarns `forM_` \case
            (ErrorOutputCheck{} : _) -> do
              putErrorLn
                $ "ERROR: brittany pretty printer"
                ++ " returned syntactically invalid result."
            (ErrorInput str : _) -> do
              putErrorLn $ "ERROR: parse error: " ++ str
            uns@(ErrorUnknownNode{} : _) -> do
              putErrorLn
                $ "WARNING: encountered unknown syntactical constructs:"
              uns `forM_` \case
                ErrorUnknownNode str ast@(L loc _) -> do
                  putErrorLn $ "  " <> str <> " at " <> showSDocUnsafe (ppr loc)
                  when
                      (config
                      & _conf_debug
                      & _dconf_dump_ast_unknown
                      & confUnpack
                      )
                    $ do
                        putErrorLn $ "  " ++ show (astToDoc ast)
                _ -> error "cannot happen (TM)"
              putErrorLn
                "  -> falling back on exactprint for this element of the module"
            warns@(LayoutWarning{} : _) -> do
              putErrorLn $ "WARNINGS:"
              warns `forM_` \case
                LayoutWarning str -> putErrorLn str
                _ -> error "cannot happen (TM)"
            unused@(ErrorUnusedComment{} : _) -> do
              putErrorLn
                $ "Error: detected unprocessed comments."
                ++ " The transformation output will most likely"
                ++ " not contain some of the comments"
                ++ " present in the input haskell source file."
              putErrorLn $ "Affected are the following comments:"
              unused `forM_` \case
                ErrorUnusedComment str -> putErrorLn str
                _ -> error "cannot happen (TM)"
            unused@(ErrorUnusedComments{} : _) -> do
              unused `forM_` \case
                ErrorUnusedComments (L (GHC.SrcSpanAnn _ ann) _) cIn cOut -> do
                  putErrorLn
                    $ "Error: detected unprocessed comments ("
                    ++ show cOut ++ " out of " ++ show cIn ++ ")."
                    ++ " The transformation output will most likely"
                    ++ " not contain some of the comments"
                    ++ " present in the input haskell source file."
                  putErrorLn $ "Affected is the declaration at " ++ show (astToDoc ann)
                _ -> error "cannot happen (TM)"
            (ErrorMacroConfig err input : _) -> do
              putErrorLn $ "Error: parse error in inline configuration:"
              putErrorLn err
              putErrorLn $ "  in the string \"" ++ input ++ "\"."
            [] -> error "cannot happen"
    parseResult <- liftIO $ parsePrintModuleCommon
      (TraceFunc putErrorLnIO)
      config
      inputVal
      ( putErrorLnIO
        $ "Warning: Encountered -XCPP."
        ++ " Be warned that -XCPP is not supported and that"
        ++ " brittany cannot check that its output is syntactically"
        ++ " valid in its presence."
      )

    case parseResult of
      Left errWarns@[ErrorInput{}] -> do
        printErrorsAndWarnings errWarns
        ExceptT.throwE 60
      Left errWarns@(ErrorMacroConfig{}: _) -> do
        printErrorsAndWarnings errWarns
        ExceptT.throwE 61
      Left errWarns -> do
        printErrorsAndWarnings errWarns
        ExceptT.throwE 70
      Right (errsWarns, outSText, hasChangesAct) -> do
        printErrorsAndWarnings errsWarns

        hasChanges <- liftIO $ hasChangesAct

        -- TODO: don't output anything when there are errors unless user
        -- adds some override?
        let shouldOutput = not suppressOutput && not checkMode
        when shouldOutput
          $ addTraceSep (_conf_debug config)
          $ case outputPathM of
              Nothing -> liftIO $ Text.IO.putStr $ outSText
              Just p -> liftIO $ do
                let
                  shouldWrite = case inputPathM of
                    Nothing -> True
                    Just p2 -> hasChanges || p /= p2
                when shouldWrite $ Text.IO.writeFile p $ outSText

        when (checkMode && hasChanges) $ case inputPathM of
          Nothing -> pure ()
          Just p -> liftIO $ putStrLn $ "formatting would modify: " ++ p

        return (if hasChanges then Changes else NoChanges)
 where
  addTraceSep conf =
    if or
        [ confUnpack $ _dconf_dump_annotations conf
        , confUnpack $ _dconf_dump_ast_unknown conf
        , confUnpack $ _dconf_dump_ast_full conf
        , confUnpack $ _dconf_dump_bridoc_raw conf
        , confUnpack $ _dconf_dump_bridoc_simpl_alt conf
        , confUnpack $ _dconf_dump_bridoc_simpl_floating conf
        , confUnpack $ _dconf_dump_bridoc_simpl_columns conf
        , confUnpack $ _dconf_dump_bridoc_simpl_indent conf
        , confUnpack $ _dconf_dump_bridoc_final conf
        ]
      then trace "----"
      else id
