{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ConstraintKinds #-}

module Language.Haskell.Brittany.Internal.Backend
  ( layoutBriDocM
  )
where



#include "prelude.inc"

import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
import           Language.Haskell.GHC.ExactPrint.Types ( AnnKey, Annotation )

import GHC ( AnnKeywordId (..) )

import           Language.Haskell.Brittany.Internal.LayouterBasics
import           Language.Haskell.Brittany.Internal.BackendUtils
import           Language.Haskell.Brittany.Internal.Utils
import           Language.Haskell.Brittany.Internal.Config.Types
import           Language.Haskell.Brittany.Internal.Types


import qualified Data.Text.Lazy.Builder as Text.Builder


import           Data.HList.ContainsType

import           Control.Monad.Extra ( whenM )

import qualified Control.Monad.Trans.Writer.Strict as WriterS



type ColIndex  = Int

data ColumnSpacing
  = ColumnSpacingLeaf Int
  | ColumnSpacingRef Int Int

type ColumnBlock  a = [a]
type ColumnBlocks a = Seq [a]
type ColMap1 = IntMapL.IntMap {- ColIndex -} (Bool, ColumnBlocks ColumnSpacing)
type ColMap2 = IntMapL.IntMap {- ColIndex -} (Float, ColumnBlock Int, ColumnBlocks Int)
                                          -- (ratio of hasSpace, maximum, raw)

data ColInfo
  = ColInfoStart -- start value to begin the mapAccumL.
  | ColInfoNo BriDoc
  | ColInfo ColIndex ColSig [(Int, ColInfo)]

instance Show ColInfo where
  show :: ColInfo -> String
show ColInfo
ColInfoStart = String
"ColInfoStart"
  show (ColInfoNo BriDoc
bd) = String
"ColInfoNo " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show (Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
30 (Doc -> String
forall a. Show a => a -> String
show (BriDoc -> Doc
briDocToDoc BriDoc
bd)) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"..")
  show (ColInfo Int
ind ColSig
sig [(Int, ColInfo)]
list) = String
"ColInfo " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
ind String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ColSig -> String
forall a. Show a => a -> String
show ColSig
sig String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [(Int, ColInfo)] -> String
forall a. Show a => a -> String
show [(Int, ColInfo)]
list

data ColBuildState = ColBuildState
  { ColBuildState -> ColMap1
_cbs_map :: ColMap1
  , ColBuildState -> Int
_cbs_index :: ColIndex
  }

type LayoutConstraints m = ( MonadMultiReader Config m
                           , MonadMultiReader ExactPrint.Types.Anns m
                           , MonadMultiWriter Text.Builder.Builder m
                           , MonadMultiWriter (Seq String) m
                           , MonadMultiState LayoutState m
                           )

layoutBriDocM :: forall m . LayoutConstraints m => BriDoc -> m ()
layoutBriDocM :: BriDoc -> m ()
layoutBriDocM = \case
  BriDoc
BDEmpty -> do
    () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return () -- can it be that simple
  BDLit Text
t -> do
    m ()
forall (m :: * -> *).
(MonadMultiState LayoutState m, MonadMultiWriter Builder m,
 MonadMultiWriter (Seq String) m) =>
m ()
layoutIndentRestorePostComment
    m ()
forall (m :: * -> *).
(MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) =>
m ()
layoutRemoveIndentLevelLinger
    Text -> m ()
forall (m :: * -> *).
(MonadMultiWriter Builder m, MonadMultiState LayoutState m,
 MonadMultiWriter (Seq String) m) =>
Text -> m ()
layoutWriteAppend Text
t
  BDSeq [BriDoc]
list -> do
    [BriDoc]
list [BriDoc] -> (BriDoc -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
`forM_` BriDoc -> m ()
forall (m :: * -> *). LayoutConstraints m => BriDoc -> m ()
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 ColSig
_ [BriDoc]
list -> do
    [BriDoc]
list [BriDoc] -> (BriDoc -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
`forM_` BriDoc -> m ()
forall (m :: * -> *). LayoutConstraints m => BriDoc -> m ()
layoutBriDocM
  BriDoc
BDSeparator -> do
    m ()
forall (m :: * -> *).
(MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) =>
m ()
layoutAddSepSpace
  BDAddBaseY BrIndent
indent BriDoc
bd -> do
    let indentF :: m () -> m ()
indentF = case BrIndent
indent of
          BrIndent
BrIndentNone      -> m () -> m ()
forall a. a -> a
id
          BrIndent
BrIndentRegular   -> m () -> m ()
forall (m :: * -> *).
(MonadMultiWriter Builder m, MonadMultiState LayoutState m,
 MonadMultiReader Config m, MonadMultiWriter (Seq String) m) =>
m () -> m ()
layoutWithAddBaseCol
          BrIndentSpecial Int
i -> Int -> m () -> m ()
forall (m :: * -> *).
(MonadMultiWriter Builder m, MonadMultiState LayoutState m,
 MonadMultiWriter (Seq String) m) =>
Int -> m () -> m ()
layoutWithAddBaseColN Int
i
    m () -> m ()
indentF (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ BriDoc -> m ()
forall (m :: * -> *). LayoutConstraints m => BriDoc -> m ()
layoutBriDocM BriDoc
bd
  BDBaseYPushCur BriDoc
bd -> do
    m ()
forall (m :: * -> *).
(MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) =>
m ()
layoutBaseYPushCur
    BriDoc -> m ()
forall (m :: * -> *). LayoutConstraints m => BriDoc -> m ()
layoutBriDocM BriDoc
bd
  BDBaseYPop BriDoc
bd -> do
    BriDoc -> m ()
forall (m :: * -> *). LayoutConstraints m => BriDoc -> m ()
layoutBriDocM BriDoc
bd
    m ()
forall (m :: * -> *).
(MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) =>
m ()
layoutBaseYPop
  BDIndentLevelPushCur BriDoc
bd -> do
    m ()
forall (m :: * -> *).
(MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) =>
m ()
layoutIndentLevelPushCur
    BriDoc -> m ()
forall (m :: * -> *). LayoutConstraints m => BriDoc -> m ()
layoutBriDocM BriDoc
bd
  BDIndentLevelPop BriDoc
bd -> do
    BriDoc -> m ()
forall (m :: * -> *). LayoutConstraints m => BriDoc -> m ()
layoutBriDocM BriDoc
bd
    m ()
forall (m :: * -> *).
(MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) =>
m ()
layoutIndentLevelPop
  BDEnsureIndent BrIndent
indent BriDoc
bd -> do
    let indentF :: m () -> m ()
indentF = case BrIndent
indent of
          BrIndent
BrIndentNone      -> m () -> m ()
forall a. a -> a
id
          BrIndent
BrIndentRegular   -> m () -> m ()
forall (m :: * -> *).
(MonadMultiWriter Builder m, MonadMultiState LayoutState m,
 MonadMultiReader Config m, MonadMultiWriter (Seq String) m) =>
m () -> m ()
layoutWithAddBaseCol
          BrIndentSpecial Int
i -> Int -> m () -> m ()
forall (m :: * -> *).
(MonadMultiWriter Builder m, MonadMultiState LayoutState m,
 MonadMultiWriter (Seq String) m) =>
Int -> m () -> m ()
layoutWithAddBaseColN Int
i
    m () -> m ()
indentF (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      m ()
forall (m :: * -> *).
(MonadMultiWriter Builder m, MonadMultiState LayoutState m,
 MonadMultiWriter (Seq String) m) =>
m ()
layoutWriteEnsureBlock
      BriDoc -> m ()
forall (m :: * -> *). LayoutConstraints m => BriDoc -> m ()
layoutBriDocM BriDoc
bd
  BDPar BrIndent
indent BriDoc
sameLine BriDoc
indented -> do
    BriDoc -> m ()
forall (m :: * -> *). LayoutConstraints m => BriDoc -> m ()
layoutBriDocM BriDoc
sameLine
    let indentF :: m () -> m ()
indentF = case BrIndent
indent of
          BrIndent
BrIndentNone      -> m () -> m ()
forall a. a -> a
id
          BrIndent
BrIndentRegular   -> m () -> m ()
forall (m :: * -> *).
(MonadMultiWriter Builder m, MonadMultiState LayoutState m,
 MonadMultiReader Config m, MonadMultiWriter (Seq String) m) =>
m () -> m ()
layoutWithAddBaseCol
          BrIndentSpecial Int
i -> Int -> m () -> m ()
forall (m :: * -> *).
(MonadMultiWriter Builder m, MonadMultiState LayoutState m,
 MonadMultiWriter (Seq String) m) =>
Int -> m () -> m ()
layoutWithAddBaseColN Int
i
    m () -> m ()
indentF (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      m ()
forall (m :: * -> *).
(MonadMultiWriter Builder m, MonadMultiState LayoutState m,
 MonadMultiWriter (Seq String) m) =>
m ()
layoutWriteNewlineBlock
      BriDoc -> m ()
forall (m :: * -> *). LayoutConstraints m => BriDoc -> m ()
layoutBriDocM BriDoc
indented
  BDLines           [BriDoc]
lines                      -> [BriDoc] -> m ()
forall (m :: * -> *). LayoutConstraints m => [BriDoc] -> m ()
alignColsLines [BriDoc]
lines
  BDAlt             []                         -> String -> m ()
forall a. HasCallStack => String -> a
error String
"empty BDAlt"
  BDAlt             (BriDoc
alt:[BriDoc]
_)                    -> BriDoc -> m ()
forall (m :: * -> *). LayoutConstraints m => BriDoc -> m ()
layoutBriDocM BriDoc
alt
  BDForceMultiline  BriDoc
bd                         -> BriDoc -> m ()
forall (m :: * -> *). LayoutConstraints m => BriDoc -> m ()
layoutBriDocM BriDoc
bd
  BDForceSingleline BriDoc
bd                         -> BriDoc -> m ()
forall (m :: * -> *). LayoutConstraints m => BriDoc -> m ()
layoutBriDocM BriDoc
bd
  BDForwardLineMode BriDoc
bd                         -> BriDoc -> m ()
forall (m :: * -> *). LayoutConstraints m => BriDoc -> m ()
layoutBriDocM BriDoc
bd
  BDExternal AnnKey
annKey Set AnnKey
subKeys Bool
shouldAddComment Text
t -> do
    let tlines :: [Text]
tlines     = Text -> [Text]
Text.lines (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack String
"\n"
        tlineCount :: Int
tlineCount = [Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
tlines
    Anns
anns :: ExactPrint.Anns <- m Anns
forall a (m :: * -> *). MonadMultiReader a m => m a
mAsk
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shouldAddComment (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      Text -> m ()
forall (m :: * -> *).
(MonadMultiWriter Builder m, MonadMultiState LayoutState m,
 MonadMultiWriter (Seq String) m) =>
Text -> m ()
layoutWriteAppend
        (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$  String -> Text
Text.pack
        (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$  String
"{-"
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ (AnnKey, Maybe Annotation) -> String
forall a. Show a => a -> String
show (AnnKey
annKey, AnnKey -> Anns -> Maybe Annotation
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup AnnKey
annKey Anns
anns)
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"-}"
    [Int] -> [Text] -> [(Int, Text)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 ..] [Text]
tlines [(Int, Text)] -> ((Int, Text) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
`forM_` \(Int
i, Text
l) -> do
      Text -> m ()
forall (m :: * -> *).
(MonadMultiWriter Builder m, MonadMultiState LayoutState m,
 MonadMultiWriter (Seq String) m) =>
Text -> m ()
layoutWriteAppend (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
l
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
tlineCount) m ()
forall (m :: * -> *).
(MonadMultiWriter Builder m, MonadMultiState LayoutState m,
 MonadMultiWriter (Seq String) m) =>
m ()
layoutWriteNewlineBlock
    do
      LayoutState
state <- m LayoutState
forall a (m :: * -> *). MonadMultiGet a m => m a
mGet
      let filterF :: AnnKey -> Annotation -> Bool
filterF AnnKey
k Annotation
_ = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ AnnKey
k AnnKey -> Set AnnKey -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set AnnKey
subKeys
      LayoutState -> m ()
forall a (m :: * -> *). MonadMultiState a m => a -> m ()
mSet (LayoutState -> m ()) -> LayoutState -> m ()
forall a b. (a -> b) -> a -> b
$ LayoutState
state
        { _lstate_comments :: Anns
_lstate_comments = (AnnKey -> Annotation -> Bool) -> Anns -> Anns
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey AnnKey -> Annotation -> Bool
filterF (Anns -> Anns) -> Anns -> Anns
forall a b. (a -> b) -> a -> b
$ LayoutState -> Anns
_lstate_comments LayoutState
state
        }
  BDPlain Text
t -> do
    Text -> m ()
forall (m :: * -> *).
(MonadMultiWriter Builder m, MonadMultiState LayoutState m,
 MonadMultiWriter (Seq String) m) =>
Text -> m ()
layoutWriteAppend Text
t
  BDAnnotationPrior AnnKey
annKey BriDoc
bd -> do
    LayoutState
state <- m LayoutState
forall a (m :: * -> *). MonadMultiGet a m => m a
mGet
    let m :: Anns
m = LayoutState -> Anns
_lstate_comments LayoutState
state
    let moveToExactLocationAction :: m ()
moveToExactLocationAction = case LayoutState -> Either Int Int
_lstate_curYOrAddNewline LayoutState
state of
          Left{} -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          Right{} -> AnnKey -> m ()
forall (m :: * -> *).
(MonadMultiWriter Builder m, MonadMultiState LayoutState m,
 MonadMultiReader Anns m, MonadMultiWriter (Seq String) m) =>
AnnKey -> m ()
moveToExactAnn AnnKey
annKey
    Maybe [(Comment, DeltaPos)]
mAnn <- do
      let mAnn :: Maybe [(Comment, DeltaPos)]
mAnn = Annotation -> [(Comment, DeltaPos)]
ExactPrint.annPriorComments (Annotation -> [(Comment, DeltaPos)])
-> Maybe Annotation -> Maybe [(Comment, DeltaPos)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AnnKey -> Anns -> Maybe Annotation
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup AnnKey
annKey Anns
m
      LayoutState -> m ()
forall a (m :: * -> *). MonadMultiState a m => a -> m ()
mSet (LayoutState -> m ()) -> LayoutState -> m ()
forall a b. (a -> b) -> a -> b
$ LayoutState
state
        { _lstate_comments :: Anns
_lstate_comments = (Annotation -> Annotation) -> AnnKey -> Anns -> Anns
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust
          (\Annotation
ann -> Annotation
ann { annPriorComments :: [(Comment, DeltaPos)]
ExactPrint.annPriorComments = [] })
          AnnKey
annKey
          Anns
m
        }
      Maybe [(Comment, DeltaPos)] -> m (Maybe [(Comment, DeltaPos)])
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [(Comment, DeltaPos)]
mAnn
    case Maybe [(Comment, DeltaPos)]
mAnn of
      Maybe [(Comment, DeltaPos)]
Nothing     -> m ()
moveToExactLocationAction
      Just []     -> m ()
moveToExactLocationAction
      Just [(Comment, DeltaPos)]
priors -> do
        -- layoutResetSepSpace
        [(Comment, DeltaPos)]
priors
          [(Comment, DeltaPos)] -> ((Comment, DeltaPos) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
`forM_` \(ExactPrint.Types.Comment String
comment AnnSpan
_ Maybe AnnKeywordId
_, ExactPrint.Types.DP (Int
y, Int
x)) ->
                    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ String
comment String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"(" Bool -> Bool -> Bool
|| String
comment String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
")") (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
                      let commentLines :: [Text]
commentLines = Text -> [Text]
Text.lines (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
comment
                      case String
comment of
                        (Char
'#':String
_) -> Int -> Int -> Int -> m ()
forall (m :: * -> *).
(MonadMultiWriter Builder m, MonadMultiState LayoutState m,
 MonadMultiWriter (Seq String) m) =>
Int -> Int -> Int -> m ()
layoutMoveToCommentPos Int
y (-Int
999) ([Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
commentLines)
                                   --  ^ evil hack for CPP
                        String
_       -> Int -> Int -> Int -> m ()
forall (m :: * -> *).
(MonadMultiWriter Builder m, MonadMultiState LayoutState m,
 MonadMultiWriter (Seq String) m) =>
Int -> Int -> Int -> m ()
layoutMoveToCommentPos Int
y Int
x ([Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
commentLines)
                      -- fixedX <- fixMoveToLineByIsNewline x
                      -- replicateM_ fixedX layoutWriteNewline
                      -- layoutMoveToIndentCol y
                      [Text] -> m ()
forall (m :: * -> *).
(MonadMultiWriter Builder m, MonadMultiState LayoutState m,
 MonadMultiWriter (Seq String) m) =>
[Text] -> m ()
layoutWriteAppendMultiline [Text]
commentLines
          -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }
        m ()
moveToExactLocationAction
    BriDoc -> m ()
forall (m :: * -> *). LayoutConstraints m => BriDoc -> m ()
layoutBriDocM BriDoc
bd
  BDAnnotationKW AnnKey
annKey Maybe AnnKeywordId
keyword BriDoc
bd -> do
    BriDoc -> m ()
forall (m :: * -> *). LayoutConstraints m => BriDoc -> m ()
layoutBriDocM BriDoc
bd
    Maybe (NonEmpty (Comment, DeltaPos))
mComments <- do
      LayoutState
state <- m LayoutState
forall a (m :: * -> *). MonadMultiGet a m => m a
mGet
      let m :: Anns
m    = LayoutState -> Anns
_lstate_comments LayoutState
state
      let mAnn :: Maybe [(KeywordId, DeltaPos)]
mAnn = Annotation -> [(KeywordId, DeltaPos)]
ExactPrint.annsDP (Annotation -> [(KeywordId, DeltaPos)])
-> Maybe Annotation -> Maybe [(KeywordId, DeltaPos)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AnnKey -> Anns -> Maybe Annotation
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup AnnKey
annKey Anns
m
      let mToSpan :: Maybe [(KeywordId, DeltaPos)]
mToSpan = case Maybe [(KeywordId, DeltaPos)]
mAnn of
            Just [(KeywordId, DeltaPos)]
anns | Maybe AnnKeywordId
keyword Maybe AnnKeywordId -> Maybe AnnKeywordId -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe AnnKeywordId
forall a. Maybe a
Nothing -> [(KeywordId, DeltaPos)] -> Maybe [(KeywordId, DeltaPos)]
forall a. a -> Maybe a
Just [(KeywordId, DeltaPos)]
anns
            Just ((ExactPrint.Types.G AnnKeywordId
kw1, DeltaPos
_):[(KeywordId, DeltaPos)]
annR) | Maybe AnnKeywordId
keyword Maybe AnnKeywordId -> Maybe AnnKeywordId -> Bool
forall a. Eq a => a -> a -> Bool
== AnnKeywordId -> Maybe AnnKeywordId
forall a. a -> Maybe a
Just AnnKeywordId
kw1 -> [(KeywordId, DeltaPos)] -> Maybe [(KeywordId, DeltaPos)]
forall a. a -> Maybe a
Just
              [(KeywordId, DeltaPos)]
annR
            Maybe [(KeywordId, DeltaPos)]
_ -> Maybe [(KeywordId, DeltaPos)]
forall a. Maybe a
Nothing
      case Maybe [(KeywordId, DeltaPos)]
mToSpan of
        Just [(KeywordId, DeltaPos)]
anns -> do
          let ([(Comment, DeltaPos)]
comments, [(KeywordId, DeltaPos)]
rest) = (((KeywordId, DeltaPos) -> Maybe (Comment, DeltaPos))
 -> [(KeywordId, DeltaPos)]
 -> ([(Comment, DeltaPos)], [(KeywordId, DeltaPos)]))
-> [(KeywordId, DeltaPos)]
-> ((KeywordId, DeltaPos) -> Maybe (Comment, DeltaPos))
-> ([(Comment, DeltaPos)], [(KeywordId, DeltaPos)])
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((KeywordId, DeltaPos) -> Maybe (Comment, DeltaPos))
-> [(KeywordId, DeltaPos)]
-> ([(Comment, DeltaPos)], [(KeywordId, DeltaPos)])
forall a b. (a -> Maybe b) -> [a] -> ([b], [a])
spanMaybe [(KeywordId, DeltaPos)]
anns (((KeywordId, DeltaPos) -> Maybe (Comment, DeltaPos))
 -> ([(Comment, DeltaPos)], [(KeywordId, DeltaPos)]))
-> ((KeywordId, DeltaPos) -> Maybe (Comment, DeltaPos))
-> ([(Comment, DeltaPos)], [(KeywordId, DeltaPos)])
forall a b. (a -> b) -> a -> b
$ \case
                (ExactPrint.Types.AnnComment Comment
x, DeltaPos
dp) -> (Comment, DeltaPos) -> Maybe (Comment, DeltaPos)
forall a. a -> Maybe a
Just (Comment
x, DeltaPos
dp)
                (KeywordId, DeltaPos)
_ -> Maybe (Comment, DeltaPos)
forall a. Maybe a
Nothing
          LayoutState -> m ()
forall a (m :: * -> *). MonadMultiState a m => a -> m ()
mSet (LayoutState -> m ()) -> LayoutState -> m ()
forall a b. (a -> b) -> a -> b
$ LayoutState
state
            { _lstate_comments :: Anns
_lstate_comments = (Annotation -> Annotation) -> AnnKey -> Anns -> Anns
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust
              (\Annotation
ann -> Annotation
ann { annsDP :: [(KeywordId, DeltaPos)]
ExactPrint.annsDP = [(KeywordId, DeltaPos)]
rest })
              AnnKey
annKey
              Anns
m
            }
          Maybe (NonEmpty (Comment, DeltaPos))
-> m (Maybe (NonEmpty (Comment, DeltaPos)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (NonEmpty (Comment, DeltaPos))
 -> m (Maybe (NonEmpty (Comment, DeltaPos))))
-> Maybe (NonEmpty (Comment, DeltaPos))
-> m (Maybe (NonEmpty (Comment, DeltaPos)))
forall a b. (a -> b) -> a -> b
$ [(Comment, DeltaPos)] -> Maybe (NonEmpty (Comment, DeltaPos))
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [(Comment, DeltaPos)]
comments
        Maybe [(KeywordId, DeltaPos)]
_ -> Maybe (NonEmpty (Comment, DeltaPos))
-> m (Maybe (NonEmpty (Comment, DeltaPos)))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (NonEmpty (Comment, DeltaPos))
forall a. Maybe a
Nothing
    case Maybe (NonEmpty (Comment, DeltaPos))
mComments of
      Maybe (NonEmpty (Comment, DeltaPos))
Nothing -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just NonEmpty (Comment, DeltaPos)
comments -> do
        NonEmpty (Comment, DeltaPos)
comments NonEmpty (Comment, DeltaPos)
-> ((Comment, DeltaPos) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
`forM_` \(ExactPrint.Types.Comment String
comment AnnSpan
_ Maybe AnnKeywordId
_, ExactPrint.Types.DP (Int
y, Int
x)) ->
          Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ String
comment String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"(" Bool -> Bool -> Bool
|| String
comment String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
")") (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
            let commentLines :: [Text]
commentLines = Text -> [Text]
Text.lines (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
comment
            -- evil hack for CPP:
            case String
comment of
              (Char
'#':String
_) -> Int -> Int -> Int -> m ()
forall (m :: * -> *).
(MonadMultiWriter Builder m, MonadMultiState LayoutState m,
 MonadMultiWriter (Seq String) m) =>
Int -> Int -> Int -> m ()
layoutMoveToCommentPos Int
y (-Int
999) ([Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
commentLines)
              String
_       -> Int -> Int -> Int -> m ()
forall (m :: * -> *).
(MonadMultiWriter Builder m, MonadMultiState LayoutState m,
 MonadMultiWriter (Seq String) m) =>
Int -> Int -> Int -> m ()
layoutMoveToCommentPos Int
y Int
x ([Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
commentLines)
            -- fixedX <- fixMoveToLineByIsNewline x
            -- replicateM_ fixedX layoutWriteNewline
            -- layoutMoveToIndentCol y
            [Text] -> m ()
forall (m :: * -> *).
(MonadMultiWriter Builder m, MonadMultiState LayoutState m,
 MonadMultiWriter (Seq String) m) =>
[Text] -> m ()
layoutWriteAppendMultiline [Text]
commentLines
      -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }
  BDAnnotationRest AnnKey
annKey BriDoc
bd -> do
    BriDoc -> m ()
forall (m :: * -> *). LayoutConstraints m => BriDoc -> m ()
layoutBriDocM BriDoc
bd
    Maybe Annotation
annMay <- do
      LayoutState
state <- m LayoutState
forall a (m :: * -> *). MonadMultiGet a m => m a
mGet
      let m :: Anns
m = LayoutState -> Anns
_lstate_comments LayoutState
state
      Maybe Annotation -> m (Maybe Annotation)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Annotation -> m (Maybe Annotation))
-> Maybe Annotation -> m (Maybe Annotation)
forall a b. (a -> b) -> a -> b
$ AnnKey -> Anns -> Maybe Annotation
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup AnnKey
annKey Anns
m
    let mComments :: Maybe (NonEmpty (Comment, DeltaPos))
mComments = [(Comment, DeltaPos)] -> Maybe (NonEmpty (Comment, DeltaPos))
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty ([(Comment, DeltaPos)] -> Maybe (NonEmpty (Comment, DeltaPos)))
-> Maybe [(Comment, DeltaPos)]
-> Maybe (NonEmpty (Comment, DeltaPos))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Annotation -> [(Comment, DeltaPos)]
extractAllComments (Annotation -> [(Comment, DeltaPos)])
-> Maybe Annotation -> Maybe [(Comment, DeltaPos)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Annotation
annMay
    let semiCount :: Int
semiCount = [()] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ ()
                | Just Annotation
ann <- [ Maybe Annotation
annMay ]
                , (KeywordId
ExactPrint.Types.AnnSemiSep, DeltaPos
_) <- Annotation -> [(KeywordId, DeltaPos)]
ExactPrint.Types.annsDP Annotation
ann
                ]
    Bool
shouldAddSemicolonNewlines <- m Config
forall a (m :: * -> *). MonadMultiReader a m => m a
mAsk m Config -> (Config -> Bool) -> m Bool
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&>
      Config -> CLayoutConfig Identity
forall (f :: * -> *). CConfig f -> CLayoutConfig f
_conf_layout (Config -> CLayoutConfig Identity)
-> (CLayoutConfig Identity -> Identity (Last Bool))
-> Config
-> Identity (Last Bool)
forall a b c. (a -> b) -> (b -> c) -> a -> c
.> CLayoutConfig Identity -> Identity (Last Bool)
forall (f :: * -> *). CLayoutConfig f -> f (Last Bool)
_lconfig_experimentalSemicolonNewlines (Config -> Identity (Last Bool))
-> (Identity (Last Bool) -> Bool) -> Config -> Bool
forall a b c. (a -> b) -> (b -> c) -> a -> c
.> Identity (Last Bool) -> Bool
forall a b. Coercible a b => Identity a -> b
confUnpack
    (LayoutState -> LayoutState) -> m ()
forall s (m :: * -> *). MonadMultiState s m => (s -> s) -> m ()
mModify ((LayoutState -> LayoutState) -> m ())
-> (LayoutState -> LayoutState) -> m ()
forall a b. (a -> b) -> a -> b
$ \LayoutState
state -> LayoutState
state
      { _lstate_comments :: Anns
_lstate_comments = (Annotation -> Annotation) -> AnnKey -> Anns -> Anns
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust
        ( \Annotation
ann -> Annotation
ann { annFollowingComments :: [(Comment, DeltaPos)]
ExactPrint.annFollowingComments = []
                      , annPriorComments :: [(Comment, DeltaPos)]
ExactPrint.annPriorComments     = []
                      , annsDP :: [(KeywordId, DeltaPos)]
ExactPrint.annsDP               =
                        (((KeywordId, DeltaPos) -> Bool)
 -> [(KeywordId, DeltaPos)] -> [(KeywordId, DeltaPos)])
-> [(KeywordId, DeltaPos)]
-> ((KeywordId, DeltaPos) -> Bool)
-> [(KeywordId, DeltaPos)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((KeywordId, DeltaPos) -> Bool)
-> [(KeywordId, DeltaPos)] -> [(KeywordId, DeltaPos)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Annotation -> [(KeywordId, DeltaPos)]
ExactPrint.annsDP Annotation
ann) (((KeywordId, DeltaPos) -> Bool) -> [(KeywordId, DeltaPos)])
-> ((KeywordId, DeltaPos) -> Bool) -> [(KeywordId, DeltaPos)]
forall a b. (a -> b) -> a -> b
$ \case
                          (ExactPrint.Types.AnnComment{}, DeltaPos
_) -> Bool
False
                          (KeywordId, DeltaPos)
_                                  -> Bool
True
                      }
        )
        AnnKey
annKey
        (LayoutState -> Anns
_lstate_comments LayoutState
state)
      }
    case Maybe (NonEmpty (Comment, DeltaPos))
mComments of
      Maybe (NonEmpty (Comment, DeltaPos))
Nothing -> do
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shouldAddSemicolonNewlines (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
          [Int
1..Int
semiCount] [Int] -> (Int -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
`forM_` \Int
_ -> m ()
forall (m :: * -> *).
(MonadMultiWriter Builder m, MonadMultiState LayoutState m,
 MonadMultiWriter (Seq String) m) =>
m ()
layoutWriteNewline
      Just NonEmpty (Comment, DeltaPos)
comments -> do
        NonEmpty (Comment, DeltaPos)
comments NonEmpty (Comment, DeltaPos)
-> ((Comment, DeltaPos) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
`forM_` \(ExactPrint.Types.Comment String
comment AnnSpan
_ Maybe AnnKeywordId
_, ExactPrint.Types.DP (Int
y, Int
x)) ->
          Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ String
comment String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"(" Bool -> Bool -> Bool
|| String
comment String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
")") (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
            let commentLines :: [Text]
commentLines = Text -> [Text]
Text.lines (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack String
comment
            case String
comment of
              (Char
'#':String
_) -> Int -> Int -> Int -> m ()
forall (m :: * -> *).
(MonadMultiWriter Builder m, MonadMultiState LayoutState m,
 MonadMultiWriter (Seq String) m) =>
Int -> Int -> Int -> m ()
layoutMoveToCommentPos Int
y (-Int
999) Int
1
                         --  ^ evil hack for CPP
              String
")"     -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                         --  ^ fixes the formatting of parens
                         --    on the lhs of type alias defs
              String
_       -> Int -> Int -> Int -> m ()
forall (m :: * -> *).
(MonadMultiWriter Builder m, MonadMultiState LayoutState m,
 MonadMultiWriter (Seq String) m) =>
Int -> Int -> Int -> m ()
layoutMoveToCommentPos Int
y Int
x ([Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
commentLines)
            -- fixedX <- fixMoveToLineByIsNewline x
            -- replicateM_ fixedX layoutWriteNewline
            -- layoutMoveToIndentCol y
            [Text] -> m ()
forall (m :: * -> *).
(MonadMultiWriter Builder m, MonadMultiState LayoutState m,
 MonadMultiWriter (Seq String) m) =>
[Text] -> m ()
layoutWriteAppendMultiline [Text]
commentLines
      -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }
  BDMoveToKWDP AnnKey
annKey AnnKeywordId
keyword Bool
shouldRestoreIndent BriDoc
bd -> do
    Maybe (Int, Int)
mDP <- do
      LayoutState
state <- m LayoutState
forall a (m :: * -> *). MonadMultiGet a m => m a
mGet
      let m :: Anns
m    = LayoutState -> Anns
_lstate_comments LayoutState
state
      let mAnn :: Maybe [(KeywordId, DeltaPos)]
mAnn = Annotation -> [(KeywordId, DeltaPos)]
ExactPrint.annsDP (Annotation -> [(KeywordId, DeltaPos)])
-> Maybe Annotation -> Maybe [(KeywordId, DeltaPos)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AnnKey -> Anns -> Maybe Annotation
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup AnnKey
annKey Anns
m
      let relevant :: [DeltaPos]
relevant = [ DeltaPos
dp
                     | Just [(KeywordId, DeltaPos)]
ann <- [Maybe [(KeywordId, DeltaPos)]
mAnn]
                     , (ExactPrint.Types.G AnnKeywordId
kw1, DeltaPos
dp) <- [(KeywordId, DeltaPos)]
ann
                     , AnnKeywordId
keyword AnnKeywordId -> AnnKeywordId -> Bool
forall a. Eq a => a -> a -> Bool
== AnnKeywordId
kw1
                     ]
      -- mTell $ Seq.fromList [show keyword, "KWDP: " ++ show annKey ++ " " ++ show mAnn, show relevant]
      case [DeltaPos]
relevant of
        [] -> Maybe (Int, Int) -> m (Maybe (Int, Int))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Int, Int)
forall a. Maybe a
Nothing
        (ExactPrint.Types.DP (Int
y, Int
x):[DeltaPos]
_) -> do
          LayoutState -> m ()
forall a (m :: * -> *). MonadMultiState a m => a -> m ()
mSet LayoutState
state { _lstate_commentNewlines :: Int
_lstate_commentNewlines = Int
0 }
          Maybe (Int, Int) -> m (Maybe (Int, Int))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Int, Int) -> m (Maybe (Int, Int)))
-> Maybe (Int, Int) -> m (Maybe (Int, Int))
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> Maybe (Int, Int)
forall a. a -> Maybe a
Just (Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
- LayoutState -> Int
_lstate_commentNewlines LayoutState
state, Int
x)
    case Maybe (Int, Int)
mDP of
      Maybe (Int, Int)
Nothing -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just (Int
y, Int
x) ->
        -- we abuse this, as we probably will print the KW next, which is
        -- _not_ a comment..
        Int -> Int -> Int -> m ()
forall (m :: * -> *).
(MonadMultiWriter Builder m, MonadMultiState LayoutState m,
 MonadMultiWriter (Seq String) m) =>
Int -> Int -> Int -> m ()
layoutMoveToCommentPos Int
y (if Bool
shouldRestoreIndent then Int
x else Int
0) Int
1
    BriDoc -> m ()
forall (m :: * -> *). LayoutConstraints m => BriDoc -> m ()
layoutBriDocM BriDoc
bd
  BDNonBottomSpacing Bool
_ BriDoc
bd -> BriDoc -> m ()
forall (m :: * -> *). LayoutConstraints m => BriDoc -> m ()
layoutBriDocM BriDoc
bd
  BDSetParSpacing    BriDoc
bd -> BriDoc -> m ()
forall (m :: * -> *). LayoutConstraints m => BriDoc -> m ()
layoutBriDocM BriDoc
bd
  BDForceParSpacing  BriDoc
bd -> BriDoc -> m ()
forall (m :: * -> *). LayoutConstraints m => BriDoc -> m ()
layoutBriDocM BriDoc
bd
  BDDebug String
s BriDoc
bd -> do
    Builder -> m ()
forall a (m :: * -> *). MonadMultiWriter a m => a -> m ()
mTell (Builder -> m ()) -> Builder -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> Builder
Text.Builder.fromText (Text -> Builder) -> Text -> Builder
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"{-" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"-}"
    BriDoc -> m ()
forall (m :: * -> *). LayoutConstraints m => BriDoc -> m ()
layoutBriDocM BriDoc
bd

briDocLineLength :: BriDoc -> Int
briDocLineLength :: BriDoc -> Int
briDocLineLength BriDoc
briDoc = (State Bool Int -> Bool -> Int) -> Bool -> State Bool Int -> Int
forall a b c. (a -> b -> c) -> b -> a -> c
flip State Bool Int -> Bool -> Int
forall s a. State s a -> s -> a
StateS.evalState Bool
False (State Bool Int -> Int) -> State Bool Int -> Int
forall a b. (a -> b) -> a -> b
$ BriDoc -> State Bool Int
rec BriDoc
briDoc
                          -- the state encodes whether a separator was already
                          -- appended at the current position.
 where
  rec :: BriDoc -> State Bool Int
rec = \case
    BriDoc
BDEmpty                 -> Int -> State Bool Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> State Bool Int) -> Int -> State Bool Int
forall a b. (a -> b) -> a -> b
$ Int
0
    BDLit Text
t                 -> Bool -> StateT Bool Identity ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
StateS.put Bool
False StateT Bool Identity () -> Int -> State Bool Int
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Text -> Int
Text.length Text
t
    BDSeq [BriDoc]
bds               -> [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> StateT Bool Identity [Int] -> State Bool Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BriDoc -> State Bool Int
rec (BriDoc -> State Bool Int)
-> [BriDoc] -> StateT Bool Identity [Int]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
`mapM` [BriDoc]
bds
    BDCols ColSig
_ [BriDoc]
bds            -> [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> StateT Bool Identity [Int] -> State Bool Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BriDoc -> State Bool Int
rec (BriDoc -> State Bool Int)
-> [BriDoc] -> StateT Bool Identity [Int]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
`mapM` [BriDoc]
bds
    BriDoc
BDSeparator -> StateT Bool Identity Bool
forall (m :: * -> *) s. Monad m => StateT s m s
StateS.get StateT Bool Identity Bool
-> (Bool -> State Bool Int) -> State Bool Int
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
b -> Bool -> StateT Bool Identity ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
StateS.put Bool
True StateT Bool Identity () -> Int -> State Bool Int
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> if Bool
b then Int
0 else Int
1
    BDAddBaseY BrIndent
_ BriDoc
bd         -> BriDoc -> State Bool Int
rec BriDoc
bd
    BDBaseYPushCur       BriDoc
bd -> BriDoc -> State Bool Int
rec BriDoc
bd
    BDBaseYPop           BriDoc
bd -> BriDoc -> State Bool Int
rec BriDoc
bd
    BDIndentLevelPushCur BriDoc
bd -> BriDoc -> State Bool Int
rec BriDoc
bd
    BDIndentLevelPop     BriDoc
bd -> BriDoc -> State Bool Int
rec BriDoc
bd
    BDPar BrIndent
_ BriDoc
line BriDoc
_          -> BriDoc -> State Bool Int
rec BriDoc
line
    BDAlt{}                 -> String -> State Bool Int
forall a. HasCallStack => String -> a
error String
"briDocLineLength BDAlt"
    BDForceMultiline  BriDoc
bd    -> BriDoc -> State Bool Int
rec BriDoc
bd
    BDForceSingleline BriDoc
bd    -> BriDoc -> State Bool Int
rec BriDoc
bd
    BDForwardLineMode BriDoc
bd    -> BriDoc -> State Bool Int
rec BriDoc
bd
    BDExternal AnnKey
_ Set AnnKey
_ Bool
_ Text
t      -> Int -> State Bool Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> State Bool Int) -> Int -> State Bool Int
forall a b. (a -> b) -> a -> b
$ Text -> Int
Text.length Text
t
    BDPlain Text
t               -> Int -> State Bool Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> State Bool Int) -> Int -> State Bool Int
forall a b. (a -> b) -> a -> b
$ Text -> Int
Text.length Text
t
    BDAnnotationPrior AnnKey
_ BriDoc
bd  -> BriDoc -> State Bool Int
rec BriDoc
bd
    BDAnnotationKW AnnKey
_ Maybe AnnKeywordId
_ BriDoc
bd   -> BriDoc -> State Bool Int
rec BriDoc
bd
    BDAnnotationRest AnnKey
_ BriDoc
bd   -> BriDoc -> State Bool Int
rec BriDoc
bd
    BDMoveToKWDP AnnKey
_ AnnKeywordId
_ Bool
_ BriDoc
bd   -> BriDoc -> State Bool Int
rec BriDoc
bd
    BDLines ls :: [BriDoc]
ls@(BriDoc
_ : [BriDoc]
_)      -> do
      Bool
x <- StateT Bool Identity Bool
forall (m :: * -> *) s. Monad m => StateT s m s
StateS.get
      Int -> State Bool Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> State Bool Int) -> Int -> State Bool Int
forall a b. (a -> b) -> a -> b
$ [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ [BriDoc]
ls [BriDoc] -> (BriDoc -> Int) -> [Int]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \BriDoc
l -> State Bool Int -> Bool -> Int
forall s a. State s a -> s -> a
StateS.evalState (BriDoc -> State Bool Int
rec BriDoc
l) Bool
x
    BDLines []              -> String -> State Bool Int
forall a. HasCallStack => String -> a
error String
"briDocLineLength BDLines []"
    BDEnsureIndent BrIndent
_ BriDoc
bd     -> BriDoc -> State Bool Int
rec BriDoc
bd
    BDSetParSpacing   BriDoc
bd    -> BriDoc -> State Bool Int
rec BriDoc
bd
    BDForceParSpacing BriDoc
bd    -> BriDoc -> State Bool Int
rec BriDoc
bd
    BDNonBottomSpacing Bool
_ BriDoc
bd -> BriDoc -> State Bool Int
rec BriDoc
bd
    BDDebug            String
_ BriDoc
bd -> BriDoc -> State Bool Int
rec BriDoc
bd

briDocIsMultiLine :: BriDoc -> Bool
briDocIsMultiLine :: BriDoc -> Bool
briDocIsMultiLine BriDoc
briDoc = BriDoc -> Bool
rec BriDoc
briDoc
 where
  rec :: BriDoc -> Bool
  rec :: BriDoc -> Bool
rec = \case
    BriDoc
BDEmpty                                  -> Bool
False
    BDLit Text
_                                  -> Bool
False
    BDSeq [BriDoc]
bds                                -> (BriDoc -> Bool) -> [BriDoc] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any BriDoc -> Bool
rec [BriDoc]
bds
    BDCols ColSig
_ [BriDoc]
bds                             -> (BriDoc -> Bool) -> [BriDoc] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any BriDoc -> Bool
rec [BriDoc]
bds
    BriDoc
BDSeparator                              -> Bool
False
    BDAddBaseY BrIndent
_ BriDoc
bd                          -> BriDoc -> Bool
rec BriDoc
bd
    BDBaseYPushCur       BriDoc
bd                  -> BriDoc -> Bool
rec BriDoc
bd
    BDBaseYPop           BriDoc
bd                  -> BriDoc -> Bool
rec BriDoc
bd
    BDIndentLevelPushCur BriDoc
bd                  -> BriDoc -> Bool
rec BriDoc
bd
    BDIndentLevelPop     BriDoc
bd                  -> BriDoc -> Bool
rec BriDoc
bd
    BDPar BrIndent
_ BriDoc
_ BriDoc
_                              -> Bool
True
    BDAlt{}                                  -> String -> Bool
forall a. HasCallStack => String -> a
error String
"briDocIsMultiLine BDAlt"
    BDForceMultiline  BriDoc
_                      -> Bool
True
    BDForceSingleline BriDoc
bd                     -> BriDoc -> Bool
rec BriDoc
bd
    BDForwardLineMode BriDoc
bd                     -> BriDoc -> Bool
rec BriDoc
bd
    BDExternal AnnKey
_ Set AnnKey
_ Bool
_ Text
t | [Text
_] <- Text -> [Text]
Text.lines Text
t -> Bool
False
    BDExternal AnnKey
_ Set AnnKey
_ Bool
_ Text
_                       -> Bool
True
    BDPlain Text
t | [Text
_] <- Text -> [Text]
Text.lines Text
t          -> Bool
False
    BDPlain Text
_                                -> Bool
True
    BDAnnotationPrior AnnKey
_ BriDoc
bd                   -> BriDoc -> Bool
rec BriDoc
bd
    BDAnnotationKW AnnKey
_ Maybe AnnKeywordId
_ BriDoc
bd                    -> BriDoc -> Bool
rec BriDoc
bd
    BDAnnotationRest AnnKey
_ BriDoc
bd                    -> BriDoc -> Bool
rec BriDoc
bd
    BDMoveToKWDP AnnKey
_ AnnKeywordId
_ Bool
_ BriDoc
bd                    -> BriDoc -> Bool
rec BriDoc
bd
    BDLines (BriDoc
_ : BriDoc
_ : [BriDoc]
_)                      -> Bool
True
    BDLines [BriDoc
_        ]                      -> Bool
False
    BDLines [] -> String -> Bool
forall a. HasCallStack => String -> a
error String
"briDocIsMultiLine BDLines []"
    BDEnsureIndent BrIndent
_ BriDoc
bd                      -> BriDoc -> Bool
rec BriDoc
bd
    BDSetParSpacing   BriDoc
bd                     -> BriDoc -> Bool
rec BriDoc
bd
    BDForceParSpacing BriDoc
bd                     -> BriDoc -> Bool
rec BriDoc
bd
    BDNonBottomSpacing Bool
_ BriDoc
bd                  -> BriDoc -> Bool
rec BriDoc
bd
    BDDebug            String
_ BriDoc
bd                  -> BriDoc -> Bool
rec BriDoc
bd

-- In theory
-- =========

-- .. this algorithm works roughly in these steps:
--
-- 1. For each line, get the (nested) column info, descending as far as
--    BDCols nodes go. The column info is a (rose) tree where the leafs
--    are arbitrary (non-BDCols) BriDocs.
-- 2. Walk through the lines and compare its column info with that of its
--    predecessor. If both are non-leafs and the column "signatures" align
--    (they don't align e.g. when they are totally different syntactical
--    structures or the number of children differs), mark these parts of
--    the two tree structures as connected and recurse to its children
--    (i.e. again comparing the children in this line with the children in
--    the previous line).
-- 3. What we now have is one tree per line, and connections between "same"
--    nodes between lines. These connection can span multiple lines.
--    We next look at spacing information. This is available at the leafs,
--    but in this step we aggregate _over connections_. At the top level, this
--    gives us one piece of data: How long would each line be, if we fully
--    aligned everything (kept all connections "active"). In contrast to
--    just taking the sum of all leafs for each tree, this line length includes
--    the spaces used for alignment.
-- 4. Treat those lines where alignment would result in overflowing of the
--    column limit. This "treatment" is currently configurable, and can e.g.
--    mean:
--    a) we stop alignment alltogether,
--    b) we remove alignment just from the overflowing lines,
--    c) we reduce the number of spaces inserted in overflowing lines using
--       some technique to make them not overflow, but without reducing the
--       space insertion to zero,
--    d) don't do anything
-- 5. Actually print the lines, walking over each tree and inserting spaces
--    according to the info and decisions gathered in the previous steps.
--
-- Possible improvements
-- =====================
--
-- - If alignment is disabled for specific lines, the aggregated per-connection
--   info of those lines is still retained and not recalculated. This can
--   result in spaces being inserted to create alignment with a line that
--   would overflow and thus gets disabled entirely.
--   An better approach would be to repeat step 3 after marking overflowing
--   lines as such, and not include the overflowing spacings as references
--   for non-overflowing ones. In the simplest case one additional iteration
--   would suffice, e.g. 1-2-3-4-3-5, but it would also be possible to refine
--   this and first remove alignment in the deepest parts of the tree for
--   overflowing lines, repeating and moving upwards until no lines are
--   anymore overflowing.
--   Further, it may make sense to break up connections when overflowing would
--   occur.
-- - It may also make sense to not filter all overflowing lines, but remove
--   them one-by-one and in each step recalculate the aggregated connection
--   spacing info. Because removing one overflowing line from the calculation
--   may very well cause another previously overflowing line to not overflow
--   any longer.
--   There is also a nasty optimization problem hiding in there (find the
--   minimal amount of alignment disabling that results in no overflows)
--   but that is overkill.
--
--   (with both these improvements there would be quite some repetition between
--   steps 3 and 4, but it should be possible to ensure termination. Still,
--   performance might become an issue as such an approach is not necessarily
--   linear in bridoc size any more.)
--
-- In practice
-- ===========
--
-- .. the current implementation is somewhat sloppy. Steps 1 and 2
-- are executed in one step, step 3 already applies one strategy that disables
-- certain connections (see `_lconfig_alignmentLimit`) and step 4 does some
-- of the calculations one might expect to occur in step 3. Steps 4 and 5
-- are executed in the same recursion, too.
-- Also, _lconfig_alignmentLimit really is itself a hack that hides the issue
-- mentioned in the first "possible improvement".
alignColsLines :: LayoutConstraints m => [BriDoc] -> m ()
alignColsLines :: [BriDoc] -> m ()
alignColsLines [BriDoc]
bridocs = do -- colInfos `forM_` \colInfo -> do
  -- tellDebugMess ("alignColsLines: at " ++ take 100 (show $ briDocToDoc $ head bridocs))
  Int
curX <- do
    LayoutState
state <- m LayoutState
forall a (m :: * -> *). MonadMultiGet a m => m a
mGet
    Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> m Int) -> Int -> m Int
forall a b. (a -> b) -> a -> b
$ (Int -> Int) -> (Int -> Int) -> Either Int Int -> Int
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Int -> Int
forall a. a -> a
id (Int -> Int -> Int
forall a b. a -> b -> a
const Int
0) (LayoutState -> Either Int Int
_lstate_curYOrAddNewline LayoutState
state) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe
      Int
0
      (LayoutState -> Maybe Int
_lstate_addSepSpace LayoutState
state)
  Int
colMax     <- m Config
forall a (m :: * -> *). MonadMultiReader a m => m a
mAsk m Config -> (Config -> Int) -> m Int
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Config -> CLayoutConfig Identity
forall (f :: * -> *). CConfig f -> CLayoutConfig f
_conf_layout (Config -> CLayoutConfig Identity)
-> (CLayoutConfig Identity -> Identity (Last Int))
-> Config
-> Identity (Last Int)
forall a b c. (a -> b) -> (b -> c) -> a -> c
.> CLayoutConfig Identity -> Identity (Last Int)
forall (f :: * -> *). CLayoutConfig f -> f (Last Int)
_lconfig_cols (Config -> Identity (Last Int))
-> (Identity (Last Int) -> Int) -> Config -> Int
forall a b c. (a -> b) -> (b -> c) -> a -> c
.> Identity (Last Int) -> Int
forall a b. Coercible a b => Identity a -> b
confUnpack
  Int
alignMax   <- m Config
forall a (m :: * -> *). MonadMultiReader a m => m a
mAsk m Config -> (Config -> Int) -> m Int
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Config -> CLayoutConfig Identity
forall (f :: * -> *). CConfig f -> CLayoutConfig f
_conf_layout (Config -> CLayoutConfig Identity)
-> (CLayoutConfig Identity -> Identity (Last Int))
-> Config
-> Identity (Last Int)
forall a b c. (a -> b) -> (b -> c) -> a -> c
.> CLayoutConfig Identity -> Identity (Last Int)
forall (f :: * -> *). CLayoutConfig f -> f (Last Int)
_lconfig_alignmentLimit (Config -> Identity (Last Int))
-> (Identity (Last Int) -> Int) -> Config -> Int
forall a b c. (a -> b) -> (b -> c) -> a -> c
.> Identity (Last Int) -> Int
forall a b. Coercible a b => Identity a -> b
confUnpack
  Bool
alignBreak <-
    m Config
forall a (m :: * -> *). MonadMultiReader a m => m a
mAsk m Config -> (Config -> Bool) -> m Bool
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Config -> CLayoutConfig Identity
forall (f :: * -> *). CConfig f -> CLayoutConfig f
_conf_layout (Config -> CLayoutConfig Identity)
-> (CLayoutConfig Identity -> Identity (Last Bool))
-> Config
-> Identity (Last Bool)
forall a b c. (a -> b) -> (b -> c) -> a -> c
.> CLayoutConfig Identity -> Identity (Last Bool)
forall (f :: * -> *). CLayoutConfig f -> f (Last Bool)
_lconfig_alignmentBreakOnMultiline (Config -> Identity (Last Bool))
-> (Identity (Last Bool) -> Bool) -> Config -> Bool
forall a b c. (a -> b) -> (b -> c) -> a -> c
.> Identity (Last Bool) -> Bool
forall a b. Coercible a b => Identity a -> b
confUnpack
  case () of
    ()
_ -> do
      -- tellDebugMess ("processedMap: " ++ show processedMap)
      [m ()] -> m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
        ([m ()] -> m ()) -> [m ()] -> m ()
forall a b. (a -> b) -> a -> b
$   m () -> [m ()] -> [m ()]
forall a. a -> [a] -> [a]
List.intersperse m ()
forall (m :: * -> *).
(MonadMultiWriter Builder m, MonadMultiState LayoutState m,
 MonadMultiWriter (Seq String) m) =>
m ()
layoutWriteEnsureNewlineBlock
        ([m ()] -> [m ()]) -> [m ()] -> [m ()]
forall a b. (a -> b) -> a -> b
$   [ColInfo]
colInfos
        [ColInfo] -> (ColInfo -> m ()) -> [m ()]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Int -> ColMap2 -> ColInfo -> m ()
forall (m :: * -> *).
LayoutConstraints m =>
Int -> ColMap2 -> ColInfo -> m ()
processInfo Int
colMax ColMap2
processedMap
     where
      ([ColInfo]
colInfos, ColBuildState
finalState) =
        State ColBuildState [ColInfo]
-> ColBuildState -> ([ColInfo], ColBuildState)
forall s a. State s a -> s -> (a, s)
StateS.runState ([BriDoc] -> State ColBuildState [ColInfo]
mergeBriDocs [BriDoc]
bridocs) (ColMap1 -> Int -> ColBuildState
ColBuildState ColMap1
forall a. IntMap a
IntMapS.empty Int
0)
      -- maxZipper :: [Int] -> [Int] -> [Int]
      -- maxZipper [] ys = ys
      -- maxZipper xs [] = xs
      -- maxZipper (x:xr) (y:yr) = max x y : maxZipper xr yr
      colAggregation :: [Int] -> Int
      colAggregation :: [Int] -> Int
colAggregation [] = Int
0 -- this probably cannot happen the way we call
                            -- this function, because _cbs_map only ever
                            -- contains nonempty Seqs.
      colAggregation [Int]
xs = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [ Int
x | Int
x <- [Int]
xs, Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [Int]
xs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
alignMax' ]
        where alignMax' :: Int
alignMax' = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 Int
alignMax

      processedMap :: ColMap2
      processedMap :: ColMap2
processedMap =
        (ColMap2 -> ColMap2) -> ColMap2
forall a. (a -> a) -> a
fix ((ColMap2 -> ColMap2) -> ColMap2)
-> (ColMap2 -> ColMap2) -> ColMap2
forall a b. (a -> b) -> a -> b
$ \ColMap2
result -> ColBuildState -> ColMap1
_cbs_map ColBuildState
finalState ColMap1
-> ((Bool, ColumnBlocks ColumnSpacing)
    -> (Float, [Int], Seq [Int]))
-> ColMap2
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(Bool
lastFlag, ColumnBlocks ColumnSpacing
colSpacingss) ->
          let
            colss :: Seq [Int]
colss = ColumnBlocks ColumnSpacing
colSpacingss ColumnBlocks ColumnSpacing
-> ([ColumnSpacing] -> [Int]) -> Seq [Int]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \[ColumnSpacing]
spss -> case [ColumnSpacing] -> [ColumnSpacing]
forall a. [a] -> [a]
reverse [ColumnSpacing]
spss of
              [] -> []
              (ColumnSpacing
xN:[ColumnSpacing]
xR) ->
                [Int] -> [Int]
forall a. [a] -> [a]
reverse ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ (if Bool
lastFlag then ColumnSpacing -> Int
fLast else ColumnSpacing -> Int
fInit) ColumnSpacing
xN Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: (ColumnSpacing -> Int) -> [ColumnSpacing] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ColumnSpacing -> Int
fInit [ColumnSpacing]
xR
             where
              fLast :: ColumnSpacing -> Int
fLast (ColumnSpacingLeaf Int
len ) = Int
len
              fLast (ColumnSpacingRef Int
len Int
_) = Int
len
              fInit :: ColumnSpacing -> Int
fInit (ColumnSpacingLeaf Int
len) = Int
len
              fInit (ColumnSpacingRef Int
_ Int
i ) = case Int -> ColMap2 -> Maybe (Float, [Int], Seq [Int])
forall a. Int -> IntMap a -> Maybe a
IntMapL.lookup Int
i ColMap2
result of
                Maybe (Float, [Int], Seq [Int])
Nothing           -> Int
0
                Just (Float
_, [Int]
maxs, Seq [Int]
_) -> [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int]
maxs
            maxCols :: [Int]
maxCols = {-Foldable.foldl1 maxZipper-}
              ([Int] -> Int) -> [[Int]] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Int] -> Int
colAggregation ([[Int]] -> [Int]) -> [[Int]] -> [Int]
forall a b. (a -> b) -> a -> b
$ [[Int]] -> [[Int]]
forall a. [[a]] -> [[a]]
transpose ([[Int]] -> [[Int]]) -> [[Int]] -> [[Int]]
forall a b. (a -> b) -> a -> b
$ Seq [Int] -> [[Int]]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList Seq [Int]
colss
            (Int
_, [Int]
posXs) = -- trace ("colss=" ++ show colss ++ ", maxCols=" ++ show maxCols ++ " for " ++ take 100 (show $ briDocToDoc $ head bridocs)) $
                         (Int -> Int -> (Int, Int)) -> Int -> [Int] -> (Int, [Int])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL (\Int
acc Int
x -> (Int
acc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
x, Int
acc)) Int
curX [Int]
maxCols
            counter :: Int -> [Int] -> Int
counter Int
count [Int]
l = if [Int] -> Int
forall a. [a] -> a
List.last [Int]
posXs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Int] -> Int
forall a. [a] -> a
List.last [Int]
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
colMax
              then Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
              else Int
count
            ratio :: Float
ratio = Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Int -> [Int] -> Int) -> Int -> Seq [Int] -> Int
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Int -> [Int] -> Int
counter (Int
0 :: Int) Seq [Int]
colss)
              Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Seq [Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Seq [Int]
colss)
          in
            (Float
ratio, [Int]
maxCols, Seq [Int]
colss)

      mergeBriDocs :: [BriDoc] -> StateS.State ColBuildState [ColInfo]
      mergeBriDocs :: [BriDoc] -> State ColBuildState [ColInfo]
mergeBriDocs [BriDoc]
bds = ColInfo -> [BriDoc] -> State ColBuildState [ColInfo]
mergeBriDocsW ColInfo
ColInfoStart [BriDoc]
bds

      mergeBriDocsW
        :: ColInfo -> [BriDoc] -> StateS.State ColBuildState [ColInfo]
      mergeBriDocsW :: ColInfo -> [BriDoc] -> State ColBuildState [ColInfo]
mergeBriDocsW ColInfo
_        []       = [ColInfo] -> State ColBuildState [ColInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return []
      mergeBriDocsW ColInfo
lastInfo (BriDoc
bd:[BriDoc]
bdr) = do
        ColInfo
info  <- Bool -> ColInfo -> BriDoc -> StateT ColBuildState Identity ColInfo
mergeInfoBriDoc Bool
True ColInfo
lastInfo BriDoc
bd
        [ColInfo]
infor <- ColInfo -> [BriDoc] -> State ColBuildState [ColInfo]
mergeBriDocsW
          -- (if alignBreak && briDocIsMultiLine bd then ColInfoStart else info)
          (if BriDoc -> Bool
shouldBreakAfter BriDoc
bd then ColInfo
ColInfoStart else ColInfo
info)
          [BriDoc]
bdr
        [ColInfo] -> State ColBuildState [ColInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return ([ColInfo] -> State ColBuildState [ColInfo])
-> [ColInfo] -> State ColBuildState [ColInfo]
forall a b. (a -> b) -> a -> b
$ ColInfo
info ColInfo -> [ColInfo] -> [ColInfo]
forall a. a -> [a] -> [a]
: [ColInfo]
infor

      -- even with alignBreak config flag, we don't stop aligning for certain
      -- ColSigs - the ones with "False" below. The main reason is that
      -- there are uses of BDCols where they provide the alignment of several
      -- consecutive full larger code segments, for example ColOpPrefix.
      -- Motivating example is
      -- > foo
      -- >   $  [ aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa
      -- >      , bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb
      -- >      ]
      -- >   ++ [ ccccccccccccccccccccccccccccccccccccccccccccccccccccccccc ]
      -- If we break the alignment here, then all three lines for the first
      -- list move left by one, which is horrible. We really don't want to
      -- break whole-block alignments.
      -- For list, listcomp, tuple and tuples the reasoning is much simpler:
      -- alignment should not have much effect anyways, so i simply make the
      -- choice here that enabling alignment is the safer route for preventing
      -- potential glitches, and it should never have a negative effect.
      -- For RecUpdate the argument is much less clear - it is mostly a
      -- personal preference to not break alignment for those, even if
      -- multiline. Really, this should be configurable.. (TODO)
      shouldBreakAfter :: BriDoc -> Bool
      shouldBreakAfter :: BriDoc -> Bool
shouldBreakAfter BriDoc
bd = if Bool
alignBreak
        then BriDoc -> Bool
briDocIsMultiLine BriDoc
bd Bool -> Bool -> Bool
&& case BriDoc
bd of
          (BDCols ColSig
ColTyOpPrefix         [BriDoc]
_) -> Bool
False
          (BDCols ColSig
ColPatternsFuncPrefix [BriDoc]
_) -> Bool
True
          (BDCols ColSig
ColPatternsFuncInfix  [BriDoc]
_) -> Bool
True
          (BDCols ColSig
ColPatterns           [BriDoc]
_) -> Bool
True
          (BDCols ColSig
ColCasePattern        [BriDoc]
_) -> Bool
True
          (BDCols ColBindingLine{}      [BriDoc]
_) -> Bool
True
          (BDCols ColSig
ColGuard              [BriDoc]
_) -> Bool
True
          (BDCols ColSig
ColGuardedBody        [BriDoc]
_) -> Bool
True
          (BDCols ColSig
ColBindStmt           [BriDoc]
_) -> Bool
True
          (BDCols ColSig
ColDoLet              [BriDoc]
_) -> Bool
True
          (BDCols ColSig
ColRec                [BriDoc]
_) -> Bool
False
          (BDCols ColSig
ColRecUpdate          [BriDoc]
_) -> Bool
False
          (BDCols ColSig
ColRecDecl            [BriDoc]
_) -> Bool
False
          (BDCols ColSig
ColListComp           [BriDoc]
_) -> Bool
False
          (BDCols ColSig
ColList               [BriDoc]
_) -> Bool
False
          (BDCols ColApp{}              [BriDoc]
_) -> Bool
True
          (BDCols ColSig
ColTuple              [BriDoc]
_) -> Bool
False
          (BDCols ColSig
ColTuples             [BriDoc]
_) -> Bool
False
          (BDCols ColSig
ColOpPrefix           [BriDoc]
_) -> Bool
False
          BriDoc
_                                -> Bool
True
        else Bool
False

      mergeInfoBriDoc
        :: Bool
        -> ColInfo
        -> BriDoc
        -> StateS.StateT ColBuildState Identity ColInfo
      mergeInfoBriDoc :: Bool -> ColInfo -> BriDoc -> StateT ColBuildState Identity ColInfo
mergeInfoBriDoc Bool
lastFlag ColInfo
ColInfoStart = Bool -> BriDoc -> StateT ColBuildState Identity ColInfo
briDocToColInfo Bool
lastFlag
      mergeInfoBriDoc Bool
lastFlag ColInfoNo{}  = Bool -> BriDoc -> StateT ColBuildState Identity ColInfo
briDocToColInfo Bool
lastFlag
      mergeInfoBriDoc Bool
lastFlag (ColInfo Int
infoInd ColSig
infoSig [(Int, ColInfo)]
subLengthsInfos) =
        \case
          brdc :: BriDoc
brdc@(BDCols ColSig
colSig [BriDoc]
subDocs)
            | ColSig
infoSig ColSig -> ColSig -> Bool
forall a. Eq a => a -> a -> Bool
== ColSig
colSig Bool -> Bool -> Bool
&& [(Int, ColInfo)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, ColInfo)]
subLengthsInfos Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [BriDoc] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BriDoc]
subDocs
            -> do
              let
                isLastList :: [Bool]
isLastList = if Bool
lastFlag
                  then (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==[BriDoc] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BriDoc]
subDocs) (Int -> Bool) -> [Int] -> [Bool]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int
1 ..]
                  else Bool -> [Bool]
forall a. a -> [a]
repeat Bool
False
              [ColInfo]
infos <- [Bool] -> [ColInfo] -> [BriDoc] -> [(Bool, ColInfo, BriDoc)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Bool]
isLastList ((Int, ColInfo) -> ColInfo
forall a b. (a, b) -> b
snd ((Int, ColInfo) -> ColInfo) -> [(Int, ColInfo)] -> [ColInfo]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int, ColInfo)]
subLengthsInfos) [BriDoc]
subDocs
                [(Bool, ColInfo, BriDoc)]
-> ((Bool, ColInfo, BriDoc)
    -> StateT ColBuildState Identity ColInfo)
-> State ColBuildState [ColInfo]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
`forM` \(Bool
lf, ColInfo
info, BriDoc
bd) -> Bool -> ColInfo -> BriDoc -> StateT ColBuildState Identity ColInfo
mergeInfoBriDoc Bool
lf ColInfo
info BriDoc
bd
              let curLengths :: [Int]
curLengths   = BriDoc -> Int
briDocLineLength (BriDoc -> Int) -> [BriDoc] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [BriDoc]
subDocs
              let trueSpacings :: [ColumnSpacing]
trueSpacings = [(Int, ColInfo)] -> [ColumnSpacing]
getTrueSpacings ([Int] -> [ColInfo] -> [(Int, ColInfo)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
curLengths [ColInfo]
infos)
              do -- update map
                ColBuildState
s <- StateT ColBuildState Identity ColBuildState
forall (m :: * -> *) s. Monad m => StateT s m s
StateS.get
                let m :: ColMap1
m                  = ColBuildState -> ColMap1
_cbs_map ColBuildState
s
                let (Just (Bool
_, ColumnBlocks ColumnSpacing
spaces)) = Int -> ColMap1 -> Maybe (Bool, ColumnBlocks ColumnSpacing)
forall a. Int -> IntMap a -> Maybe a
IntMapS.lookup Int
infoInd ColMap1
m
                ColBuildState -> StateT ColBuildState Identity ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
StateS.put ColBuildState
s
                  { _cbs_map :: ColMap1
_cbs_map = Int -> (Bool, ColumnBlocks ColumnSpacing) -> ColMap1 -> ColMap1
forall a. Int -> a -> IntMap a -> IntMap a
IntMapS.insert
                    Int
infoInd
                    (Bool
lastFlag, ColumnBlocks ColumnSpacing
spaces ColumnBlocks ColumnSpacing
-> [ColumnSpacing] -> ColumnBlocks ColumnSpacing
forall a. Seq a -> a -> Seq a
Seq.|> [ColumnSpacing]
trueSpacings)
                    ColMap1
m
                  }
              ColInfo -> StateT ColBuildState Identity ColInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (ColInfo -> StateT ColBuildState Identity ColInfo)
-> ColInfo -> StateT ColBuildState Identity ColInfo
forall a b. (a -> b) -> a -> b
$ Int -> ColSig -> [(Int, ColInfo)] -> ColInfo
ColInfo Int
infoInd ColSig
colSig ([Int] -> [ColInfo] -> [(Int, ColInfo)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
curLengths [ColInfo]
infos)
            | Bool
otherwise
            -> Bool -> BriDoc -> StateT ColBuildState Identity ColInfo
briDocToColInfo Bool
lastFlag BriDoc
brdc
          BriDoc
brdc -> ColInfo -> StateT ColBuildState Identity ColInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (ColInfo -> StateT ColBuildState Identity ColInfo)
-> ColInfo -> StateT ColBuildState Identity ColInfo
forall a b. (a -> b) -> a -> b
$ BriDoc -> ColInfo
ColInfoNo BriDoc
brdc

briDocToColInfo :: Bool -> BriDoc -> StateS.State ColBuildState ColInfo
briDocToColInfo :: Bool -> BriDoc -> StateT ColBuildState Identity ColInfo
briDocToColInfo Bool
lastFlag = \case
  BDCols ColSig
sig [BriDoc]
list -> Bool
-> (Int
    -> State ColBuildState (ColumnBlocks ColumnSpacing, ColInfo))
-> StateT ColBuildState Identity ColInfo
withAlloc Bool
lastFlag ((Int -> State ColBuildState (ColumnBlocks ColumnSpacing, ColInfo))
 -> StateT ColBuildState Identity ColInfo)
-> (Int
    -> State ColBuildState (ColumnBlocks ColumnSpacing, ColInfo))
-> StateT ColBuildState Identity ColInfo
forall a b. (a -> b) -> a -> b
$ \Int
ind -> do
    let isLastList :: [Bool]
isLastList =
          if Bool
lastFlag then (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==[BriDoc] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BriDoc]
list) (Int -> Bool) -> [Int] -> [Bool]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int
1 ..] else Bool -> [Bool]
forall a. a -> [a]
repeat Bool
False
    [ColInfo]
subInfos <- [Bool] -> [BriDoc] -> [(Bool, BriDoc)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Bool]
isLastList [BriDoc]
list [(Bool, BriDoc)]
-> ((Bool, BriDoc) -> StateT ColBuildState Identity ColInfo)
-> State ColBuildState [ColInfo]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
`forM` (Bool -> BriDoc -> StateT ColBuildState Identity ColInfo)
-> (Bool, BriDoc) -> StateT ColBuildState Identity ColInfo
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Bool -> BriDoc -> StateT ColBuildState Identity ColInfo
briDocToColInfo
    let lengthInfos :: [(Int, ColInfo)]
lengthInfos  = [Int] -> [ColInfo] -> [(Int, ColInfo)]
forall a b. [a] -> [b] -> [(a, b)]
zip (BriDoc -> Int
briDocLineLength (BriDoc -> Int) -> [BriDoc] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [BriDoc]
list) [ColInfo]
subInfos
    let trueSpacings :: [ColumnSpacing]
trueSpacings = [(Int, ColInfo)] -> [ColumnSpacing]
getTrueSpacings [(Int, ColInfo)]
lengthInfos
    (ColumnBlocks ColumnSpacing, ColInfo)
-> State ColBuildState (ColumnBlocks ColumnSpacing, ColInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return ((ColumnBlocks ColumnSpacing, ColInfo)
 -> State ColBuildState (ColumnBlocks ColumnSpacing, ColInfo))
-> (ColumnBlocks ColumnSpacing, ColInfo)
-> State ColBuildState (ColumnBlocks ColumnSpacing, ColInfo)
forall a b. (a -> b) -> a -> b
$ ([ColumnSpacing] -> ColumnBlocks ColumnSpacing
forall a. a -> Seq a
Seq.singleton [ColumnSpacing]
trueSpacings, Int -> ColSig -> [(Int, ColInfo)] -> ColInfo
ColInfo Int
ind ColSig
sig [(Int, ColInfo)]
lengthInfos)
  BriDoc
bd -> ColInfo -> StateT ColBuildState Identity ColInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (ColInfo -> StateT ColBuildState Identity ColInfo)
-> ColInfo -> StateT ColBuildState Identity ColInfo
forall a b. (a -> b) -> a -> b
$ BriDoc -> ColInfo
ColInfoNo BriDoc
bd

getTrueSpacings :: [(Int, ColInfo)] -> [ColumnSpacing]
getTrueSpacings :: [(Int, ColInfo)] -> [ColumnSpacing]
getTrueSpacings [(Int, ColInfo)]
lengthInfos = [(Int, ColInfo)]
lengthInfos [(Int, ColInfo)]
-> ((Int, ColInfo) -> ColumnSpacing) -> [ColumnSpacing]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
  (Int
len, ColInfo Int
i ColSig
_ [(Int, ColInfo)]
_) -> Int -> Int -> ColumnSpacing
ColumnSpacingRef Int
len Int
i
  (Int
len, ColInfo
_            ) -> Int -> ColumnSpacing
ColumnSpacingLeaf Int
len

withAlloc
  :: Bool
  -> (  ColIndex
     -> StateS.State ColBuildState (ColumnBlocks ColumnSpacing, ColInfo)
     )
  -> StateS.State ColBuildState ColInfo
withAlloc :: Bool
-> (Int
    -> State ColBuildState (ColumnBlocks ColumnSpacing, ColInfo))
-> StateT ColBuildState Identity ColInfo
withAlloc Bool
lastFlag Int -> State ColBuildState (ColumnBlocks ColumnSpacing, ColInfo)
f = do
  ColBuildState
cbs <- StateT ColBuildState Identity ColBuildState
forall (m :: * -> *) s. Monad m => StateT s m s
StateS.get
  let ind :: Int
ind = ColBuildState -> Int
_cbs_index ColBuildState
cbs
  ColBuildState -> StateT ColBuildState Identity ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
StateS.put (ColBuildState -> StateT ColBuildState Identity ())
-> ColBuildState -> StateT ColBuildState Identity ()
forall a b. (a -> b) -> a -> b
$ ColBuildState
cbs { _cbs_index :: Int
_cbs_index = Int
ind Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 }
  (ColumnBlocks ColumnSpacing
space, ColInfo
info) <- Int -> State ColBuildState (ColumnBlocks ColumnSpacing, ColInfo)
f Int
ind
  StateT ColBuildState Identity ColBuildState
forall (m :: * -> *) s. Monad m => StateT s m s
StateS.get StateT ColBuildState Identity ColBuildState
-> (ColBuildState -> StateT ColBuildState Identity ())
-> StateT ColBuildState Identity ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ColBuildState
c -> ColBuildState -> StateT ColBuildState Identity ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
StateS.put
    (ColBuildState -> StateT ColBuildState Identity ())
-> ColBuildState -> StateT ColBuildState Identity ()
forall a b. (a -> b) -> a -> b
$ ColBuildState
c { _cbs_map :: ColMap1
_cbs_map = Int -> (Bool, ColumnBlocks ColumnSpacing) -> ColMap1 -> ColMap1
forall a. Int -> a -> IntMap a -> IntMap a
IntMapS.insert Int
ind (Bool
lastFlag, ColumnBlocks ColumnSpacing
space) (ColMap1 -> ColMap1) -> ColMap1 -> ColMap1
forall a b. (a -> b) -> a -> b
$ ColBuildState -> ColMap1
_cbs_map ColBuildState
c }
  ColInfo -> StateT ColBuildState Identity ColInfo
forall (m :: * -> *) a. Monad m => a -> m a
return ColInfo
info

processInfo :: LayoutConstraints m => Int -> ColMap2 -> ColInfo -> m ()
processInfo :: Int -> ColMap2 -> ColInfo -> m ()
processInfo Int
maxSpace ColMap2
m = \case
  ColInfo
ColInfoStart       -> String -> m ()
forall a. HasCallStack => String -> a
error String
"should not happen (TM)"
  ColInfoNo BriDoc
doc      -> BriDoc -> m ()
forall (m :: * -> *). LayoutConstraints m => BriDoc -> m ()
layoutBriDocM BriDoc
doc
  ColInfo Int
ind ColSig
_ [(Int, ColInfo)]
list -> -- trace ("processInfo ind=" ++ show ind ++ ", list=" ++ show list ++ ", colmap=" ++ show m) $
                        do
    Int
colMaxConf <- m Config
forall a (m :: * -> *). MonadMultiReader a m => m a
mAsk m Config -> (Config -> Int) -> m Int
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Config -> CLayoutConfig Identity
forall (f :: * -> *). CConfig f -> CLayoutConfig f
_conf_layout (Config -> CLayoutConfig Identity)
-> (CLayoutConfig Identity -> Identity (Last Int))
-> Config
-> Identity (Last Int)
forall a b c. (a -> b) -> (b -> c) -> a -> c
.> CLayoutConfig Identity -> Identity (Last Int)
forall (f :: * -> *). CLayoutConfig f -> f (Last Int)
_lconfig_cols (Config -> Identity (Last Int))
-> (Identity (Last Int) -> Int) -> Config -> Int
forall a b c. (a -> b) -> (b -> c) -> a -> c
.> Identity (Last Int) -> Int
forall a b. Coercible a b => Identity a -> b
confUnpack
    ColumnAlignMode
alignMode <- m Config
forall a (m :: * -> *). MonadMultiReader a m => m a
mAsk m Config -> (Config -> ColumnAlignMode) -> m ColumnAlignMode
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Config -> CLayoutConfig Identity
forall (f :: * -> *). CConfig f -> CLayoutConfig f
_conf_layout (Config -> CLayoutConfig Identity)
-> (CLayoutConfig Identity -> Identity (Last ColumnAlignMode))
-> Config
-> Identity (Last ColumnAlignMode)
forall a b c. (a -> b) -> (b -> c) -> a -> c
.> CLayoutConfig Identity -> Identity (Last ColumnAlignMode)
forall (f :: * -> *). CLayoutConfig f -> f (Last ColumnAlignMode)
_lconfig_columnAlignMode (Config -> Identity (Last ColumnAlignMode))
-> (Identity (Last ColumnAlignMode) -> ColumnAlignMode)
-> Config
-> ColumnAlignMode
forall a b c. (a -> b) -> (b -> c) -> a -> c
.> Identity (Last ColumnAlignMode) -> ColumnAlignMode
forall a b. Coercible a b => Identity a -> b
confUnpack
    Int
curX      <- do
      LayoutState
state <- m LayoutState
forall a (m :: * -> *). MonadMultiGet a m => m a
mGet
      -- tellDebugMess ("processInfo: " ++ show (_lstate_curYOrAddNewline state) ++ " - " ++ show ((_lstate_addSepSpace state)))
      let spaceAdd :: Int
spaceAdd = case LayoutState -> Maybe Int
_lstate_addSepSpace LayoutState
state of
            Maybe Int
Nothing -> Int
0
            Just Int
i -> Int
i
      Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> m Int) -> Int -> m Int
forall a b. (a -> b) -> a -> b
$ case LayoutState -> Either Int Int
_lstate_curYOrAddNewline LayoutState
state of
        Left Int
i -> case LayoutState -> Maybe Int
_lstate_commentCol LayoutState
state of
          Maybe Int
Nothing -> Int
spaceAdd Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i
          Just Int
c -> Int
c
        Right{} -> Int
spaceAdd
    let colMax :: Int
colMax = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
colMaxConf (Int
curX Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
maxSpace)
    -- tellDebugMess $ show curX
    let Just (Float
ratio, [Int]
maxCols1, Seq [Int]
_colss) = Int -> ColMap2 -> Maybe (Float, [Int], Seq [Int])
forall a. Int -> IntMap a -> Maybe a
IntMapS.lookup Int
ind ColMap2
m
    let maxCols2 :: [Int]
maxCols2 = [(Int, ColInfo)]
list [(Int, ColInfo)] -> ((Int, ColInfo) -> Int) -> [Int]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(Int, ColInfo)
e -> case (Int, ColInfo)
e of
          (Int
_, ColInfo Int
i ColSig
_ [(Int, ColInfo)]
_) ->
            let Just (Float
_, [Int]
ms, Seq [Int]
_) = Int -> ColMap2 -> Maybe (Float, [Int], Seq [Int])
forall a. Int -> IntMap a -> Maybe a
IntMapS.lookup Int
i ColMap2
m in [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int]
ms
          (Int
l, ColInfo
_) -> Int
l
    let maxCols :: [Int]
maxCols = (Int -> Int -> Int) -> [Int] -> [Int] -> [Int]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Int -> Int
forall a. Ord a => a -> a -> a
max [Int]
maxCols1 [Int]
maxCols2
    let (Int
maxX, [Int]
posXs) = (Int -> Int -> (Int, Int)) -> Int -> [Int] -> (Int, [Int])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL (\Int
acc Int
x -> (Int
acc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
x, Int
acc)) Int
curX [Int]
maxCols
    -- handle the cases that the vertical alignment leads to more than max
    -- cols:
    -- this is not a full fix, and we must correct individually in addition.
    -- because: the (at least) line with the largest element in the last
    -- column will always still overflow, because we just updated the column
    -- sizes in such a way that it works _if_ we have sizes (*factor)
    -- in each column. but in that line, in the last column, we will be
    -- forced to occupy the full vertical space, not reduced by any factor.
    let fixedPosXs :: [Int]
fixedPosXs = case ColumnAlignMode
alignMode of
          ColumnAlignModeAnimouslyScale Int
i | Int
maxX Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
colMax -> [Int]
fixed [Int] -> (Int -> Int) -> [Int]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
curX)
           where
            Float
factor :: Float =
              -- 0.0001 as an offering to the floating point gods.
                              Float -> Float -> Float
forall a. Ord a => a -> a -> a
min
              Float
1.0001
              (Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
colMax Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
curX) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
maxX Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
curX))
            offsets :: [Int]
offsets = (Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract Int
curX) (Int -> Int) -> [Int] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int]
posXs
            fixed :: [Int]
fixed   = [Int]
offsets [Int] -> (Int -> Int) -> [Int]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Float) -> (Float -> Float) -> Int -> Float
forall a b c. (a -> b) -> (b -> c) -> a -> c
.> (Float -> Float -> Float
forall a. Num a => a -> a -> a
*Float
factor) (Int -> Float) -> (Float -> Int) -> Int -> Int
forall a b c. (a -> b) -> (b -> c) -> a -> c
.> Float -> Int
forall a b. (RealFrac a, Integral b) => a -> b
truncate
          ColumnAlignMode
_ -> [Int]
posXs
    let spacings :: [Int]
spacings = (Int -> Int -> Int) -> [Int] -> [Int] -> [Int]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (-)
                           ([Int] -> [Int]
forall a. [a] -> [a]
List.tail [Int]
fixedPosXs [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
maxX Int
colMax])
                           [Int]
fixedPosXs
    -- tellDebugMess $ "ind = " ++ show ind
    -- tellDebugMess $ "maxCols = " ++ show maxCols
    -- tellDebugMess $ "fixedPosXs = " ++ show fixedPosXs
    -- tellDebugMess $ "list = " ++ show list
    -- tellDebugMess $ "maxSpace = " ++ show maxSpace
    let alignAct :: m ()
alignAct = [Int] -> [Int] -> [(Int, ColInfo)] -> [(Int, Int, (Int, ColInfo))]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Int]
fixedPosXs [Int]
spacings [(Int, ColInfo)]
list [(Int, Int, (Int, ColInfo))]
-> ((Int, Int, (Int, ColInfo)) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
`forM_` \(Int
destX, Int
s, (Int, ColInfo)
x) -> do
          Int -> m ()
forall (m :: * -> *).
(MonadMultiWriter Builder m, MonadMultiState LayoutState m,
 MonadMultiWriter (Seq String) m) =>
Int -> m ()
layoutWriteEnsureAbsoluteN Int
destX
          Int -> ColMap2 -> ColInfo -> m ()
forall (m :: * -> *).
LayoutConstraints m =>
Int -> ColMap2 -> ColInfo -> m ()
processInfo Int
s ColMap2
m ((Int, ColInfo) -> ColInfo
forall a b. (a, b) -> b
snd (Int, ColInfo)
x)
        noAlignAct :: m ()
noAlignAct = [(Int, ColInfo)]
list [(Int, ColInfo)] -> ((Int, ColInfo) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
`forM_` ((Int, ColInfo) -> ColInfo
forall a b. (a, b) -> b
snd ((Int, ColInfo) -> ColInfo)
-> (ColInfo -> m ()) -> (Int, ColInfo) -> m ()
forall a b c. (a -> b) -> (b -> c) -> a -> c
.> ColInfo -> m ()
forall (m :: * -> *). LayoutConstraints m => ColInfo -> m ()
processInfoIgnore)
        animousAct :: m ()
animousAct = -- trace ("animousAct fixedPosXs=" ++ show fixedPosXs ++ ", list=" ++ show list ++ ", maxSpace=" ++ show maxSpace ++ ", colMax="++show colMax) $
                     if [Int] -> Int
forall a. [a] -> a
List.last [Int]
fixedPosXs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int, ColInfo) -> Int
forall a b. (a, b) -> a
fst ([(Int, ColInfo)] -> (Int, ColInfo)
forall a. [a] -> a
List.last [(Int, ColInfo)]
list) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
colMax
                     -- per-item check if there is overflowing.
          then m ()
noAlignAct
          else m ()
alignAct
    case ColumnAlignMode
alignMode of
      ColumnAlignMode
ColumnAlignModeDisabled                        -> m ()
noAlignAct
      ColumnAlignMode
ColumnAlignModeUnanimously | Int
maxX Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
colMax    -> m ()
alignAct
      ColumnAlignMode
ColumnAlignModeUnanimously                     -> m ()
noAlignAct
      ColumnAlignModeMajority Float
limit | Float
ratio Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
>= Float
limit -> m ()
animousAct
      ColumnAlignModeMajority{}                      -> m ()
noAlignAct
      ColumnAlignModeAnimouslyScale{}                -> m ()
animousAct
      ColumnAlignMode
ColumnAlignModeAnimously                       -> m ()
animousAct
      ColumnAlignMode
ColumnAlignModeAlways                          -> m ()
alignAct

processInfoIgnore :: LayoutConstraints m => ColInfo -> m ()
processInfoIgnore :: ColInfo -> m ()
processInfoIgnore = \case
  ColInfo
ColInfoStart     -> String -> m ()
forall a. HasCallStack => String -> a
error String
"should not happen (TM)"
  ColInfoNo BriDoc
doc    -> BriDoc -> m ()
forall (m :: * -> *). LayoutConstraints m => BriDoc -> m ()
layoutBriDocM BriDoc
doc
  ColInfo Int
_ ColSig
_ [(Int, ColInfo)]
list -> [(Int, ColInfo)]
list [(Int, ColInfo)] -> ((Int, ColInfo) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
`forM_` ((Int, ColInfo) -> ColInfo
forall a b. (a, b) -> b
snd ((Int, ColInfo) -> ColInfo)
-> (ColInfo -> m ()) -> (Int, ColInfo) -> m ()
forall a b c. (a -> b) -> (b -> c) -> a -> c
.> ColInfo -> m ()
forall (m :: * -> *). LayoutConstraints m => ColInfo -> m ()
processInfoIgnore)