{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE GADTs #-}

module Language.Haskell.Brittany.Internal.ToBriDoc.Decl where

import qualified Data.Data
import qualified Data.Foldable
import qualified Data.Maybe
import qualified Data.Text as Text
import GHC (GenLocated(L), LexicalFixity(Prefix, Infix), SrcSpan)
import GHC.Data.Bag (bagToList, emptyBag)
import qualified GHC.Data.FastString as FastString
import GHC.Hs
import qualified GHC.OldList as List
import GHC.Types.Basic
  (Activation(..), InlinePragma(..), InlineSpec(..), RuleMatchInfo(..))
import GHC.Types.SrcLoc (Located, getLoc, unLoc)
import qualified GHC
import qualified GHC.Types.SrcLoc as GHC
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.ToBriDocTools
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.Types
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint
import Language.Haskell.Brittany.Internal.Components.BriDoc



layoutDecl :: ToBriDoc HsDecl
layoutDecl d@(L loc decl) = case decl of
  SigD _ sig  -> layoutSig d sig
  ValD _ bind -> layoutBind (L loc bind) >>= \case
    Left  ns -> docLines $ return <$> ns
    Right n  -> return n
  TyClD _ tycl -> layoutTyCl (L loc tycl)
  InstD NoExtField (TyFamInstD NoExtField tfid) ->
    layoutTyFamInstDecl False d tfid
  InstD NoExtField (ClsInstD NoExtField inst) -> layoutClsInst d inst
  _ -> briDocByExactNoComment d

--------------------------------------------------------------------------------
-- Sig
--------------------------------------------------------------------------------

layoutSig :: (Data.Data.Data ast, ExactPrint.ExactPrint ast) => (LocatedA ast) -> ToBriDocP Sig
layoutSig fallback sig = case sig of
  TypeSig epAnn names (HsWC _ sigTy) ->
    layoutNamesAndType epAnn Nothing names sigTy
  InlineSig _ name (InlinePragma _ spec _arity phaseAct conlike) -> do
    nameStr <- lrdrNameToTextAnn name
    specStr <- specStringCompat spec
    let
      phaseStr = case phaseAct of
        NeverActive -> "" -- not [] - for NOINLINE NeverActive is
                               -- in fact the default
        AlwaysActive -> ""
        ActiveBefore _ i -> "[~" ++ show i ++ "] "
        ActiveAfter _ i -> "[" ++ show i ++ "] "
        FinalActive -> error "brittany internal error: FinalActive"
    let
      conlikeStr = case conlike of
        FunLike -> ""
        ConLike -> "CONLIKE "
    docLit
      $ Text.pack ("{-# " ++ specStr ++ conlikeStr ++ phaseStr)
      <> nameStr
      <> Text.pack " #-}"
  ClassOpSig epAnn False names sigTy ->
    layoutNamesAndType epAnn Nothing names sigTy -- TODO92 we ignore an ann here
  PatSynSig epAnn names sigTy -> -- TODO92 we ignore an ann here
    layoutNamesAndType epAnn (Just "pattern") names sigTy
  _ -> briDocByExactNoComment fallback -- TODO
 where
  layoutNamesAndType
    :: EpAnn AnnSig
    -> Maybe String
    -> [LIdP GhcPs]
    -> LHsSigType GhcPs
    -> ToBriDocM BriDocNumbered
  layoutNamesAndType epAnn mKeyword names sigTy = docHandleComms epAnn $ do
    -- TODO92 epAnn might contain interesting bits (the key loc?)
    let
      keyDoc = case mKeyword of
        Just key -> [appSep . docLit $ Text.pack key]
        Nothing -> []
    let (AnnSig addEpAnn _) = anns epAnn
    let posColon = obtainAnnPos addEpAnn AnnDcolon
    nameStrs <- names `forM` lrdrNameToTextAnn
    let nameStr = Text.intercalate (Text.pack ", ") $ nameStrs
    typeDoc <- shareDoc $ callLayouter layout_sigType sigTy
    let hasComments = hasAnyCommentsBelow fallback
    shouldBeHanging <-
      mAsk <&> _conf_layout .> _lconfig_hangingTypeSignature .> confUnpack
    if shouldBeHanging
      then
        docSeq
          $ [ appSep
            $ docSeq
            $ keyDoc
            <> [docLit nameStr]
            , docSetBaseY $ docLines
              [ docCols
                  ColTyOpPrefix
                  [ docHandleComms posColon $ docLit $ Text.pack ":: "
                  , docAddBaseY (BrIndentSpecial 3) $ typeDoc
                  ]
              ]
            ]
      else layoutLhsAndType
        hasComments
        (appSep . docSeq $ keyDoc <> [docLit nameStr])
        (docHandleComms posColon $ docLit $ Text.pack "::")
        2
        (typeDoc)

specStringCompat
  :: MonadMultiWriter [BrittanyError] m => InlineSpec -> m String
specStringCompat = \case
  -- TODO92 better error for this?
  NoUserInlinePrag -> error "NoUserInlinePrag"
  Inline -> pure "INLINE "
  Inlinable -> pure "INLINABLE "
  NoInline -> pure "NOINLINE "

-- layoutGuardLStmt :: ToBriDoc' (StmtLR rdL rdR) -- ToBriDoc' (Stmt GhcPs (LHsExpr GhcPs))
-- layoutGuardLStmt lgstmt@(L _ stmtLR) = case stmtLR of -- TODO92 we had an `docWrapNode lgstmt` here
--                                                       -- but it seems we can't have comments in 92?
--   BodyStmt _ body _ _ -> briDocByExactNoComment body -- TODO92 layoutExpr body
--   BindStmt _ lPat expr -> do
--     patDoc <- docSharedWrapper briDocByExactNoComment lPat -- TODO92 layoutPat
--     expDoc <- docSharedWrapper briDocByExactNoComment expr -- TODO92 layoutExpr
--     docCols
--       ColBindStmt
--       [ appSep $ patDoc -- TODO92 colsWrapPat =<< patDoc
--       , docSeq [appSep $ docLit $ Text.pack "<-", expDoc]
--       ]
--   _ -> unknownNodeError "" lgstmt -- TODO


--------------------------------------------------------------------------------
-- HsBind
--------------------------------------------------------------------------------

layoutBind
  :: ToBriDocC (HsBindLR GhcPs) (Either [BriDocNumbered] BriDocNumbered)
layoutBind lbind@(L _ bind) = case bind of
  FunBind NoExtField fId (MG NoExtField _lmatches@(L _ matches) _) [] -> do
    idStr <- lrdrNameToTextAnn fId
    binderDoc <- docLit $ Text.pack "="
    funcPatDocs <- docHandleComms lbind
      $ matches `forM` layoutPatternBind (Just idStr) binderDoc
    return $ Left $ funcPatDocs
  PatBind _epAnn pat (GRHSs _ grhss whereBinds) ([], []) -> do -- TODO92 are we ignoring something in whereBinds?
    patDocs <- callLayouter layout_colsWrapPat =<< callLayouter layout_pat pat
    mWhereDocs <- layoutLocalBinds whereBinds
    -- let mWhereArg = mWhereDocs <&> (,) (mkAnnKey lbind) -- TODO: is this the right AnnKey?
    binderDoc <- docLit $ Text.pack "="
    let hasComments = hasAnyCommentsBelow lbind
    fmap Right $ docHandleComms lbind $ layoutPatternBindFinal
      Nothing
      binderDoc
      (Just patDocs)
      (Right grhss)
      mWhereDocs
      hasComments
  PatSynBind _ (PSB _ patID lpat rpat dir) -> do
    fmap Right $ docHandleComms lbind $ layoutPatSynBind patID lpat dir rpat
  _ -> Right <$> unknownNodeError "" lbind
layoutIPBind :: ToBriDoc IPBind
layoutIPBind lipbind@(L _ bind) = case bind of
  IPBind _ (Right _) _ -> error "brittany internal error: IPBind Right"
  IPBind _ (Left (L _ (HsIPName name))) expr -> do
    ipName <- docLit $ Text.pack $ '?' : FastString.unpackFS name
    binderDoc <- docLit $ Text.pack "="
    let hasComments = hasAnyCommentsBelow lipbind
    layoutPatternBindFinal
      Nothing
      binderDoc
      (Just ipName)
      (Left expr)
      (id, Nothing)
      hasComments


data BagBindOrSig = BagBind (LHsBindLR GhcPs GhcPs)
                  | BagSig (LSig GhcPs)

bindOrSigtoSrcSpan :: BagBindOrSig -> SrcSpan
bindOrSigtoSrcSpan (BagBind (L (SrcSpanAnn _ l) _)) = l
bindOrSigtoSrcSpan (BagSig (L (SrcSpanAnn _ l) _)) = l

layoutLocalBinds
  :: HsLocalBindsLR GhcPs GhcPs
  -> ToBriDocM
       ( ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
       , Maybe
           ( ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
           , [BriDocNumbered]
           )
       )
layoutLocalBinds binds = case binds of
  -- HsValBinds (ValBindsIn lhsBindsLR []) ->
  --   Just . (>>= either id return) . Data.Foldable.toList <$> mapBagM layoutBind lhsBindsLR -- TODO: fix ordering
  -- x@(HsValBinds (ValBindsIn{})) ->
  --   Just . (:[]) <$> unknownNodeError "HsValBinds (ValBindsIn _ (_:_))" x
  HsValBinds epAnn (ValBinds _ bindlrs sigs) -> do
    let locWhere = obtainAnnPos epAnn AnnWhere
    let unordered =
          [ BagBind b | b <- Data.Foldable.toList bindlrs ]
            ++ [ BagSig s | s <- sigs ]
        ordered = List.sortOn (ExactPrint.rs . bindOrSigtoSrcSpan) unordered
    ds <- join <$> ordered `forM` \case
      BagBind b -> either id return <$> layoutBind b
      BagSig  s@(L _ sig) -> do
        doc <- layoutSig s sig
        pure [doc]
    pure $ (docHandleComms epAnn, Just (docHandleComms locWhere, ds))
--  x@(HsValBinds (ValBindsOut _binds _lsigs)) ->
  HsValBinds _ (XValBindsLR{}) -> error "brittany internal error: XValBindsLR"
  HsIPBinds epAnn (IPBinds _ bb) -> do
    ds <- mapM layoutIPBind bb
    pure $ (docHandleComms epAnn, Just (id, ds)) -- TODO92 do we need to replace id?
  EmptyLocalBinds NoExtField -> return $ (id, Nothing)

layoutGrhs
  :: LGRHS GhcPs (LHsExpr GhcPs)
  -> ToBriDocM
       ( Maybe (EpAnn GrhsAnn)
       , [BriDocNumbered]
       , BriDocNumbered
       )
layoutGrhs (L _ (GRHS epAnn guards body)) = do
  let posArrow = obtainAnnPos epAnn AnnRarrow
  guardDocs <- case guards of
    [] -> pure []
    _  -> docFlushCommsPost False posArrow $ callLayouter layout_stmt `mapM` guards
  let bodyEndPos = case locA $ getLoc body of
        GHC.RealSrcSpan s _ -> Just s
        GHC.UnhelpfulSpan{} -> Nothing
  bodyDoc <- docFlushCommsPost True bodyEndPos $ callLayouter layout_expr body
  return (Just epAnn, guardDocs, bodyDoc)

layoutPatternBind
  :: Maybe Text
  -> BriDocNumbered
  -> LMatch GhcPs (LHsExpr GhcPs)
  -> ToBriDocM BriDocNumbered
layoutPatternBind funId binderDoc lmatch@(L _ match) = do
  let Match epAnn matchCtx pats (GRHSs _ grhss whereBinds) = match
  patDocs <- pats `forM` \p ->
    fmap return $ callLayouter layout_colsWrapPat =<< callLayouter layout_pat p
  let isInfix = isInfixMatch match
  let matchEndLoc = case GHC.locA $ GHC.getLoc lmatch of
        GHC.RealSrcSpan s _ -> Just $ GHC.realSrcSpanEnd s
        GHC.UnhelpfulSpan{} -> Nothing
  mIdDoc <- case matchCtx of
    FunRhs matchId _ _ -> fmap Just $ do
      t <- lrdrNameToTextAnn matchId
      let t' = fixPatternBindIdentifier match t
      docLit t'
    _ -> pure Nothing
  patDoc <- case (mIdDoc, patDocs) of
    (Just idDoc, p1 : p2 : pr) | isInfix -> if null pr
      then docCols
        ColPatternsFuncInfix
        [ appSep $ docForceSingleline p1
        , appSep $ pure idDoc
        , docForceSingleline p2
        ]
      else docCols
        ColPatternsFuncInfix
        ([ docCols
             ColPatterns
             [ docParenL
             , appSep $ docForceSingleline p1
             , appSep $ pure idDoc
             , docForceSingleline p2
             , appSep $ docParenR
             ]
         ]
        ++ (spacifyDocs $ docForceSingleline <$> pr)
        )
    (Just idDoc, []) -> pure idDoc
    (Just idDoc, ps) ->
      docCols ColPatternsFuncPrefix
        $ appSep (pure idDoc)
        : (spacifyDocs $ docForceSingleline <$> ps)
    (Nothing, ps) ->
      docCols ColPatterns
        $ (List.intersperse docSeparator $ docForceSingleline <$> ps)
  mWhereDocs <- layoutLocalBinds whereBinds
  -- let mWhereArg = mWhereDocs <&> (,) (mkAnnKey lmatch)
  let alignmentToken = if null pats then Nothing else funId
  let hasComments = hasAnyCommentsBelow lmatch
  docHandleComms lmatch $ docHandleComms epAnn $ docFlushCommsPost True matchEndLoc
    $ layoutPatternBindFinal
      alignmentToken
      binderDoc
      (Just patDoc)
      (Right grhss)
      mWhereDocs
      hasComments

fixPatternBindIdentifier :: Match GhcPs (LHsExpr GhcPs) -> Text -> Text
fixPatternBindIdentifier match idStr = go $ m_ctxt match
 where
  go = \case
    (FunRhs _ _ SrcLazy) -> Text.cons '~' idStr
    (FunRhs _ _ SrcStrict) -> Text.cons '!' idStr
    (FunRhs _ _ NoSrcStrict) -> idStr
    (StmtCtxt ctx1) -> goInner ctx1
    _ -> idStr
  -- I have really no idea if this path ever occurs, but better safe than
  -- risking another "drop bangpatterns" bugs.
  goInner = \case
    (PatGuard ctx1) -> go ctx1
    (ParStmtCtxt ctx1) -> goInner ctx1
    (TransStmtCtxt ctx1) -> goInner ctx1
    _ -> idStr

layoutPatternBindFinal
  :: Maybe Text
  -> BriDocNumbered
  -> Maybe BriDocNumbered
  -> Either (LHsExpr GhcPs) [LGRHS GhcPs (LHsExpr GhcPs)]
  -> ( ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
     , Maybe
         ( ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
         , [BriDocNumbered]
         )
     )
  -> Bool
  -> ToBriDocM BriDocNumbered
layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauses (wrapBinds, mWhereDocs) hasComments
  = do
    let
      patPartInline = case mPatDoc of
        Nothing -> []
        Just patDoc -> [appSep $ docForceSingleline $ return patDoc]
      patPartParWrap = case mPatDoc of
        Nothing -> id
        Just patDoc -> docPar (return patDoc)
    whereIndent <- do
      shouldSpecial <-
        mAsk <&> _conf_layout .> _lconfig_indentWhereSpecial .> confUnpack
      regularIndentAmount <-
        mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack
      pure $ if shouldSpecial
        then BrIndentSpecial (max 1 (regularIndentAmount `div` 2))
        else BrIndentRegular
    -- TODO: apart from this, there probably are more nodes below which could
    --       be shared between alternatives.
    wherePartMultiLine :: [ToBriDocM BriDocNumbered] <- case mWhereDocs of
      Nothing -> return $ []
      Just (wrapWhere, [w]) -> pure . pure <$> docAlt
        [ docEnsureIndent BrIndentRegular
          $ docSeq
              [ wrapBinds $ wrapWhere $ docLit $ Text.pack "where"
              , docSeparator
              , docForceSingleline $ return w
              ]
        , docEnsureIndent whereIndent
        $ docLines
            [ wrapBinds $ wrapWhere $ docLit $ Text.pack "where"
            , docEnsureIndent whereIndent
            $ docSetIndentLevel
            $ docNonBottomSpacing
            $ return w
            ]
        ]
      Just (wrapWhere, ws) ->
        fmap (pure . pure)
          $ docEnsureIndent whereIndent
          $ docLines
              [ wrapBinds $ wrapWhere $ docLit $ Text.pack "where"
              , docEnsureIndent whereIndent
              $ docSetIndentLevel
              $ docNonBottomSpacing
              $ docLines
              $ return
              <$> ws
              ]
    let
      singleLineGuardsDoc guards = appSep $ case guards of
        [] -> docEmpty
        [g] -> docSeq
          [appSep $ docLit $ Text.pack "|", docForceSingleline $ return g]
        gs ->
          docSeq
            $ [appSep $ docLit $ Text.pack "|"]
            ++ (List.intersperse
                 docCommaSep
                 (docForceSingleline . return <$> gs)
               )
      wherePart = case mWhereDocs of
        Nothing -> Just docEmpty
        Just (wrapWhere, [w]) -> Just $ docSeq
          [ docSeparator
          , wrapBinds $ wrapWhere $ appSep $ docLit $ Text.pack "where"
          , docSetIndentLevel $ docForceSingleline $ return w
          ]
        _ -> Nothing

    indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack

    clauseDocs <- case clauses of
      Left expr -> do
        e <- callLayouter layout_expr expr
        pure [(Nothing, [], e)]
      Right grhss -> layoutGrhs `mapM` grhss

    let multipleClauses = not $ null clauseDocs

    runFilteredAlternative $ do

      case clauseDocs of
        [(grhsEpAnn, guards, body)] -> do
          let grhsHasComms = hasAnyCommentsBelow grhsEpAnn
          let guardPart = docHandleComms grhsEpAnn $ singleLineGuardsDoc guards
          -- func x | null x = x + a + 2 where a = 1
          -- or
          -- func x | null x = x + a + b where
          --   a = 1
          --   b = 2
          forM_ wherePart $ \wherePart' ->
            addAlternativeCond (not hasComments && not grhsHasComms) $ docCols
              (ColBindingLine alignmentToken)
              [ docSeq (patPartInline ++ [guardPart])
              , docSeq
                [ appSep $ return binderDoc
                , docForceSingleline $ return body
                , wherePart'
                ]
              ]

          -- any below have this pattern:
          -- …
          --   where a = 1
          -- or
          -- …
          --  where
          --   a = 1
          --   b = 1

          -- func x | null x = do
          --   stmt x
          addAlternativeCond (not $ maybe False startsWithComments grhsEpAnn)
            $ docLines
            $ [ docCols
                  (ColBindingLine alignmentToken)
                  [ docSeq (patPartInline ++ [guardPart])
                  , docSeq
                    [ appSep $ return binderDoc
                      -- TODO I did it this way just to reduce test breakage,
                      --      but arguably we should modify tests instead.
                      --      I _think_ we really want to drop this alternative
                      --      when grhsHasComms
                    , docForceParSpacing
                    $ docAddBaseY BrIndentRegular
                    $ return body
                    ]
                  ]
              ]
            ++ wherePartMultiLine
          -- func x | null x =
          --   x + a + 2
          addAlternative
            $ docLines
            $ [ docForceSingleline
                $ docSeq (patPartInline ++ [guardPart, return binderDoc])
              , docEnsureIndent BrIndentRegular
              $ docForceSingleline
              $ return body
              ]
            ++ wherePartMultiLine
          -- func x | null x
          --   = do
          --       stmt x
          --       log "abc"
          addAlternative
            $ docLines
            $ [ docCols
                  (ColBindingLine alignmentToken)
                  [ docSeq (patPartInline ++ [guardPart])
                  , docSeq
                    [ appSep $ return binderDoc
                    , docForceParSpacing
                    $ docAddBaseY BrIndentRegular
                    $ return body
                    ]
                  ]
              ]
             -- , lineMod $ docAlt
             --   [ docSetBaseY $ return body
             --   , docAddBaseY BrIndentRegular $ return body
             --   ]
            ++ wherePartMultiLine
          -- func x | null x =
          --   do
          --     stmt1
          --     stmt2 x
          addAlternative
            $ docLines
            $ [ docSeq (patPartInline ++ [guardPart, return binderDoc])
              , docNonBottomSpacing
              $ docEnsureIndent BrIndentRegular
              $ docAddBaseY BrIndentRegular
              $ return body
              ]
            ++ wherePartMultiLine

        _ -> return () -- no alternatives exclusively when `length clauseDocs /= 1`

      case mPatDoc of
        Just patDoc | multipleClauses, indentPolicy == IndentPolicyFree ->
          -- multiple clauses added in-paragraph, each in a single line
          -- func x | null x    = baz
          --        | otherwise = asd
          addAlternative
            $ docLines
            $ [ docSeq
                  [ appSep $ docForceSingleline $ return patDoc
                  , docSetBaseY
                  $ docLines
                  $ clauseDocs
                  <&> \(epAnn, guardDocs, bodyDoc) -> docHandleComms epAnn $ do
                        let guardPart = singleLineGuardsDoc guardDocs
                        -- the docForceSingleline might seems superflous, but it
                        -- helps the alternative resolving impl.
                        docForceSingleline $ docCols
                          ColGuardedBody
                          [ guardPart
                          , docSeq
                            [ appSep $ return binderDoc
                            , docForceSingleline $ return bodyDoc
                            -- i am not sure if there is a benefit to using
                            -- docForceParSpacing additionally here:
                            -- , docAddBaseY BrIndentRegular $ return bodyDoc
                            ]
                          ]
                  ]
              ]
            ++ wherePartMultiLine
        _ -> return ()
      -- func x y
      --   | null x, null y = a + b
      --   | otherwise = a - b
      addAlternative
        $ docLines
        $ [ docAddBaseY BrIndentRegular
            $ patPartParWrap
            $ docLines
            $ map docSetBaseY
            $ clauseDocs
            <&> \(epAnn, guardDocs, bodyDoc) -> docHandleComms epAnn $ do
                  let guardPart = singleLineGuardsDoc guardDocs
                  -- the docForceSingleline might seems superflous, but it
                  -- helps the alternative resolving impl.
                  docForceSingleline $ docCols
                    ColGuardedBody
                    [ guardPart
                    , docSeq
                      [ appSep $ return binderDoc
                      , docForceSingleline
                      $ return bodyDoc
                      -- i am not sure if there is a benefit to using
                      -- docForceParSpacing additionally here:
                      -- , docAddBaseY BrIndentRegular $ return bodyDoc
                      ]
                    ]
          ]
        ++ wherePartMultiLine
      -- func x y
      --   | null x, null y = do
      --       stmt x
      --       stmt y
      --   | otherwise -> do
      --       abort
      addAlternativeCond (not hasComments)
        $ docLines
        $ [ docAddBaseY BrIndentRegular
            $ patPartParWrap
            $ docLines
            $ map docSetBaseY
            $ clauseDocs
            <&> \(grhsEpAnn, guardDocs, bodyDoc) -> -- TODO92
              docHandleComms grhsEpAnn $ docSeq
                [ singleLineGuardsDoc guardDocs
                , docCols
                  ColOpPrefix
                  [ appSep $ return binderDoc
                  , docAddBaseY BrIndentRegular
                  $ docForceParSpacing
                  $ return bodyDoc
                  ]
                ]
          ]
        ++ wherePartMultiLine
      -- func x y
      --   | null x, null y
      --   = do
      --     stmt x
      --     stmt y
      --   | otherwise
      --   = abort
      addAlternative
        $ docLines
        $ [ docAddBaseY BrIndentRegular
            $ patPartParWrap
            $ docLines
            $ map docSetBaseY
            $ clauseDocs
            >>= \(grhsEpAnn, guardDocs, bodyDoc) -> -- TODO92
              [ docHandleComms grhsEpAnn $ singleLineGuardsDoc guardDocs
              , docCols
                ColOpPrefix
                [ appSep $ return binderDoc
                , docAddBaseY BrIndentRegular
                $ docForceParSpacing
                $ return bodyDoc
                ]
              ]
          ]
        ++ wherePartMultiLine
      -- func x y
      --   | null x
      --   , null y
      --   = do
      --       stmt x
      --       stmt y
      --   | otherwise
      --   = abort
      addAlternative
        $ docLines
        $ [ docAddBaseY BrIndentRegular
            $ patPartParWrap
            $ docLines
            $ map docSetBaseY
            $ clauseDocs
            >>= \(grhsEpAnn, guardDocs, bodyDoc) -> case guardDocs of
              [] ->
                [ docHandleComms grhsEpAnn
                $ docCols
                  ColOpPrefix
                  [ appSep $ return binderDoc
                  , docAddBaseY BrIndentRegular $ return bodyDoc
                  ]
                ]
              [g] ->
                [ docHandleComms grhsEpAnn
                  $ docSeq [appSep $ docLit $ Text.pack "|", return g]
                , docSeq
                  [ appSep $ return binderDoc
                  , docAddBaseY BrIndentRegular $ return bodyDoc
                  ]
                ]
              (g1 : gr) ->
                (  [ docHandleComms grhsEpAnn
                     $ docSeq [appSep $ docLit $ Text.pack "|", return g1]
                   ]
                ++ (gr <&> \g ->
                     docSeq [appSep $ docLit $ Text.pack ",", return g]
                   )
                ++ [ docSeq
                     [ appSep $ return binderDoc
                     , docAddBaseY BrIndentRegular $ return bodyDoc
                     ]
                   ]
                )
          ]
        ++ wherePartMultiLine

-- | Layout a pattern synonym binding
layoutPatSynBind
  :: LIdP GhcPs
  -> HsPatSynDetails GhcPs
  -> HsPatSynDir GhcPs
  -> LPat GhcPs
  -> ToBriDocM BriDocNumbered
layoutPatSynBind name patSynDetails patDir rpat = do
  let
    patDoc = docLit $ Text.pack "pattern"
    binderDoc = case patDir of
      ImplicitBidirectional -> docLit $ Text.pack "="
      _ -> docLit $ Text.pack "<-"
    body = callLayouter layout_colsWrapPat =<< callLayouter layout_pat rpat
    whereDoc = docLit $ Text.pack "where"
  mWhereDocs <- layoutPatSynWhere patDir
  headDoc <-
    fmap pure
    $ docSeq
    $ [ patDoc
      , docSeparator
      , layoutLPatSyn name patSynDetails
      , docSeparator
      , binderDoc
      ]
  runFilteredAlternative $ do
    addAlternative
      $
      -- pattern .. where
      --   ..
      --   ..
        docAddBaseY BrIndentRegular
      $ docSeq
          ([headDoc, docSeparator, body] ++ case mWhereDocs of
            Just ds -> [docSeparator, docPar whereDoc (docLines ds)]
            Nothing -> []
          )
    addAlternative
      $
      -- pattern .. =
      --   ..
      -- pattern .. <-
      --   .. where
      --   ..
      --   ..
        docAddBaseY BrIndentRegular
      $ docPar
          headDoc
          (case mWhereDocs of
            Nothing -> body
            Just ds -> docLines ([docSeq [body, docSeparator, whereDoc]] ++ ds)
          )

-- | Helper method for the left hand side of a pattern synonym
layoutLPatSyn
  :: LIdP GhcPs
  -> HsPatSynDetails GhcPs
  -> ToBriDocM BriDocNumbered
layoutLPatSyn name (PrefixCon _ vars) = do
  docName <- lrdrNameToTextAnn name
  names <- mapM lrdrNameToTextAnn vars
  docSeq . fmap appSep $ docLit docName : (docLit <$> names)
layoutLPatSyn name (InfixCon left right) = do
  leftDoc <- lrdrNameToTextAnn left
  docName <- lrdrNameToTextAnn name
  rightDoc <- lrdrNameToTextAnn right
  docSeq . fmap (appSep . docLit) $ [leftDoc, docName, rightDoc]
layoutLPatSyn name (RecCon recArgs) = do
  docName <- lrdrNameToTextAnn name
  args <- mapM (lrdrNameToTextAnn . rdrNameFieldOcc . recordPatSynField) recArgs
  docSeq
    . fmap docLit
    $ [docName, Text.pack " { "]
    <> intersperse (Text.pack ", ") args
    <> [Text.pack " }"]

-- | Helper method to get the where clause from of explicitly bidirectional
-- pattern synonyms
layoutPatSynWhere
  :: HsPatSynDir GhcPs -> ToBriDocM (Maybe [ToBriDocM BriDocNumbered])
layoutPatSynWhere hs = case hs of
  ExplicitBidirectional (MG NoExtField lbinds@(L _ binds) _) -> do
    binderDoc <- docLit $ Text.pack "="
    bindDocs <- mapM (shareDoc . layoutPatternBind Nothing binderDoc) binds
    pure $ Just $ docHandleComms lbinds bindDocs
  _ -> pure Nothing

--------------------------------------------------------------------------------
-- TyClDecl
--------------------------------------------------------------------------------

layoutTyCl :: ToBriDoc TyClDecl
layoutTyCl ltycl@(L _loc tycl) = case tycl of
  SynDecl epAnn name vars fixity typ -> do
    let
      isInfix = case fixity of
        Prefix -> False
        Infix -> True
    let posEqual = obtainAnnPos epAnn AnnEqual
    let posOpen = obtainAnnPos epAnn AnnOpenP
    -- hasTrailingParen <- hasAnnKeywordComment ltycl AnnCloseP
    -- let parenWrapper = if hasTrailingParen
    --       then appSep . docWrapNodeRest ltycl
    --       else id
    docHandleComms ltycl $ docHandleComms epAnn $ do
      nameStr <- lrdrNameToTextAnn name
      let lhs = appSep $ if isInfix
            then do
              let (a, b, rest) = case hsq_explicit vars of
                    (v1 : v2 : vR) -> (v1, v2, vR)
                    _              -> error "unexpected vars, expected at least 2"
              -- This isn't quite right, but does give syntactically valid results
              let needsParens  = not (null rest) || Data.Maybe.isJust posOpen
              docSeq
                $  [docLit $ Text.pack "type", docSeparator]
                ++ [ docParenL | needsParens ]
                ++ [ layoutTyVarBndr False a
                   , docSeparator
                   , docLit nameStr
                   , docSeparator
                   , layoutTyVarBndr False b
                   ]
                ++ [ docParenR | needsParens ]
                ++ fmap (layoutTyVarBndr True) rest
            else
              docSeq
              $  [ docLit $ Text.pack "type"
                 , docSeparator
                 , docHandleComms name $ docLit nameStr
                 ]
              ++ fmap (layoutTyVarBndr True) (hsq_explicit vars)
      sharedLhs <- shareDoc $ id lhs
      typeDoc   <- shareDoc $ callLayouter2 layout_type False typ
      let hasComments = hasAnyCommentsConnected ltycl
      layoutLhsAndType hasComments
                       sharedLhs
                       (docHandleComms posEqual $ docLit $ Text.pack "=")
                       1
                       typeDoc
  DataDecl epAnn name tyVars _ dataDefn -> do
    layouters <- mAsk
    layout_dataDecl layouters (Just ltycl) epAnn name tyVars [] dataDefn
  _ -> briDocByExactNoComment ltycl

layoutTyVarBndr :: Bool -> ToBriDoc (HsTyVarBndr ())
layoutTyVarBndr needsSep (L _ bndr) = case bndr of
  UserTyVar _ _ name -> do
    nameStr <- lrdrNameToTextAnn name
    docSeq $ [ docSeparator | needsSep ] ++ [docLit nameStr]
  KindedTyVar _ _ name kind -> do
    nameStr <- lrdrNameToTextAnn name
    docSeq
      $ [ docSeparator | needsSep ]
      ++ [ docLit $ Text.pack "("
         , appSep $ docLit nameStr
         , appSep . docLit $ Text.pack "::"
         , docForceSingleline $ callLayouter2 layout_type False kind
         , docLit $ Text.pack ")"
         ]


--------------------------------------------------------------------------------
-- TyFamInstDecl
--------------------------------------------------------------------------------



layoutTyFamInstDecl
  :: Data.Data.Data a
  => Bool
  -> LocatedA a
  -> TyFamInstDecl GhcPs
  -> ToBriDocM BriDocNumbered
layoutTyFamInstDecl inClass outerNode tfid = do
  let
    posType = obtainAnnPos (tfid_xtn tfid) AnnType
    FamEqn epAnn name bndrsMay pats _fixity typ = tfid_eqn tfid
    posEqual = obtainAnnPos epAnn AnnEqual
    -- bndrsMay isJust e.g. with
    --   type instance forall a . MyType (Maybe a) = Either () a
  nameStr <- lrdrNameToTextAnn name
  -- TODO92 needsParens <- hasAnnKeyword outerNode AnnOpenP
  let needsParens = False
  layouters <- mAsk
  let
    instanceDoc = docHandleComms posType $ if inClass
      then docLit $ Text.pack "type"
      else docSeq
        [appSep . docLit $ Text.pack "type", docLit $ Text.pack "instance"]
    makeForallDoc :: [LHsTyVarBndr () GhcPs] -> ToBriDocM BriDocNumbered
    makeForallDoc bndrs = do
      bndrDocs <- callLayouter layout_tyVarBndrs bndrs
      docSeq
        (  [docLit (Text.pack "forall")]
        ++ layout_tyVarBndrsSingleline layouters bndrDocs
        )
    lhs =
      docHandleComms epAnn $ docSeq
        $ [appSep instanceDoc]
        ++ [ makeForallDoc foralls | (HsOuterExplicit _ foralls) <- [bndrsMay] ]
        ++ [ docParenL | needsParens ]
        ++ [appSep $ docHandleComms name $ docLit nameStr]
        ++ intersperse docSeparator (layout_hsTyPats layouters pats)
        ++ [ docParenR | needsParens ]
  -- TODO92 hasComments <-
    -- (||)
    -- <$> hasAnyRegularCommentsConnected outerNode
    -- <*> hasAnyRegularCommentsRest innerNode
  let hasComments = hasAnyCommentsConnected outerNode
  typeDoc <- shareDoc $ callLayouter2 layout_type False typ
  layoutLhsAndType hasComments lhs (docHandleComms posEqual $ docLit $ Text.pack "=") 1 typeDoc


--------------------------------------------------------------------------------
-- ClsInstDecl
--------------------------------------------------------------------------------

-- | Layout an @instance@ declaration
--
--   Layout signatures and bindings using the corresponding layouters from the
--   top-level. Layout the instance head, type family instances, and data family
--   instances using ExactPrint.
layoutClsInst :: LHsDecl GhcPs -> ClsInstDecl GhcPs -> ToBriDocM BriDocNumbered
layoutClsInst (L declLoc _) cid = do
  -- _ x
  docLines
    [ layoutInstanceHead
    , docEnsureIndent BrIndentRegular
    $ docSetIndentLevel
    $ docSortedLines
    $ fmap layoutAndLocateSig (cid_sigs cid)
    ++ fmap layoutAndLocateBind (bagToList $ cid_binds cid)
    ++ fmap layoutAndLocateTyFamInsts (cid_tyfam_insts cid)
    ++ fmap layoutAndLocateDataFamInsts (cid_datafam_insts cid)
    ]
 where
  layoutInstanceHead :: ToBriDocM BriDocNumbered
  layoutInstanceHead = case cid_ext cid of
    (EpAnn annAnchor addEpAnns (EpaComments comms), sortKey) -> do
      let posWhere = obtainAnnPos addEpAnns AnnWhere
      let (commsBefore, commsAfter) =
            partition
              (\(L anch _) ->
                (Just $ GHC.realSrcSpanStart $ anchor anch)
                < fmap GHC.realSrcSpanStart posWhere)
              comms
      docHandleComms (reverse commsAfter)
        $ briDocByExactNoComment
        $ L declLoc
        $ InstD NoExtField
        $ ClsInstD NoExtField
        $ (removeChildren cid) {
            cid_ext = (EpAnn annAnchor addEpAnns (EpaComments commsBefore), sortKey)
          }
    _ -> briDocByExactNoComment
        $ L declLoc
        $ InstD NoExtField
        $ ClsInstD NoExtField
        $ removeChildren cid

  removeChildren :: ClsInstDecl GhcPs -> ClsInstDecl GhcPs
  removeChildren c = c
    { cid_binds = emptyBag
    , cid_sigs = []
    , cid_tyfam_insts = []
    , cid_datafam_insts = []
    }

  -- | Like 'docLines', but sorts the lines based on location
  docSortedLines
    :: [ToBriDocM (Located BriDocNumbered)] -> ToBriDocM BriDocNumbered
  docSortedLines l =
    allocateNode
      . BDLines
      . fmap unLoc
      . List.sortOn (ExactPrint.rs . getLoc)
      =<< sequence l

  layoutAndLocateSig :: ToBriDocC Sig (Located BriDocNumbered)
  layoutAndLocateSig lsig@(L (SrcSpanAnn _ loc) sig) = L loc <$> layoutSig lsig sig

  layoutAndLocateBind :: LHsBind GhcPs -> ToBriDocM (Located BriDocNumbered)
  layoutAndLocateBind lbind@(L (SrcSpanAnn _ loc) _) =
    L loc <$> (joinBinds =<< layoutBind lbind)

  joinBinds
    :: Either [BriDocNumbered] BriDocNumbered -> ToBriDocM BriDocNumbered
  joinBinds = \case
    Left ns -> docLines $ return <$> ns
    Right n -> return n

  layoutAndLocateTyFamInsts
    :: ToBriDocC TyFamInstDecl (Located BriDocNumbered)
  layoutAndLocateTyFamInsts ltfid@(L (SrcSpanAnn _ loc) tfid) =
    L loc <$> layoutTyFamInstDecl True ltfid tfid

  layoutAndLocateDataFamInsts
    :: ToBriDocC DataFamInstDecl (Located BriDocNumbered)
  layoutAndLocateDataFamInsts ldfid@(L (SrcSpanAnn _ loc) _) =
    L loc <$> layoutDataFamInstDecl ldfid

  -- | Send to ExactPrint then remove unecessary whitespace
  layoutDataFamInstDecl :: ToBriDoc DataFamInstDecl
  layoutDataFamInstDecl ldfid@(L _ (DataFamInstDecl famEqn)) =
    docHandleComms ldfid $ case famEqn of
      FamEqn epAnn tycon bndrs pats Prefix rhs -> do
        layouters <- mAsk
        layout_dataDecl
          layouters
          Nothing
          epAnn
          tycon
          (case bndrs of
            HsOuterImplicit NoExtField -> HsQTvs NoExtField []
            HsOuterExplicit _ innerBndrs -> HsQTvs NoExtField $ innerBndrs
          )
          pats
          rhs
      _ -> error "Unsupported DataFamInstDecl"
        -- case rhs of
        -- HsDataDefn NoExtField NewType Nothing Nothing Nothing [lcons] [] ->
        --   let L _ cons = lcons
        --   case cons of
        --     ConDeclH98 _ext cName False _qvars ctxMay details _conDoc -> do
        --       -- (Just (L _ [])) = ctxMay
        --       nameStr <- lrdrNameToTextAnn tycon
        --       consNameStr <- lrdrNameToTextAnn cName
        --       tyVarLine <- return <$> createBndrDoc bndrs
        --       let
        --         isInfix = case fixity of
        --           Prefix -> False
        --           Infix -> True
        --       _ x
        --       docHandleComms epAnn
        --         $  docSeq
        --         $  [appSep $ docLitS "newtype", appSep $ docLit nameStr]
        --         ++ [ makeForallDoc foralls | (HsOuterExplicit _ foralls) <- [bndrs] ]
        --         ++ [ _ pats ]
      -- fmap stripWhitespace <$> undefined -- TODO92 !!! briDocByExactNoComment ldfid

--------------------------------------------------------------------------------
-- Common Helpers
--------------------------------------------------------------------------------

layoutLhsAndType
  :: Bool
  -> ToBriDocM BriDocNumbered
  -> ToBriDocM BriDocNumbered
  -> Int
  -> ToBriDocM BriDocNumbered
  -> ToBriDocM BriDocNumbered
layoutLhsAndType hasComments lhs sep sepLen typeDoc = do
  runFilteredAlternative $ do
    -- (separators probably are "=" or "::")
    -- lhs = type
    -- lhs :: type
    addAlternativeCond (not hasComments) $ docSeq
      [lhs, docSeparator, sep, docSeparator, docForceSingleline typeDoc]
    -- lhs
    --   :: typeA
    --   -> typeB
    -- lhs
    --   =  typeA
    --   -> typeB
    addAlternative $ docAddBaseY BrIndentRegular $ docPar lhs $ docCols
      ColTyOpPrefix
      [ appSep sep
      , docAddBaseY (BrIndentSpecial (sepLen + 1)) typeDoc
      ]
