hexagoxel
/
brittany
1
0
Fork 0
Code Issues 117 Pull Requests 5 Packages Projects Releases 5 Wiki Activity

Refactor s/rec/go for extension compat

ghc92
Lennart Spitzner 2023-04-17 09:32:27 +00:00
parent dc4e59f2a1
commit 0a76fe952c
1 changed files with 97 additions and 97 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

194
source/library/Language/Haskell/Brittany/Internal/Transformations/T1_Alt.hs
View File

@ -104,7 +104,7 @@ transformAlts =
MultiRWSS.withMultiStateA (AltCurPos 0 0 0 False AltLineModeStateNone) MultiRWSS.withMultiStateA (AltCurPos 0 0 0 False AltLineModeStateNone)
. Memo.startEvalMemoT . Memo.startEvalMemoT
. fmap unwrapBriDocNumbered . fmap unwrapBriDocNumbered
. rec . go
where where
-- this function is exponential by nature and cannot be improved in any -- this function is exponential by nature and cannot be improved in any
-- way i can think of, and i've tried. (stupid StableNames.) -- way i can think of, and i've tried. (stupid StableNames.)
@ -143,25 +143,25 @@ transformAlts =
rec go
:: BriDocNumbered :: BriDocNumbered
-> Memo.MemoT -> Memo.MemoT
Int Int
[VerticalSpacing] [VerticalSpacing]
(MultiRWSS.MultiRWS r w (AltCurPos ': s)) (MultiRWSS.MultiRWS r w (AltCurPos ': s))
BriDocNumbered BriDocNumbered
rec bdX@(brDcId, brDc) = do go bdX@(brDcId, brDc) = do
let reWrap = (,) brDcId let reWrap = (,) brDcId
-- debugAcp :: AltCurPos <- mGet -- debugAcp :: AltCurPos <- mGet
case brDc of case brDc of
-- BDWrapAnnKey annKey bd -> do -- BDWrapAnnKey annKey bd -> do
-- acp <- mGet -- acp <- mGet
-- mSet $ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp } -- mSet $ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp }
-- BDWrapAnnKey annKey <$> rec bd -- BDWrapAnnKey annKey <$> go bd
BDEmpty{} -> processSpacingSimple bdX $> bdX BDEmpty{} -> processSpacingSimple bdX $> bdX
BDLit{} -> processSpacingSimple bdX $> bdX BDLit{} -> processSpacingSimple bdX $> bdX
BDSeq list -> reWrap . BDSeq <$> list `forM` rec BDSeq list -> reWrap . BDSeq <$> list `forM` go
BDCols sig list -> reWrap . BDCols sig <$> list `forM` rec BDCols sig list -> reWrap . BDCols sig <$> list `forM` go
BDSeparator -> processSpacingSimple bdX $> bdX BDSeparator -> processSpacingSimple bdX $> bdX
BDAddBaseY indent bd -> do BDAddBaseY indent bd -> do
acp <- mGet acp <- mGet
@ -170,7 +170,7 @@ transformAlts =
{ _acp_indentPrep = max (_acp_indentPrep acp) indAdd { _acp_indentPrep = max (_acp_indentPrep acp) indAdd
, _acp_indentPrepForced = forced || _acp_indentPrepForced acp , _acp_indentPrepForced = forced || _acp_indentPrepForced acp
} }
r <- rec bd r <- go bd
acp' <- mGet acp' <- mGet
mSet $ acp' { _acp_indent = _acp_indent acp } mSet $ acp' { _acp_indent = _acp_indent acp }
return $ case indent of return $ case indent of
@ -181,16 +181,16 @@ transformAlts =
BDBaseYPushCur bd -> do BDBaseYPushCur bd -> do
acp <- mGet acp <- mGet
mSet $ acp { _acp_indent = _acp_line acp } mSet $ acp { _acp_indent = _acp_line acp }
r <- rec bd r <- go bd
acp' <- mGet acp' <- mGet
mSet $ acp' { _acp_indent = _acp_indent acp } mSet $ acp' { _acp_indent = _acp_indent acp }
return $ reWrap $ BDBaseYPushCur r return $ reWrap $ BDBaseYPushCur r
BDEntryDelta dp bd -> do BDEntryDelta dp bd -> do
return $ reWrap $ BDEntryDelta dp bd return $ reWrap $ BDEntryDelta dp bd
BDIndentLevelPushCur bd -> do BDIndentLevelPushCur bd -> do
reWrap . BDIndentLevelPushCur <$> rec bd reWrap . BDIndentLevelPushCur <$> go bd
BDIndentLevelPop bd -> do BDIndentLevelPop bd -> do
reWrap . BDIndentLevelPop <$> rec bd reWrap . BDIndentLevelPop <$> go bd
BDPar indent sameLine indented -> do BDPar indent sameLine indented -> do
indAmount <- indAmount <-
mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack
@ -207,12 +207,12 @@ transformAlts =
{ _acp_indent = ind, _acp_indentPrep = 0 { _acp_indent = ind, _acp_indentPrep = 0
, _acp_indentPrepForced = False , _acp_indentPrepForced = False
} }
sameLine' <- rec sameLine sameLine' <- go sameLine
mModify $ \acp' -> acp' mModify $ \acp' -> acp'
{ _acp_line = ind, _acp_indent = ind { _acp_line = ind, _acp_indent = ind
, _acp_indentPrepForced = forced , _acp_indentPrepForced = forced
} }
indented' <- rec indented indented' <- go indented
return $ reWrap $ BDPar indent sameLine' indented' return $ reWrap $ BDPar indent sameLine' indented'
BDAlt [] -> error "empty BDAlt" -- returning BDEmpty instead is a BDAlt [] -> error "empty BDAlt" -- returning BDEmpty instead is a
-- possibility, but i will prefer a -- possibility, but i will prefer a
@ -222,7 +222,7 @@ transformAlts =
altChooser <- mAsk <&> _conf_layout .> _lconfig_altChooser .> confUnpack altChooser <- mAsk <&> _conf_layout .> _lconfig_altChooser .> confUnpack
case altChooser of case altChooser of
AltChooserSimpleQuick -> do AltChooserSimpleQuick -> do
rec $ head alts go $ head alts
AltChooserShallowBest -> do AltChooserShallowBest -> do
spacings <- alts `forM` getSpacing spacings <- alts `forM` getSpacing
acp <- mGet acp <- mGet
@ -245,7 +245,7 @@ transformAlts =
<&> \(vs, bd) -> -- trace ("spacing=" ++ show vs ++ ",hasSpace=" ++ show (hasSpace lconf acp vs) ++ ",lineCheck=" ++ show (lineCheck vs)) <&> \(vs, bd) -> -- trace ("spacing=" ++ show vs ++ ",hasSpace=" ++ show (hasSpace lconf acp vs) ++ ",lineCheck=" ++ show (lineCheck vs))
(hasSpace1 lconf acp vs && lineCheck vs, bd) (hasSpace1 lconf acp vs && lineCheck vs, bd)
) )
rec go
$ fromMaybe (-- trace ("choosing last") $ $ fromMaybe (-- trace ("choosing last") $
List.last alts) List.last alts)
$ Data.List.Extra.firstJust $ Data.List.Extra.firstJust
@ -278,20 +278,20 @@ transformAlts =
let let
checkedOptions :: [Maybe (Int, BriDocNumbered)] = checkedOptions :: [Maybe (Int, BriDocNumbered)] =
zip [1 ..] options <&> (\(i, (b, x)) -> [ (i, x) | b ]) zip [1 ..] options <&> (\(i, (b, x)) -> [ (i, x) | b ])
rec go
$ fromMaybe (-- trace ("choosing last") $ $ fromMaybe (-- trace ("choosing last") $
List.last alts) List.last alts)
$ Data.List.Extra.firstJust (fmap snd) checkedOptions $ Data.List.Extra.firstJust (fmap snd) checkedOptions
BDForceAlt ForceMultiline bd -> do BDForceAlt ForceMultiline bd -> do
acp <- mGet acp <- mGet
mSet $ mergeLineMode acp (AltLineModeStateForceML False) mSet $ mergeLineMode acp (AltLineModeStateForceML False)
x <- rec bd x <- go bd
mModify $ \acp' -> acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } mModify $ \acp' -> acp' { _acp_forceMLFlag = _acp_forceMLFlag acp }
pure $ x pure $ x
BDForceAlt ForceSingleline bd -> do BDForceAlt ForceSingleline bd -> do
acp <- mGet acp <- mGet
mSet $ mergeLineMode acp AltLineModeStateForceSL mSet $ mergeLineMode acp AltLineModeStateForceSL
x <- rec bd x <- go bd
mModify $ \acp' -> acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } mModify $ \acp' -> acp' { _acp_forceMLFlag = _acp_forceMLFlag acp }
pure $ x pure $ x
BDForwardLineMode bd -> do BDForwardLineMode bd -> do
@ -299,35 +299,35 @@ transformAlts =
mSet $ acp mSet $ acp
{ _acp_forceMLFlag = altLineModeRefresh $ _acp_forceMLFlag acp { _acp_forceMLFlag = altLineModeRefresh $ _acp_forceMLFlag acp
} }
x <- rec bd x <- go bd
mModify $ \acp' -> acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } mModify $ \acp' -> acp' { _acp_forceMLFlag = _acp_forceMLFlag acp }
pure $ x pure $ x
BDForceAlt ForceZeroAdd bd -> rec bd BDForceAlt ForceZeroAdd bd -> go bd
BDExternal{} -> processSpacingSimple bdX $> bdX BDExternal{} -> processSpacingSimple bdX $> bdX
BDPlain{} -> processSpacingSimple bdX $> bdX BDPlain{} -> processSpacingSimple bdX $> bdX
BDQueueComments comms bd -> BDQueueComments comms bd ->
reWrap . BDQueueComments comms <$> rec bd reWrap . BDQueueComments comms <$> go bd
BDFlushCommentsPrior loc bd -> BDFlushCommentsPrior loc bd ->
-- TODO92 for AnnotationPrior we had this here: -- TODO92 for AnnotationPrior we had this here:
-- > acp <- mGet -- > acp <- mGet
-- > mSet -- > mSet
-- > $ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp } -- > $ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp }
-- > bd' <- rec bd -- > bd' <- go bd
-- not sure if the lineModeDecay is relevant any longer though.. -- not sure if the lineModeDecay is relevant any longer though..
reWrap . BDFlushCommentsPrior loc <$> rec bd reWrap . BDFlushCommentsPrior loc <$> go bd
BDFlushCommentsPost loc shouldMark bd -> BDFlushCommentsPost loc shouldMark bd ->
reWrap . BDFlushCommentsPost loc shouldMark <$> rec bd reWrap . BDFlushCommentsPost loc shouldMark <$> go bd
BDLines [] -> return $ reWrap BDEmpty -- evil transformation. or harmless. BDLines [] -> return $ reWrap BDEmpty -- evil transformation. or harmless.
BDLines (l : lr) -> do BDLines (l : lr) -> do
initialAcp <- mGet initialAcp <- mGet
l' <- rec l l' <- go l
lr' <- lr `forM` \x -> do lr' <- lr `forM` \x -> do
mModify $ \acp -> acp mModify $ \acp -> acp
{ _acp_line = _acp_indent initialAcp { _acp_line = _acp_indent initialAcp
, _acp_indent = _acp_indent initialAcp , _acp_indent = _acp_indent initialAcp
, _acp_indentPrepForced = _acp_indentPrepForced initialAcp , _acp_indentPrepForced = _acp_indentPrepForced initialAcp
} }
rec x go x
return $ reWrap $ BDLines (l' : lr') return $ reWrap $ BDLines (l' : lr')
BDEnsureIndent indent bd -> do BDEnsureIndent indent bd -> do
acp <- mGet acp <- mGet
@ -343,7 +343,7 @@ transformAlts =
-- Then, the actual indentation is relative to the current -- Then, the actual indentation is relative to the current
-- indentation, not the current cursor position. -- indentation, not the current cursor position.
} }
r <- rec bd r <- go bd
acp' <- mGet acp' <- mGet
mSet $ acp' { _acp_indent = _acp_indent acp } mSet $ acp' { _acp_indent = _acp_indent acp }
return $ case indent of return $ case indent of
@ -353,9 +353,9 @@ transformAlts =
BrIndentRegularForce -> BrIndentRegularForce ->
reWrap $ BDEnsureIndent (BrIndentSpecial indAdd) r reWrap $ BDEnsureIndent (BrIndentSpecial indAdd) r
BrIndentSpecial i -> reWrap $ BDEnsureIndent (BrIndentSpecial i) r BrIndentSpecial i -> reWrap $ BDEnsureIndent (BrIndentSpecial i) r
BDForceAlt (NonBottomSpacing _) bd -> rec bd BDForceAlt (NonBottomSpacing _) bd -> go bd
BDForceAlt SetParSpacing bd -> rec bd BDForceAlt SetParSpacing bd -> go bd
BDForceAlt ForceParSpacing bd -> rec bd BDForceAlt ForceParSpacing bd -> go bd
BDDebug s bd -> do BDDebug s bd -> do
acp :: AltCurPos <- mGet acp :: AltCurPos <- mGet
tellDebugMess tellDebugMess
@ -365,7 +365,7 @@ transformAlts =
++ show brDcId ++ show brDcId
++ "): acp=" ++ "): acp="
++ show acp ++ show acp
reWrap . BDDebug s <$> rec bd reWrap . BDDebug s <$> go bd
processSpacingSimple processSpacingSimple
:: ( MonadMultiReader Config m :: ( MonadMultiReader Config m
, MonadMultiState AltCurPos m , MonadMultiState AltCurPos m
@ -404,15 +404,15 @@ getSpacing
. (MonadMultiReader Config m, MonadMultiWriter (Seq String) m) . (MonadMultiReader Config m, MonadMultiWriter (Seq String) m)
=> BriDocNumbered => BriDocNumbered
-> m (LineModeValidity VerticalSpacing) -> m (LineModeValidity VerticalSpacing)
getSpacing !bridoc = rec bridoc getSpacing !bridoc = go bridoc
where where
rec :: BriDocNumbered -> m (LineModeValidity VerticalSpacing) go :: BriDocNumbered -> m (LineModeValidity VerticalSpacing)
rec (brDcId, brDc) = do go (brDcId, brDc) = do
config <- mAsk config <- mAsk
let colMax = config & _conf_layout & _lconfig_cols & confUnpack let colMax = config & _conf_layout & _lconfig_cols & confUnpack
let indAmount = confUnpack $ _lconfig_indentAmount $ _conf_layout $ config let indAmount = confUnpack $ _lconfig_indentAmount $ _conf_layout $ config
result :: LineModeValidity VerticalSpacing <- case brDc of result :: LineModeValidity VerticalSpacing <- case brDc of
-- BDWrapAnnKey _annKey bd -> rec bd -- BDWrapAnnKey _annKey bd -> go bd
BDEmpty -> BDEmpty ->
pure pure
$ LineModeValid $ LineModeValid
@ -421,14 +421,14 @@ getSpacing !bridoc = rec bridoc
pure pure
$ LineModeValid $ LineModeValid
$ VerticalSpacing (Text.length t) VerticalSpacingParNone False False $ VerticalSpacing (Text.length t) VerticalSpacingParNone False False
BDSeq list -> sumVs <$> rec `mapM` list BDSeq list -> sumVs <$> go `mapM` list
BDCols _sig list -> sumVs <$> rec `mapM` list BDCols _sig list -> sumVs <$> go `mapM` list
BDSeparator -> BDSeparator ->
pure pure
$ LineModeValid $ LineModeValid
$ VerticalSpacing 1 VerticalSpacingParNone False False $ VerticalSpacing 1 VerticalSpacingParNone False False
BDAddBaseY indent bd -> do BDAddBaseY indent bd -> do
mVs <- rec bd mVs <- go bd
pure pure
[ vs [ vs
{ _vs_paragraph = case _vs_paragraph vs of { _vs_paragraph = case _vs_paragraph vs of
@ -450,7 +450,7 @@ getSpacing !bridoc = rec bridoc
, indent == BrIndentNone || _vs_onlyZeroAddInd vs == False , indent == BrIndentNone || _vs_onlyZeroAddInd vs == False
] ]
BDBaseYPushCur bd -> do BDBaseYPushCur bd -> do
mVs <- rec bd mVs <- go bd
return $ mVs <&> \vs -> vs return $ mVs <&> \vs -> vs
-- We leave par as-is, even though it technically is not -- We leave par as-is, even though it technically is not
-- accurate (in general). -- accurate (in general).
@ -466,11 +466,11 @@ getSpacing !bridoc = rec bridoc
) )
, _vs_paragraph = VerticalSpacingParSome 0 , _vs_paragraph = VerticalSpacingParSome 0
} }
BDIndentLevelPushCur bd -> rec bd BDIndentLevelPushCur bd -> go bd
BDIndentLevelPop bd -> rec bd BDIndentLevelPop bd -> go bd
BDPar BrIndentNone sameLine indented -> do BDPar BrIndentNone sameLine indented -> do
mVs <- rec sameLine mVs <- go sameLine
mIndSp <- rec indented mIndSp <- go indented
return return
$ [ VerticalSpacing lsp pspResult parFlagResult False -- TODO92 should we turn this on? $ [ VerticalSpacing lsp pspResult parFlagResult False -- TODO92 should we turn this on?
| VerticalSpacing lsp mPsp _ _ <- mVs | VerticalSpacing lsp mPsp _ _ <- mVs
@ -493,21 +493,21 @@ getSpacing !bridoc = rec bridoc
] ]
BDPar{} -> error "BDPar with indent in getSpacing" BDPar{} -> error "BDPar with indent in getSpacing"
BDAlt [] -> error "empty BDAlt" BDAlt [] -> error "empty BDAlt"
BDAlt (alt : _) -> rec alt BDAlt (alt : _) -> go alt
BDForceAlt ForceMultiline bd -> do BDForceAlt ForceMultiline bd -> do
mVs <- rec bd mVs <- go bd
return $ mVs >>= _vs_paragraph .> \case return $ mVs >>= _vs_paragraph .> \case
VerticalSpacingParNone -> LineModeInvalid VerticalSpacingParNone -> LineModeInvalid
_ -> mVs _ -> mVs
BDForceAlt ForceSingleline bd -> do BDForceAlt ForceSingleline bd -> do
mVs <- rec bd mVs <- go bd
return $ mVs >>= _vs_paragraph .> \case return $ mVs >>= _vs_paragraph .> \case
VerticalSpacingParNone -> mVs VerticalSpacingParNone -> mVs
_ -> LineModeInvalid _ -> LineModeInvalid
BDForceAlt ForceZeroAdd bd -> do BDForceAlt ForceZeroAdd bd -> do
mVs <- rec bd mVs <- go bd
pure $ [ vs { _vs_onlyZeroAddInd = True } | vs <- mVs ] pure $ [ vs { _vs_onlyZeroAddInd = True } | vs <- mVs ]
BDForwardLineMode bd -> rec bd BDForwardLineMode bd -> go bd
BDExternal _ txt -> return $ LineModeValid $ case Text.lines txt of BDExternal _ txt -> return $ LineModeValid $ case Text.lines txt of
[t] -> [t] ->
VerticalSpacing (Text.length t) VerticalSpacingParNone False False VerticalSpacing (Text.length t) VerticalSpacingParNone False False
@ -516,10 +516,10 @@ getSpacing !bridoc = rec bridoc
[t] -> [t] ->
VerticalSpacing (Text.length t) VerticalSpacingParNone False False VerticalSpacing (Text.length t) VerticalSpacingParNone False False
_ -> VerticalSpacing 999 VerticalSpacingParNone False False _ -> VerticalSpacing 999 VerticalSpacingParNone False False
BDQueueComments _comms bd -> rec bd BDQueueComments _comms bd -> go bd
BDFlushCommentsPrior _loc bd -> rec bd BDFlushCommentsPrior _loc bd -> go bd
BDFlushCommentsPost _loc _shouldMark bd -> rec bd BDFlushCommentsPost _loc _shouldMark bd -> go bd
BDEntryDelta _dp bd -> rec bd BDEntryDelta _dp bd -> go bd
BDLines [] -> BDLines [] ->
pure pure
$ LineModeValid $ LineModeValid
@ -527,8 +527,8 @@ getSpacing !bridoc = rec bridoc
-- TODO92 should we set _vs_onlyZeroAddInd here too? -- TODO92 should we set _vs_onlyZeroAddInd here too?
-- did not do that before, but it makes sense for lines.. -- did not do that before, but it makes sense for lines..
BDLines (l1 : lR) -> do BDLines (l1 : lR) -> do
mVs <- rec l1 mVs <- go l1
mVRs <- rec `mapM` lR mVRs <- go `mapM` lR
let lSps = mVs : mVRs let lSps = mVs : mVRs
return return
$ [ VerticalSpacing lsp (VerticalSpacingParSome $ lineMax) False False $ [ VerticalSpacing lsp (VerticalSpacingParSome $ lineMax) False False
@ -538,7 +538,7 @@ getSpacing !bridoc = rec bridoc
, lineMax <- getMaxVS $ maxVs $ lSps , lineMax <- getMaxVS $ maxVs $ lSps
] ]
BDEnsureIndent indent bd -> do BDEnsureIndent indent bd -> do
mVs <- rec bd mVs <- go bd
let addInd = case indent of let addInd = case indent of
BrIndentNone -> 0 BrIndentNone -> 0
BrIndentRegular -> indAmount BrIndentRegular -> indAmount
@ -547,7 +547,7 @@ getSpacing !bridoc = rec bridoc
return $ mVs <&> \(VerticalSpacing lsp psp pf _) -> return $ mVs <&> \(VerticalSpacing lsp psp pf _) ->
VerticalSpacing (lsp + addInd) psp pf False VerticalSpacing (lsp + addInd) psp pf False
BDForceAlt (NonBottomSpacing b) bd -> do BDForceAlt (NonBottomSpacing b) bd -> do
mVs <- rec bd mVs <- go bd
return $ mVs <|> LineModeValid return $ mVs <|> LineModeValid
(VerticalSpacing (VerticalSpacing
0 0
@ -559,17 +559,17 @@ getSpacing !bridoc = rec bridoc
False False
) )
BDForceAlt SetParSpacing bd -> do BDForceAlt SetParSpacing bd -> do
mVs <- rec bd mVs <- go bd
return $ mVs <&> \vs -> vs { _vs_parFlag = True } return $ mVs <&> \vs -> vs { _vs_parFlag = True }
BDForceAlt ForceParSpacing bd -> do BDForceAlt ForceParSpacing bd -> do
mVs <- rec bd mVs <- go bd
return return
$ [ vs $ [ vs
| vs <- mVs | vs <- mVs
, _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone , _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone
] ]
BDDebug s bd -> do BDDebug s bd -> do
r <- rec bd r <- go bd
tellDebugMess tellDebugMess
$ "getSpacing: BDDebug " $ "getSpacing: BDDebug "
++ show s ++ show s
@ -604,9 +604,9 @@ getSpacing !bridoc = rec bridoc
(LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False False) (LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False False)
sumVs sumVs
:: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing
sumVs sps = foldl' (liftM2 go) initial sps sumVs sps = foldl' (liftM2 goSum) initial sps
where where
go (VerticalSpacing x1 x2 x3 x4) (VerticalSpacing y1 y2 _ y4) = goSum (VerticalSpacing x1 x2 x3 x4) (VerticalSpacing y1 y2 _ y4) =
VerticalSpacing VerticalSpacing
(x1 + y1) (x1 + y1)
(case (x2, y2) of (case (x2, y2) of
@ -646,7 +646,7 @@ getSpacings
=> Int => Int
-> BriDocNumbered -> BriDocNumbered
-> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing] -> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing]
getSpacings limit bridoc = preFilterLimit <$> rec bridoc getSpacings limit bridoc = preFilterLimit <$> go bridoc
where where
-- when we do `take K . filter someCondition` on a list of spacings, we -- when we do `take K . filter someCondition` on a list of spacings, we
-- need to first (also) limit the size of the input list, otherwise a -- need to first (also) limit the size of the input list, otherwise a
@ -657,8 +657,8 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
preFilterLimit = take (3 * limit) preFilterLimit = take (3 * limit)
memoWithKey :: Memo.MonadMemo k v m1 => k -> m1 v -> m1 v memoWithKey :: Memo.MonadMemo k v m1 => k -> m1 v -> m1 v
memoWithKey k v = Memo.memo (const v) k memoWithKey k v = Memo.memo (const v) k
rec :: BriDocNumbered -> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing] go :: BriDocNumbered -> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing]
rec (brDcId, brdc) = memoWithKey brDcId $ do go (brDcId, brdc) = memoWithKey brDcId $ do
config <- mAsk config <- mAsk
let colMax = config & _conf_layout & _lconfig_cols & confUnpack let colMax = config & _conf_layout & _lconfig_cols & confUnpack
let let
@ -686,14 +686,14 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
-- smallest member of this "equal group". -- smallest member of this "equal group".
specialNub :: [VerticalSpacing] -> [VerticalSpacing] specialNub :: [VerticalSpacing] -> [VerticalSpacing]
specialNub [] = [] specialNub [] = []
specialNub (x1 : xr) = case go x1 xr of specialNub (x1 : xr) = case goNub x1 xr of
(r, xs') -> r : specialNub xs' (r, xs') -> r : specialNub xs'
where where
go y1 [] = (y1, []) goNub y1 [] = (y1, [])
go y1 (y2 : yr) = case specialCompare y1 y2 of goNub y1 (y2 : yr) = case specialCompare y1 y2 of
Unequal -> let (r, yr') = go y1 yr in (r, y2 : yr') Unequal -> let (r, yr') = goNub y1 yr in (r, y2 : yr')
Smaller -> go y1 yr Smaller -> goNub y1 yr
Bigger -> go y2 yr Bigger -> goNub y2 yr
let -- the standard function used to enforce a constant upper bound let -- the standard function used to enforce a constant upper bound
-- on the number of elements returned for each node. Should be -- on the number of elements returned for each node. Should be
-- applied whenever in a parent the combination of spacings from -- applied whenever in a parent the combination of spacings from
@ -731,17 +731,17 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
-- total. -- total.
. preFilterLimit . preFilterLimit
result <- case brdc of result <- case brdc of
-- BDWrapAnnKey _annKey bd -> rec bd -- BDWrapAnnKey _annKey bd -> go bd
BDEmpty -> return $ [VerticalSpacing 0 VerticalSpacingParNone False False] BDEmpty -> return $ [VerticalSpacing 0 VerticalSpacingParNone False False]
BDLit t -> do BDLit t -> do
let l = Text.length t let l = Text.length t
pure $ [VerticalSpacing l VerticalSpacingParNone False False] pure $ [VerticalSpacing l VerticalSpacingParNone False False]
BDSeq list -> fmap sumVs . mapM filterAndLimit <$> rec `mapM` list BDSeq list -> fmap sumVs . mapM filterAndLimit <$> go `mapM` list
BDCols _sig list -> fmap sumVs . mapM filterAndLimit <$> rec `mapM` list BDCols _sig list -> fmap sumVs . mapM filterAndLimit <$> go `mapM` list
BDSeparator -> BDSeparator ->
pure $ [VerticalSpacing 1 VerticalSpacingParNone False False] pure $ [VerticalSpacing 1 VerticalSpacingParNone False False]
BDAddBaseY indent bd -> do BDAddBaseY indent bd -> do
mVs <- rec bd mVs <- go bd
return $ mVs <&> \vs -> vs return $ mVs <&> \vs -> vs
{ _vs_paragraph = case _vs_paragraph vs of { _vs_paragraph = case _vs_paragraph vs of
VerticalSpacingParNone -> VerticalSpacingParNone VerticalSpacingParNone -> VerticalSpacingParNone
@ -758,7 +758,7 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
BrIndentSpecial j -> i + j BrIndentSpecial j -> i + j
} }
BDBaseYPushCur bd -> do BDBaseYPushCur bd -> do
mVs <- rec bd mVs <- go bd
return $ mVs <&> \vs -> vs return $ mVs <&> \vs -> vs
-- We leave par as-is, even though it technically is not -- We leave par as-is, even though it technically is not
-- accurate (in general). -- accurate (in general).
@ -777,11 +777,11 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
VerticalSpacingParSome i -> VerticalSpacingParSome i VerticalSpacingParSome i -> VerticalSpacingParSome i
VerticalSpacingParAlways i -> VerticalSpacingParAlways i VerticalSpacingParAlways i -> VerticalSpacingParAlways i
} }
BDIndentLevelPushCur bd -> rec bd BDIndentLevelPushCur bd -> go bd
BDIndentLevelPop bd -> rec bd BDIndentLevelPop bd -> go bd
BDPar BrIndentNone sameLine indented -> do BDPar BrIndentNone sameLine indented -> do
mVss <- filterAndLimit <$> rec sameLine mVss <- filterAndLimit <$> go sameLine
indSps <- filterAndLimit <$> rec indented indSps <- filterAndLimit <$> go indented
let mVsIndSp = take limit $ [ (x, y) | x <- mVss, y <- indSps ] let mVsIndSp = take limit $ [ (x, y) | x <- mVss, y <- indSps ]
return $ mVsIndSp <&> \(VerticalSpacing lsp mPsp _ _, indSp) -> return $ mVsIndSp <&> \(VerticalSpacing lsp mPsp _ _, indSp) ->
VerticalSpacing VerticalSpacing
@ -803,17 +803,17 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
BDPar{} -> error "BDPar with indent in getSpacing" BDPar{} -> error "BDPar with indent in getSpacing"
BDAlt [] -> error "empty BDAlt" BDAlt [] -> error "empty BDAlt"
-- BDAlt (alt:_) -> rec alt -- BDAlt (alt:_) -> go alt
BDAlt alts -> do BDAlt alts -> do
r <- rec `mapM` alts r <- go `mapM` alts
return $ filterAndLimit =<< r return $ filterAndLimit =<< r
BDForceAlt ForceMultiline bd -> do BDForceAlt ForceMultiline bd -> do
mVs <- filterAndLimit <$> rec bd mVs <- filterAndLimit <$> go bd
return $ filter ((/= VerticalSpacingParNone) . _vs_paragraph) mVs return $ filter ((/= VerticalSpacingParNone) . _vs_paragraph) mVs
BDForceAlt ForceSingleline bd -> do BDForceAlt ForceSingleline bd -> do
mVs <- filterAndLimit <$> rec bd mVs <- filterAndLimit <$> go bd
return $ filter ((== VerticalSpacingParNone) . _vs_paragraph) mVs return $ filter ((== VerticalSpacingParNone) . _vs_paragraph) mVs
BDForwardLineMode bd -> rec bd BDForwardLineMode bd -> go bd
BDExternal _ txt | [t] <- Text.lines txt -> do BDExternal _ txt | [t] <- Text.lines txt -> do
let l = Text.length t let l = Text.length t
pure $ [VerticalSpacing l VerticalSpacingParNone False False] pure $ [VerticalSpacing l VerticalSpacingParNone False False]
@ -830,10 +830,10 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
VerticalSpacing (tl t1) (VerticalSpacingParAlways 0) True False VerticalSpacing (tl t1) (VerticalSpacingParAlways 0) True False
| allowHangingQuasiQuotes | allowHangingQuasiQuotes
] ]
BDQueueComments _comms bd -> rec bd BDQueueComments _comms bd -> go bd
BDFlushCommentsPrior _loc bd -> rec bd BDFlushCommentsPrior _loc bd -> go bd
BDFlushCommentsPost _loc _shouldMark bd -> rec bd BDFlushCommentsPost _loc _shouldMark bd -> go bd
BDEntryDelta _dp bd -> rec bd BDEntryDelta _dp bd -> go bd
BDLines [] -> BDLines [] ->
pure $ [VerticalSpacing 0 VerticalSpacingParNone False False] pure $ [VerticalSpacing 0 VerticalSpacingParNone False False]
BDLines ls@(_ : _) -> do BDLines ls@(_ : _) -> do
@ -842,7 +842,7 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
-- paragraph". That most importantly means that Lines should never -- paragraph". That most importantly means that Lines should never
-- be inserted anywhere but at the start of the line. A -- be inserted anywhere but at the start of the line. A
-- counterexample would be anything like Seq[Lit "foo", Lines]. -- counterexample would be anything like Seq[Lit "foo", Lines].
lSpss <- map filterAndLimit <$> rec `mapM` ls lSpss <- mapM (fmap filterAndLimit . go) ls
let let
worbled = sequence $ case lSpss of worbled = sequence $ case lSpss of
[] -> [] [] -> []
@ -858,7 +858,7 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
$ "should not happen. if my logic does not fail" $ "should not happen. if my logic does not fail"
++ "me, this follows from not (null ls)." ++ "me, this follows from not (null ls)."
return $ sumF <$> worbled return $ sumF <$> worbled
-- lSpss@(mVs:_) <- rec `mapM` ls -- lSpss@(mVs:_) <- go `mapM` ls
-- return $ case Control.Lens.transposeOf traverse lSpss of -- TODO: we currently only -- return $ case Control.Lens.transposeOf traverse lSpss of -- TODO: we currently only
-- -- consider the first alternative for the -- -- consider the first alternative for the
-- -- line's spacings. -- -- line's spacings.
@ -870,7 +870,7 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
-- (lSps:_) -> mVs <&> \(VerticalSpacing lsp _) -> -- (lSps:_) -> mVs <&> \(VerticalSpacing lsp _) ->
-- VerticalSpacing lsp $ VerticalSpacingParSome $ getMaxVS $ maxVs lSps -- VerticalSpacing lsp $ VerticalSpacingParSome $ getMaxVS $ maxVs lSps
BDEnsureIndent indent bd -> do BDEnsureIndent indent bd -> do
mVs <- rec bd mVs <- go bd
let let
addInd = case indent of addInd = case indent of
BrIndentNone -> 0 BrIndentNone -> 0
@ -884,7 +884,7 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
-- all tests work without it. It should be possible to have -- all tests work without it. It should be possible to have
-- `spMakePar` map VSPAlways{} to VSPSome x1, which fixes this -- `spMakePar` map VSPAlways{} to VSPSome x1, which fixes this
-- problem but breaks certain other cases. -- problem but breaks certain other cases.
mVs <- rec bd mVs <- go bd
return $ if null mVs return $ if null mVs
then then
[ VerticalSpacing [ VerticalSpacing
@ -936,20 +936,20 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
-- mVs -- mVs
-- ] -- ]
BDForceAlt SetParSpacing bd -> do BDForceAlt SetParSpacing bd -> do
mVs <- rec bd mVs <- go bd
return $ mVs <&> \vs -> vs { _vs_parFlag = True } return $ mVs <&> \vs -> vs { _vs_parFlag = True }
BDForceAlt ForceParSpacing bd -> do BDForceAlt ForceParSpacing bd -> do
mVs <- preFilterLimit <$> rec bd mVs <- preFilterLimit <$> go bd
return return
$ [ vs $ [ vs
| vs <- mVs | vs <- mVs
, _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone , _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone
] ]
BDForceAlt ForceZeroAdd bd -> do BDForceAlt ForceZeroAdd bd -> do
mVs <- preFilterLimit <$> rec bd mVs <- preFilterLimit <$> go bd
pure [ vs { _vs_onlyZeroAddInd = True } | vs <- mVs ] pure [ vs { _vs_onlyZeroAddInd = True } | vs <- mVs ]
BDDebug s bd -> do BDDebug s bd -> do
r <- rec bd r <- go bd
tellDebugMess tellDebugMess
$ "getSpacings: BDDebug " $ "getSpacings: BDDebug "
++ show s ++ show s
@ -980,9 +980,9 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
) )
(VerticalSpacing 0 VerticalSpacingParNone False False) (VerticalSpacing 0 VerticalSpacingParNone False False)
sumVs :: [VerticalSpacing] -> VerticalSpacing sumVs :: [VerticalSpacing] -> VerticalSpacing
sumVs sps = foldl' go initial sps sumVs sps = foldl' goSum initial sps
where where
go (VerticalSpacing x1 x2 x3 x4) (VerticalSpacing y1 y2 _ y4) = goSum (VerticalSpacing x1 x2 x3 x4) (VerticalSpacing y1 y2 _ y4) =
VerticalSpacing VerticalSpacing
(x1 + y1) (x1 + y1)
(case (x2, y2) of (case (x2, y2) of