{-# LANGUAGE NoImplicitPrelude #-}

module Language.Haskell.Brittany.Internal.S4_WriteBriDoc
  ( ppBriDoc
  )
where

import           Language.Haskell.Brittany.Internal.Prelude

import qualified Control.Monad.Trans.MultiRWS.Strict
                                               as MultiRWSS
import qualified Data.Text                     as Text
import qualified Data.Text.Lazy.Builder        as TextL.Builder
import           GHC                            ( Anchor(Anchor)
                                                , AnchorOperation
                                                  ( MovedAnchor
                                                  , UnchangedAnchor
                                                  )
                                                , EpaComment(EpaComment)
                                                , EpaCommentTok
                                                  ( EpaBlockComment
                                                  , EpaDocCommentNamed
                                                  , EpaDocCommentNext
                                                  , EpaDocCommentPrev
                                                  , EpaDocOptions
                                                  , EpaDocSection
                                                  , EpaEofComment
                                                  , EpaLineComment
                                                  )
                                                , GenLocated(L)
                                                , LEpaComment
                                                , RealSrcLoc
                                                , DeltaPos(SameLine, DifferentLine)
                                                )
import           GHC.Types.SrcLoc               ( realSrcSpanEnd )
import qualified GHC.OldList                   as List

import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint

import           Language.Haskell.Brittany.Internal.Config.Types
import           Language.Haskell.Brittany.Internal.Transformations.T1_Alt
import           Language.Haskell.Brittany.Internal.Transformations.T2_Floating
import           Language.Haskell.Brittany.Internal.Transformations.T3_Par
import           Language.Haskell.Brittany.Internal.Transformations.T4_Columns
import           Language.Haskell.Brittany.Internal.Transformations.T5_Indent
import           Language.Haskell.Brittany.Internal.Types
import           Language.Haskell.Brittany.Internal.Utils
import           Language.Haskell.Brittany.Internal.WriteBriDoc.AlignmentAlgo
import           Language.Haskell.Brittany.Internal.WriteBriDoc.Types
import           Language.Haskell.Brittany.Internal.WriteBriDoc.Operators
import Language.Haskell.Brittany.Internal.Components.BriDoc
-- import Language.Haskell.Brittany.Internal.S3_ToBriDocTools


ppBriDoc :: BriDocNumbered -> PPMLocal ()
ppBriDoc briDoc = do
  -- first step: transform the briDoc.
  briDoc' <- MultiRWSS.withMultiStateS BDEmpty $ do
    -- Note that briDoc is BriDocNumbered, but state type is BriDoc.
    -- That's why the alt-transform looks a bit special here.
    traceIfDumpConf "bridoc raw" _dconf_dump_bridoc_raw
      $ briDocToDoc
      $ unwrapBriDocNumbered
      $ briDoc
    -- bridoc transformation: remove alts
    transformAlts briDoc >>= mSet
    mGet
      >>= briDocToDoc
      .>  traceIfDumpConf "bridoc post-alt" _dconf_dump_bridoc_simpl_alt
    -- bridoc transformation: float stuff in
    mGet >>= transformSimplifyFloating .> mSet
    mGet
      >>= briDocToDoc
      .>  traceIfDumpConf "bridoc post-floating"
                          _dconf_dump_bridoc_simpl_floating
    -- bridoc transformation: par removal
    mGet >>= transformSimplifyPar .> mSet
    mGet
      >>= briDocToDoc
      .>  traceIfDumpConf "bridoc post-par" _dconf_dump_bridoc_simpl_par
    -- bridoc transformation: float stuff in
    mGet >>= transformSimplifyColumns .> mSet
    mGet
      >>= briDocToDoc
      .>  traceIfDumpConf "bridoc post-columns" _dconf_dump_bridoc_simpl_columns
    -- bridoc transformation: indent
    mGet >>= transformSimplifyIndent .> mSet
    mGet
      >>= briDocToDoc
      .>  traceIfDumpConf "bridoc post-indent" _dconf_dump_bridoc_simpl_indent
    mGet
      >>= briDocToDoc
      .>  traceIfDumpConf "bridoc final" _dconf_dump_bridoc_final
    -- -- convert to Simple type
    -- simpl <- mGet <&> transformToSimple
    -- return simpl

  let state = LayoutState { _lstate_baseYs           = [0]
                          , _lstate_curY             = 0
                          , _lstate_indLevels        = [0]
                          , _lstate_indLevelLinger   = 0
                          , _lstate_plannedSpace = PlannedNone
                          , _lstate_commentNewlines  = 0
                          }
  state' <-
    MultiRWSS.withMultiStateS state
    $ MultiRWSS.withMultiStateS ([] :: [LEpaComment])
    $ do
      layoutBriDocM briDoc'
  case _lstate_plannedSpace state' of
    PlannedNone -> if _lstate_curY state' == 0
      then pure ()
      else mTell $ TextL.Builder.fromString "\n"
    PlannedSameline _ -> if _lstate_curY state' == 0
      then pure ()
      else mTell $ TextL.Builder.fromString "\n"
    PlannedNewline l -> mTell $ TextL.Builder.fromString (replicate l '\n')
    PlannedDelta l _ -> mTell $ TextL.Builder.fromString (replicate l '\n')


layoutBriDocM :: HasCallStack => forall m . LayoutConstraints m => BriDoc -> m ()
layoutBriDocM = \case
  BDEmpty -> do
    return () -- can it be that simple
  BDLit t -> do
    layoutRemoveIndentLevelLinger
    layoutWriteAppend t
  BDSeq list -> do
    list `forM_` layoutBriDocM
  -- in this situation, there is nothing to do about cols.
  -- i think this one does not happen anymore with the current simplifications.
  -- BDCols cSig list | BDPar sameLine lines <- List.last list ->
  --   alignColsPar $ BDCols cSig (List.init list ++ [sameLine]) : lines
  BDCols _ list -> do
    list `forM_` layoutBriDocM
  BDSeparator -> do
    layoutAddSepSpace
  BDAddBaseY indent bd -> do
    let indentF = case indent of
          BrIndentNone      -> id
          BrIndentRegular   -> layoutWithAddBaseCol
          BrIndentSpecial i -> layoutWithAddBaseColN i
    indentF $ layoutBriDocM bd
  BDBaseYPushCur bd -> do
    layoutBaseYPushCur
    layoutBriDocM bd
    layoutBaseYPop
  BDIndentLevelPushCur bd -> do
    layoutIndentLevelPushCur
    layoutBriDocM bd
  BDIndentLevelPop bd -> do
    layoutBriDocM bd
    layoutIndentLevelPop
  BDEnsureIndent indent bd -> do
    let indentF = case indent of
          BrIndentNone      -> id
          BrIndentRegular   -> layoutWithAddBaseCol
          BrIndentSpecial i -> layoutWithAddBaseColN i
    indentF $ do
      layoutWriteEnsureBlock
      layoutBriDocM bd
  BDPar indent sameLine indented -> do
    layoutBriDocM sameLine
    let indentF = case indent of
          BrIndentNone      -> id
          BrIndentRegular   -> layoutWithAddBaseCol
          BrIndentSpecial i -> layoutWithAddBaseColN i
    indentF $ do
      layoutWriteNewline
      layoutBriDocM indented
  BDEntryDelta dp bd -> do
    case dp of
      GHC.SameLine _ -> pure ()
      GHC.DifferentLine l _i -> mModify $ \s -> s {
        _lstate_plannedSpace = PlannedNewline l
      }
    layoutBriDocM bd
  BDLines           lines       -> alignColsLines layoutBriDocM lines
  BDAlt             []          -> error "empty BDAlt"
  BDAlt             (alt : _)   -> layoutBriDocM alt
  BDForceMultiline  bd          -> layoutBriDocM bd
  BDForceSingleline bd          -> layoutBriDocM bd
  BDForwardLineMode bd          -> layoutBriDocM bd
  BDExternal shouldAddComment t -> do
    let tlines     = Text.lines $ t <> Text.pack "\n"
        tlineCount = length tlines
    when shouldAddComment $ do
      layoutWriteAppend $ Text.pack $ "{- via external! -}"
    zip [1 ..] tlines `forM_` \(i, l) -> do
      layoutWriteAppend $ l
      unless (i == tlineCount) layoutWriteNewline
  BDPlain t -> do
    layoutWriteAppend t
  -- BDAnnotationPrior comms bd -> do
  --   -- state <- mGet
  --   -- let m = _lstate_comments state
  --   -- let
  --   --   moveToExactLocationAction = case _lstate_curYOrAddNewline state of
  --   --     Left{} -> pure ()
  --   --     Right{} -> moveToExactAnn annKey
  --   -- case mAnn of
  --   --   Nothing -> moveToExactLocationAction
  --   --   Just [] -> moveToExactLocationAction
  --   --   Just priors -> do
  --   --     -- layoutResetSepSpace
  --   --     priors
  --   --       `forM_` \(ExactPrint.Types.Comment comment _ _, DifferentLine (y, x)) ->
  --   --                 when (comment /= "(" && comment /= ")") $ do
  --   --                   let commentLines = Text.lines $ Text.pack $ comment
  --   --                   case comment of
  --   --                     ('#' : _) ->
  --   --                       layoutMoveToCommentPos y (-999) (length commentLines)
  --   --                                --  ^ evil hack for CPP
  --   --                     _ -> layoutMoveToCommentPos y x (length commentLines)
  --   --                   -- fixedX <- fixMoveToLineByIsNewline x
  --   --                   -- replicateM_ fixedX layoutWriteNewline
  --   --                   -- layoutMoveToIndentCol y
  --   --                   layoutWriteAppendMultiline commentLines
  --   --       -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }
  --   --     moveToExactLocationAction
  --   printComments comms
  --   mModify (\s -> s + CommentCounter (length comms))
  --   layoutBriDocM bd
  -- BDAnnotationPost comms bd -> do
  --   layoutBriDocM bd
  --   printComments comms
  --   mModify (\s -> s + CommentCounter (length comms))
    -- annMay <- do
    --   state <- mGet
    --   let m = _lstate_comments state
    --   pure $ Map.lookup annKey m
    -- let mComments = nonEmpty . extractAllComments =<< annMay
    -- -- let
    -- --   semiCount = length
    -- --     [ ()
    -- --     | Just ann <- [annMay]
    -- --     , (ExactPrint.Types.AnnSemiSep, _) <- ExactPrint.Types.annsDP ann
    -- --     ]
    -- shouldAddSemicolonNewlines <-
    --   mAsk
    --   <&> _conf_layout
    --   .> _lconfig_experimentalSemicolonNewlines
    --   .> confUnpack
    -- case mComments of
    --   Nothing -> do
    --     when shouldAddSemicolonNewlines $ do
    --       [1 .. semiCount] `forM_` const layoutWriteNewline
    --   Just comments -> do
    --     comments
    --       `forM_` \(ExactPrint.Types.Comment comment _ _, DifferentLine (y, x)) ->
    --                 when (comment /= "(" && comment /= ")") $ do
    --                   let commentLines = Text.lines $ Text.pack comment
    --                   case comment of
    --                     ('#' : _) -> layoutMoveToCommentPos y (-999) 1
    --                                --  ^ evil hack for CPP
    --                     ")" -> pure ()
    --                                --  ^ fixes the formatting of parens
    --                                --    on the lhs of type alias defs
    --                     _ -> layoutMoveToCommentPos y x (length commentLines)
    --                   -- fixedX <- fixMoveToLineByIsNewline x
    --                   -- replicateM_ fixedX layoutWriteNewline
    --                   -- layoutMoveToIndentCol y
    --                   layoutWriteAppendMultiline commentLines
    --   -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }
  BDQueueComments comms bd -> do
    existing :: [GHC.LEpaComment] <- mGet
    mSet $ mergeOn (\(L l _) -> l) existing comms
    layoutBriDocM bd
  BDFlushCommentsPrior loc bd -> do
    comms <- takeBefore loc
    printComments comms
    mModify (\s -> s + CommentCounter (length comms))
    layoutBriDocM bd
  BDFlushCommentsPost loc bd -> do
    layoutBriDocM bd
    comms <- takeBefore loc
    mModify (\s -> s + CommentCounter (length comms))
    printComments comms
  BDNonBottomSpacing _ bd -> layoutBriDocM bd
  BDSetParSpacing   bd    -> layoutBriDocM bd
  BDForceParSpacing bd    -> layoutBriDocM bd
  BDDebug s bd            -> do
    mTell $ TextL.Builder.fromText $ Text.pack $ "{-" ++ s ++ "-}"
    layoutBriDocM bd

