{-# 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
  , applyCPPTransformIfEnabledPre
  , applyCPPTransformIfEnabledPost
  , parsePrintModuleCommon
  )
where

import           Control.Monad.Trans.Except
import           DataTreePrint                  ( printTreeWithCustom )
import           Data.CZipWith
import qualified Data.Text                     as Text
import qualified Data.Text.Lazy                as TextL
import qualified Data.Text.IO                  as Text.IO
import qualified GHC.Driver.Session            as GHC
import           GHC.Hs
import qualified GHC.LanguageExtensions.Type   as GHC
import qualified Language.Haskell.GHC.ExactPrint
                                               as ExactPrint
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.ToBriDocTools
import           Language.Haskell.Brittany.Internal.Prelude
import qualified Language.Haskell.Brittany.Internal.ParseExact
                                               as Parsing
import qualified Language.Haskell.Brittany.Internal.SplitExactModule
                                               as Splitting
import           Language.Haskell.Brittany.Internal.Components.Obfuscation
                                                ( obfuscate )
import           Language.Haskell.Brittany.Internal.PerModule
                                                ( processModule )
import           Language.Haskell.Brittany.Internal.Types
import           Language.Haskell.Brittany.Internal.Utils
import Language.Haskell.Brittany.Internal.Config.Types.Instances1 ()



applyCPPTransformIfEnabledPre :: Config -> String -> String
applyCPPTransformIfEnabledPre config =
  if hackAroundIncludes && not exactprintOnly
    then List.intercalate "\n" . fmap hackF . lines'
    else id
 where
  -- the flag will do the following: insert a marker string
  -- ("-- BRITANY_INCLUDE_HACK ") right before any lines starting with
  -- "#include" before processing (parsing) input; and remove that marker
  -- string from the transformation output.
  -- The flag is intentionally misspelled to prevent clashing with
  -- inline-config stuff.
  hackAroundIncludes =
    config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack
  exactprintOnly = viaGlobal || viaDebug
   where
    viaGlobal = config & _conf_roundtrip_exactprint_only & confUnpack
    viaDebug =
      config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack
  hackF s = if "#include" `isPrefixOf` s
    then "-- BRITANY_INCLUDE_HACK " ++ s
    else s

applyCPPTransformIfEnabledPost :: Config -> TextL.Text -> TextL.Text
applyCPPTransformIfEnabledPost config =
  if hackAroundIncludes && not exactprintOnly
    then
      TextL.intercalate (TextL.pack "\n")
      . map hackF
      . TextL.splitOn (TextL.pack "\n")
    else id
 where
  hackAroundIncludes =
    config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack
  exactprintOnly = viaGlobal || viaDebug
   where
    viaGlobal = config & _conf_roundtrip_exactprint_only & confUnpack
    viaDebug =
      config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack
  hackF s = fromMaybe s
    $ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s

parsePrintModuleCommon
  :: TraceFunc
  -> Config
  -> Either FilePath String
  -> IO ()
  -> IO (Either [BrittanyError] ([BrittanyError], Text, IO Bool))
parsePrintModuleCommon traceFunc config inputE cppWarnAction = runExceptT $ do
  let ghcOptions = config & _conf_forward & _options_ghc & runIdentity
  let cppMode    = config & _conf_preprocessor & _ppconf_CPPMode & confUnpack
  let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags
        then case cppMode of
          CPPModeAbort  -> pure $ Left "Encountered -XCPP. Aborting."
          CPPModeWarn   -> cppWarnAction $> Right True
          CPPModeNowarn -> pure $ Right True
        else pure $ Right False
  (parseResult, originalContentAct) <- case inputE of
    Left p -> liftIO $ do
      parseRes <- Parsing.parseModule ghcOptions p cppCheckFunc
      pure (parseRes, Text.IO.readFile p)
      -- The above means we read the file twice, but the
      -- GHC API does not really expose the source it
      -- read. Should be in cache still anyways.
      --
      -- We do not use TextL.IO.readFile because lazy IO is evil.
      -- (not identical -> read is not finished ->
      -- handle still open -> write below crashes - evil.)
    Right inputString -> do
      parseRes <- liftIO
        $ Parsing.parseModuleFromString
          ghcOptions
          "stdin"
          cppCheckFunc
          (applyCPPTransformIfEnabledPre config inputString)
      pure (parseRes, pure $ Text.pack inputString)
  (parsedSource, hasCPP) <- case parseResult of
    Left  err -> throwE [ErrorInput err]
    Right x   -> pure x
  when (config & _conf_debug & _dconf_dump_ast_full & confUnpack) $ do
    let val = printTreeWithCustom 160 customLayouterF parsedSource
    liftIO $ useTraceFunc traceFunc ("---- ast ----\n" ++ show val)
  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
  let exactprintOnly = viaGlobal || viaDebug
       where
        viaGlobal = config & _conf_roundtrip_exactprint_only & confUnpack
        viaDebug =
          config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack
  let omitCheck =
        moduleConfig
          & _conf_errorHandling
          & _econf_omit_output_valid_check
          & confUnpack
  if
    | disableFormatting -> do
      originalContents <- liftIO $ originalContentAct
      pure ([], originalContents, pure False)
    | exactprintOnly -> do
      let r = Text.pack $ ExactPrint.exactPrint parsedSource
      pure
        ( []
        , r
        , do
            originalContents <- originalContentAct
            pure $ originalContents /= r
        )
    | otherwise -> do
      let
        applyObfuscateIfEnabled =
          if moduleConfig & _conf_obfuscate & confUnpack
            then lift . obfuscate
            else pure
      (errsWarns, outRaw) <- if hasCPP || omitCheck
        then lift
          $ processModule traceFunc moduleConfig perItemConf moduleElementList
        else lift
          $ pPrintModuleAndCheck traceFunc
                                 moduleConfig
                                 perItemConf
                                 moduleElementList
      outputText <- applyObfuscateIfEnabled
        (TextL.toStrict $ applyCPPTransformIfEnabledPost config outRaw)
      let
        hasErrors = \case
          ErrorInput{} -> True
          LayoutWarning{} ->
            moduleConfig & _conf_errorHandling & _econf_Werror & confUnpack
          ErrorOutputCheck{}    -> True
          ErrorUnusedComment{}  -> True
          ErrorUnusedComments{} -> True
          ErrorUnknownNode{}    -> True
          ErrorMacroConfig{}    -> True
        outputOnErrs =
          config
            & _conf_errorHandling
            & _econf_produceOutputOnErrors
            & confUnpack
      if any hasErrors errsWarns && not outputOnErrs
        then throwE $ errsWarns
        else pure
          $ ( errsWarns
            , outputText
            , do
                originalContents <- liftIO $ originalContentAct
                pure $ originalContents /= outputText
            )

  -- pure $ _ (parsed, hasCPP, originalContentAct)

-- | 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 }
  (_errsWarns, output, _) <- ExceptT $ liftIO $ parsePrintModuleCommon
    traceFunc
    config
    (Right $ Text.unpack inputText)
    (pure ())
  pure output


-- | 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"