{-# LANGUAGE NoImplicitPrelude #-}

module Language.Haskell.Brittany.Internal
  ( Parsing.parseModule
  , Parsing.parseModuleFromString
  , parsePrintModule
  , parsePrintModuleTests
  , processModule
  , pPrintModuleAndCheck
   -- re-export from utils:
  , extractCommentConfigs
  , TraceFunc(TraceFunc)
  , Splitting.splitModuleDecls
  , Splitting.extractDeclMap
  )
where

import           Control.Monad.Trans.Except
import           Data.CZipWith
import qualified Data.Text                     as Text
import qualified Data.Text.Lazy                as TextL
import qualified GHC.Driver.Session            as GHC
import           GHC.Hs
import qualified GHC.LanguageExtensions.Type   as GHC
import qualified GHC.OldList                   as List
import           Language.Haskell.Brittany.Internal.Config.Config
import           Language.Haskell.Brittany.Internal.Config.InlineParsing
import           Language.Haskell.Brittany.Internal.Config.Types
import           Language.Haskell.Brittany.Internal.S3_ToBriDocTools
import           Language.Haskell.Brittany.Internal.Prelude
import qualified Language.Haskell.Brittany.Internal.S1_Parsing
                                               as Parsing
import qualified Language.Haskell.Brittany.Internal.S2_SplitModule
                                               as Splitting
import           Language.Haskell.Brittany.Internal.StepOrchestrate
                                                ( processModule )
import           Language.Haskell.Brittany.Internal.Types
import           Language.Haskell.Brittany.Internal.Utils
import Language.Haskell.Brittany.Internal.Config.Types.Instances1 ()



-- | Exposes the transformation in an pseudo-pure fashion. The signature
-- contains `IO` due to the GHC API not exposing a pure parsing function, but
-- there should be no observable effects.
--
-- Note that this function ignores/resets all config values regarding
-- debugging, i.e. it will never use `trace`/write to stderr.
--
-- Note that the ghc parsing function used internally currently is wrapped in
-- `mask_`, so cannot be killed easily. If you don't control the input, you
-- may wish to put some proper upper bound on the input's size as a timeout
-- won't do.
parsePrintModule
  :: TraceFunc -> Config -> Text -> IO (Either [BrittanyError] Text)
parsePrintModule traceFunc configWithDebugs inputText = runExceptT $ do
  let config =
        configWithDebugs { _conf_debug = _conf_debug staticDefaultConfig }
  let ghcOptions = config & _conf_forward & _options_ghc & runIdentity
  let config_pp  = config & _conf_preprocessor
  let cppMode    = config_pp & _ppconf_CPPMode & confUnpack
  let hackAroundIncludes =
        config_pp & _ppconf_hackAroundIncludes & confUnpack
  (parsedSource, hasCPP) <- do
    let hackF s = if "#include" `isPrefixOf` s
          then "-- BRITANY_INCLUDE_HACK " ++ s
          else s
    let hackTransform = if hackAroundIncludes
          then List.intercalate "\n" . fmap hackF . lines'
          else id
    let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags
          then case cppMode of
            CPPModeAbort  -> return $ Left "Encountered -XCPP. Aborting."
            CPPModeWarn   -> return $ Right True
            CPPModeNowarn -> return $ Right True
          else return $ Right False
    parseResult <- lift $ Parsing.parseModuleFromString
      ghcOptions
      "stdin"
      cppCheckFunc
      (hackTransform $ Text.unpack inputText)
    case parseResult of
      Left  err -> throwE [ErrorInput err]
      Right x   -> pure x
  let moduleElementList = Splitting.splitModuleDecls parsedSource
  (inlineConf, perItemConf) <-
    mapExceptT (fmap $ bimap (\(a, b) -> [ErrorMacroConfig a b]) id)
      $ extractCommentConfigs
        (useTraceFunc traceFunc)
        (Splitting.extractDeclMap parsedSource)
        moduleElementList
  let moduleConfig = cZipWith fromOptionIdentity config inlineConf
  let disableFormatting =
        moduleConfig & _conf_disable_formatting & confUnpack
  if disableFormatting
    then do
      return inputText
    else do
      (errsWarns, outputTextL) <- do
        let omitCheck =
              moduleConfig
                & _conf_errorHandling
                & _econf_omit_output_valid_check
                & confUnpack
        (ews, outRaw) <- if hasCPP || omitCheck
          then lift
            $ processModule traceFunc moduleConfig perItemConf moduleElementList
          else lift $ pPrintModuleAndCheck traceFunc
                                           moduleConfig
                                           perItemConf
                                           moduleElementList
        let hackF s = fromMaybe s
              $ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s
        pure $ if hackAroundIncludes
          then
            ( ews
            , TextL.intercalate (TextL.pack "\n")
            $   hackF
            <$> TextL.splitOn (TextL.pack "\n") outRaw
            )
          else (ews, outRaw)
      let customErrOrder ErrorInput{}          = 5
          customErrOrder LayoutWarning{}       = 0 :: Int
          customErrOrder ErrorOutputCheck{}    = 1
          customErrOrder ErrorUnusedComment{}  = 2
          customErrOrder ErrorUnusedComments{} = 3
          customErrOrder ErrorUnknownNode{}    = 4
          customErrOrder ErrorMacroConfig{}    = 6
      let hasErrors =
            if moduleConfig & _conf_errorHandling & _econf_Werror & confUnpack
              then not $ null errsWarns
              else 0 < maximum (-1 : fmap customErrOrder errsWarns)
      if hasErrors
        then throwE $ errsWarns
        else pure $ TextL.toStrict outputTextL



-- | Additionally checks that the output compiles again, appending an error
-- if it does not.
pPrintModuleAndCheck
  :: TraceFunc
  -> Config
  -> PerItemConfig
  -> FinalList ModuleElement p
  -> IO ([BrittanyError], TextL.Text)
pPrintModuleAndCheck traceFunc conf inlineConf moduleElementList = do
  let ghcOptions     = conf & _conf_forward & _options_ghc & runIdentity
  (errs, output) <- processModule traceFunc conf inlineConf moduleElementList
  parseResult <- Parsing.parseModuleFromString ghcOptions
                                               "output"
                                               (\_ -> return $ Right ())
                                               (TextL.unpack output)
  let errs' = errs ++ case parseResult of
        Left x  -> [ErrorOutputCheck x]
        Right{} -> []
  return (errs', output)


-- used for testing mostly, currently.
-- TODO: use parsePrintModule instead and remove this function.
parsePrintModuleTests :: Config -> String -> Text -> IO (Either String Text)
parsePrintModuleTests conf filename input = do
  let inputStr = Text.unpack input
  parseResult <- Parsing.parseModuleFromString
    (conf & _conf_forward & _options_ghc & runIdentity)
    filename
    (const . pure $ Right ())
    inputStr
  case parseResult of
    Left  err               -> return $ Left err
    Right (parsedModule, _) -> runExceptT $ do
      let moduleElementList = Splitting.splitModuleDecls parsedModule
      (inlineConf, perItemConf) <-
        mapExceptT
          (fmap (bimap (\(a, _) -> "when parsing inline config: " ++ a) id))
          $ extractCommentConfigs
            (\_ -> pure ())
            (Splitting.extractDeclMap parsedModule)
            moduleElementList
      let moduleConf = cZipWith fromOptionIdentity conf inlineConf
      let omitCheck =
            conf
              &  _conf_errorHandling
              .> _econf_omit_output_valid_check
              .> confUnpack
      (errs, ltext) <- if omitCheck
        then lift $ processModule (TraceFunc $ \_ -> pure ())
                                   moduleConf
                                   perItemConf
                                   moduleElementList
        else lift $ pPrintModuleAndCheck (TraceFunc $ \_ -> pure ())
                                         moduleConf
                                         perItemConf
                                         moduleElementList
      if null errs
        then pure $ TextL.toStrict $ ltext
        else throwE
          $  "pretty printing error(s):\n"
          ++ List.unlines (errorToString <$> errs)
 where
  errorToString :: BrittanyError -> String
  errorToString = \case
    ErrorInput         str    -> str
    ErrorUnusedComment _      -> "ErrorUnusedComment"
    ErrorUnusedComments _ _ _ -> "ErrorUnusedComments"
    LayoutWarning str         -> str
    ErrorUnknownNode str _    -> str
    ErrorMacroConfig str _    -> "when parsing inline config: " ++ str
    ErrorOutputCheck str      -> "Output is not syntactically valid: " ++ str
-- this approach would for if there was a pure GHC.parseDynamicFilePragma.
-- Unfortunately that does not exist yet, so we cannot provide a nominally
-- pure interface.

-- parsePrintModuleTests :: Text -> Either String Text
-- parsePrintModuleTests input = do
--   let dflags = GHC.unsafeGlobalDynFlags
--   let fakeFileName = "SomeTestFakeFileName.hs"
--   let pragmaInfo = GHC.getOptions
--         dflags
--         (GHC.stringToStringBuffer $ Text.unpack input)
--         fakeFileName
--   (dflags1, _, _) <- GHC.parseDynamicFilePragma dflags pragmaInfo
--   let parseResult = ExactPrint.Parsers.parseWith
--         dflags1
--         fakeFileName
--         GHC.parseModule
--         inputStr
--   case parseResult of
--     Left (_, s) -> Left $ "parsing error: " ++ s
--     Right (anns, parsedModule) -> do
--       let (out, errs) = runIdentity
--                       $ runMultiRWSTNil
--                       $ Control.Monad.Trans.MultiRWS.Lazy.withMultiWriterAW
--                       $ Control.Monad.Trans.MultiRWS.Lazy.withMultiWriterW
--                       $ Control.Monad.Trans.MultiRWS.Lazy.withMultiReader anns
--                       $ ppModule parsedModule
--       if (not $ null errs)
--         then do
--           let errStrs = errs <&> \case
--                 ErrorUnusedComment str -> str
--           Left $ "pretty printing error(s):\n" ++ List.unlines errStrs
--         else return $ TextL.toStrict $ Text.Builder.toLazyText out



_sigHead :: Sig GhcPs -> String
_sigHead = \case
  TypeSig _ names _ ->
    "TypeSig " ++ intercalate "," (Text.unpack . lrdrNameToText <$> names)
  _ -> "unknown sig"

_bindHead :: HsBind GhcPs -> String
_bindHead = \case
  FunBind _ fId _ [] -> "FunBind " ++ (Text.unpack $ lrdrNameToText $ fId)
  PatBind _ _pat _ ([], []) -> "PatBind smth"
  _                         -> "unknown bind"