mergeOn :: Ord b => (a -> b) -> [a] -> [a] -> [a]
mergeOn _f xs [] = xs
mergeOn _f [] ys = ys
mergeOn f xs@(x:xr) ys@(y:yr)
    | f x <= f y = x : mergeOn f xr ys
    | otherwise = y : mergeOn f xs yr

takeBefore
  :: MonadMultiState [LEpaComment] m => RealSrcLoc -> m [LEpaComment]
takeBefore loc = do
  comms <- mGet
  let (before, after) = List.span
        (\(L (Anchor spanC _) _) -> realSrcSpanEnd spanC <= loc)
        comms
  mSet after
  pure before

printComments :: LayoutConstraints m => [GHC.LEpaComment] -> m ()
printComments comms = do
  let addComment s anchor prior = do
        case anchor of
          Anchor span UnchangedAnchor -> layoutWriteComment
            True
            (ExactPrint.ss2deltaEnd prior span)
            1
            (Text.pack s)
          Anchor _span (MovedAnchor dp) ->
            layoutWriteComment False dp 1 (Text.pack s)
  comms `forM_` \case
    L anch (EpaComment (EpaDocCommentNext s) prior) -> addComment s anch prior
    L anch (EpaComment (EpaDocCommentPrev s) prior) -> addComment s anch prior
    L anch (EpaComment (EpaDocCommentNamed s) prior) -> addComment s anch prior
    L anch (EpaComment (EpaDocSection _ s) prior) -> addComment s anch prior
    L anch (EpaComment (EpaDocOptions s) prior) -> addComment s anch prior
    L anch (EpaComment (EpaLineComment s) prior) -> addComment s anch prior
    L anch (EpaComment (EpaBlockComment s) prior) -> addComment s anch prior
    L _anch (EpaComment (EpaEofComment) _prior) -> pure ()