Refactor Backend.hs (Move stuff to top-level)
Lennart Spitzner
parent
8b7b1334e2
commit
b8396da1d6
|
|
@ -3,6 +3,7 @@
|
|||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
|
||||
module Language.Haskell.Brittany.Backend
|
||||
( layoutBriDocM
|
||||
|
|
@ -36,89 +37,41 @@ import qualified Control.Monad.Trans.Writer.Strict as WriterS
|
|||
|
||||
|
||||
|
||||
briDocLineLength :: BriDoc -> Int
|
||||
briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc
|
||||
-- the state encodes whether a separator was already
|
||||
-- appended at the current position.
|
||||
where
|
||||
rec = \case
|
||||
BDEmpty -> return $ 0
|
||||
BDLit t -> StateS.put False $> Text.length t
|
||||
BDSeq bds -> sum <$> rec `mapM` bds
|
||||
BDCols _ bds -> sum <$> rec `mapM` bds
|
||||
BDSeparator -> StateS.get >>= \b -> StateS.put True $> if b then 0 else 1
|
||||
BDAddBaseY _ bd -> rec bd
|
||||
BDBaseYPushCur bd -> rec bd
|
||||
BDBaseYPop bd -> rec bd
|
||||
BDIndentLevelPushCur bd -> rec bd
|
||||
BDIndentLevelPop bd -> rec bd
|
||||
BDPar _ line _ -> rec line
|
||||
BDAlt{} -> error "briDocLineLength BDAlt"
|
||||
BDForceMultiline bd -> rec bd
|
||||
BDForceSingleline bd -> rec bd
|
||||
BDForwardLineMode bd -> rec bd
|
||||
BDExternal _ _ _ t -> return $ Text.length t
|
||||
BDAnnotationPrior _ bd -> rec bd
|
||||
BDAnnotationKW _ _ bd -> rec bd
|
||||
BDAnnotationRest _ bd -> rec bd
|
||||
BDLines ls@(_:_) -> do
|
||||
x <- StateS.get
|
||||
return $ maximum $ ls <&> \l -> StateS.evalState (rec l) x
|
||||
BDLines [] -> error "briDocLineLength BDLines []"
|
||||
BDEnsureIndent _ bd -> rec bd
|
||||
BDProhibitMTEL bd -> rec bd
|
||||
BDSetParSpacing bd -> rec bd
|
||||
BDForceParSpacing bd -> rec bd
|
||||
BDNonBottomSpacing bd -> rec bd
|
||||
BDDebug _ bd -> rec bd
|
||||
type ColIndex = Int
|
||||
|
||||
briDocIsMultiLine :: BriDoc -> Bool
|
||||
briDocIsMultiLine briDoc = rec briDoc
|
||||
where
|
||||
rec :: BriDoc -> Bool
|
||||
rec = \case
|
||||
BDEmpty -> False
|
||||
BDLit _ -> False
|
||||
BDSeq bds -> any rec bds
|
||||
BDCols _ bds -> any rec bds
|
||||
BDSeparator -> False
|
||||
BDAddBaseY _ bd -> rec bd
|
||||
BDBaseYPushCur bd -> rec bd
|
||||
BDBaseYPop bd -> rec bd
|
||||
BDIndentLevelPushCur bd -> rec bd
|
||||
BDIndentLevelPop bd -> rec bd
|
||||
BDPar _ _ _ -> True
|
||||
BDAlt{} -> error "briDocIsMultiLine BDAlt"
|
||||
BDForceMultiline _ -> True
|
||||
BDForceSingleline bd -> rec bd
|
||||
BDForwardLineMode bd -> rec bd
|
||||
BDExternal _ _ _ _ -> True
|
||||
BDAnnotationPrior _ bd -> rec bd
|
||||
BDAnnotationKW _ _ bd -> rec bd
|
||||
BDAnnotationRest _ bd -> rec bd
|
||||
BDLines (_:_:_) -> True
|
||||
BDLines [_ ] -> False
|
||||
BDLines [] -> error "briDocIsMultiLine BDLines []"
|
||||
BDEnsureIndent _ bd -> rec bd
|
||||
BDProhibitMTEL bd -> rec bd
|
||||
BDSetParSpacing bd -> rec bd
|
||||
BDForceParSpacing bd -> rec bd
|
||||
BDNonBottomSpacing bd -> rec bd
|
||||
BDDebug _ bd -> rec bd
|
||||
data ColumnSpacing
|
||||
= ColumnSpacingLeaf Int
|
||||
| ColumnSpacingRef Int Int
|
||||
|
||||
layoutBriDocM
|
||||
:: forall w m
|
||||
. ( m ~ MultiRWSS.MultiRWST
|
||||
'[Config, ExactPrint.Anns]
|
||||
w
|
||||
'[LayoutState]
|
||||
Identity
|
||||
, ContainsType Text.Builder.Builder w
|
||||
, ContainsType [LayoutError] w
|
||||
, ContainsType (Seq String) w
|
||||
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 ColInfoStart = "ColInfoStart"
|
||||
show ColInfoNo{} = "ColInfoNo{}"
|
||||
show (ColInfo ind sig list) = "ColInfo " ++ show ind ++ " " ++ show sig ++ " " ++ show list
|
||||
|
||||
data ColBuildState = ColBuildState
|
||||
{ _cbs_map :: ColMap1
|
||||
, _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
|
||||
)
|
||||
=> BriDoc
|
||||
-> m ()
|
||||
|
||||
layoutBriDocM :: forall m . LayoutConstraints m => BriDoc -> m ()
|
||||
layoutBriDocM = \case
|
||||
BDEmpty -> do
|
||||
return () -- can it be that simple
|
||||
|
|
@ -318,16 +271,79 @@ layoutBriDocM = \case
|
|||
BDDebug s bd -> do
|
||||
mTell $ Text.Builder.fromText $ Text.pack $ "{-" ++ s ++ "-}"
|
||||
layoutBriDocM bd
|
||||
|
||||
briDocLineLength :: BriDoc -> Int
|
||||
briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc
|
||||
-- the state encodes whether a separator was already
|
||||
-- appended at the current position.
|
||||
where
|
||||
-- alignColsPar :: [BriDoc]
|
||||
-- -> m ()
|
||||
-- alignColsPar l = colInfos `forM_` \colInfo -> do
|
||||
-- layoutWriteNewlineBlock
|
||||
-- processInfo (_cbs_map finalState) colInfo
|
||||
-- where
|
||||
-- (colInfos, finalState) = StateS.runState (mergeBriDocs l) (ColBuildState IntMapS.empty 0)
|
||||
alignColsLines :: [BriDoc] -> m ()
|
||||
alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do
|
||||
rec = \case
|
||||
BDEmpty -> return $ 0
|
||||
BDLit t -> StateS.put False $> Text.length t
|
||||
BDSeq bds -> sum <$> rec `mapM` bds
|
||||
BDCols _ bds -> sum <$> rec `mapM` bds
|
||||
BDSeparator -> StateS.get >>= \b -> StateS.put True $> if b then 0 else 1
|
||||
BDAddBaseY _ bd -> rec bd
|
||||
BDBaseYPushCur bd -> rec bd
|
||||
BDBaseYPop bd -> rec bd
|
||||
BDIndentLevelPushCur bd -> rec bd
|
||||
BDIndentLevelPop bd -> rec bd
|
||||
BDPar _ line _ -> rec line
|
||||
BDAlt{} -> error "briDocLineLength BDAlt"
|
||||
BDForceMultiline bd -> rec bd
|
||||
BDForceSingleline bd -> rec bd
|
||||
BDForwardLineMode bd -> rec bd
|
||||
BDExternal _ _ _ t -> return $ Text.length t
|
||||
BDAnnotationPrior _ bd -> rec bd
|
||||
BDAnnotationKW _ _ bd -> rec bd
|
||||
BDAnnotationRest _ bd -> rec bd
|
||||
BDLines ls@(_:_) -> do
|
||||
x <- StateS.get
|
||||
return $ maximum $ ls <&> \l -> StateS.evalState (rec l) x
|
||||
BDLines [] -> error "briDocLineLength BDLines []"
|
||||
BDEnsureIndent _ bd -> rec bd
|
||||
BDProhibitMTEL bd -> rec bd
|
||||
BDSetParSpacing bd -> rec bd
|
||||
BDForceParSpacing bd -> rec bd
|
||||
BDNonBottomSpacing bd -> rec bd
|
||||
BDDebug _ bd -> rec bd
|
||||
|
||||
briDocIsMultiLine :: BriDoc -> Bool
|
||||
briDocIsMultiLine briDoc = rec briDoc
|
||||
where
|
||||
rec :: BriDoc -> Bool
|
||||
rec = \case
|
||||
BDEmpty -> False
|
||||
BDLit _ -> False
|
||||
BDSeq bds -> any rec bds
|
||||
BDCols _ bds -> any rec bds
|
||||
BDSeparator -> False
|
||||
BDAddBaseY _ bd -> rec bd
|
||||
BDBaseYPushCur bd -> rec bd
|
||||
BDBaseYPop bd -> rec bd
|
||||
BDIndentLevelPushCur bd -> rec bd
|
||||
BDIndentLevelPop bd -> rec bd
|
||||
BDPar _ _ _ -> True
|
||||
BDAlt{} -> error "briDocIsMultiLine BDAlt"
|
||||
BDForceMultiline _ -> True
|
||||
BDForceSingleline bd -> rec bd
|
||||
BDForwardLineMode bd -> rec bd
|
||||
BDExternal _ _ _ _ -> True
|
||||
BDAnnotationPrior _ bd -> rec bd
|
||||
BDAnnotationKW _ _ bd -> rec bd
|
||||
BDAnnotationRest _ bd -> rec bd
|
||||
BDLines (_:_:_) -> True
|
||||
BDLines [_ ] -> False
|
||||
BDLines [] -> error "briDocIsMultiLine BDLines []"
|
||||
BDEnsureIndent _ bd -> rec bd
|
||||
BDProhibitMTEL bd -> rec bd
|
||||
BDSetParSpacing bd -> rec bd
|
||||
BDForceParSpacing bd -> rec bd
|
||||
BDNonBottomSpacing bd -> rec bd
|
||||
BDDebug _ bd -> rec bd
|
||||
|
||||
alignColsLines :: LayoutConstraints m => [BriDoc] -> m ()
|
||||
alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do
|
||||
curX <- do
|
||||
state <- mGet
|
||||
return $ either id (const 0) (_lstate_curYOrAddNewline state) + fromMaybe
|
||||
|
|
@ -360,9 +376,7 @@ layoutBriDocM = \case
|
|||
colss = colSpacingss <&> \spss -> case reverse spss of
|
||||
[] -> []
|
||||
(xN:xR) ->
|
||||
reverse $ (if lastFlag then fLast else fInit) xN : fmap
|
||||
fInit
|
||||
xR
|
||||
reverse $ (if lastFlag then fLast else fInit) xN : fmap fInit xR
|
||||
where
|
||||
fLast (ColumnSpacingLeaf len ) = len
|
||||
fLast (ColumnSpacingRef len _) = len
|
||||
|
|
@ -429,8 +443,8 @@ layoutBriDocM = \case
|
|||
-> briDocToColInfo lastFlag brdc
|
||||
brdc -> return $ ColInfoNo brdc
|
||||
|
||||
briDocToColInfo :: Bool -> BriDoc -> StateS.State ColBuildState ColInfo
|
||||
briDocToColInfo lastFlag = \case
|
||||
briDocToColInfo :: Bool -> BriDoc -> StateS.State ColBuildState ColInfo
|
||||
briDocToColInfo lastFlag = \case
|
||||
BDCols sig list -> withAlloc lastFlag $ \ind -> do
|
||||
let isLastList =
|
||||
if lastFlag then (==length list) <$> [1 ..] else repeat False
|
||||
|
|
@ -440,18 +454,18 @@ layoutBriDocM = \case
|
|||
return $ (Seq.singleton trueSpacings, ColInfo ind sig lengthInfos)
|
||||
bd -> return $ ColInfoNo bd
|
||||
|
||||
getTrueSpacings :: [(Int, ColInfo)] -> [ColumnSpacing]
|
||||
getTrueSpacings lengthInfos = lengthInfos <&> \case
|
||||
getTrueSpacings :: [(Int, ColInfo)] -> [ColumnSpacing]
|
||||
getTrueSpacings lengthInfos = lengthInfos <&> \case
|
||||
(len, ColInfo i _ _) -> ColumnSpacingRef len i
|
||||
(len, _ ) -> ColumnSpacingLeaf len
|
||||
|
||||
withAlloc
|
||||
withAlloc
|
||||
:: Bool
|
||||
-> ( ColIndex
|
||||
-> StateS.State ColBuildState (ColumnBlocks ColumnSpacing, ColInfo)
|
||||
)
|
||||
-> StateS.State ColBuildState ColInfo
|
||||
withAlloc lastFlag f = do
|
||||
withAlloc lastFlag f = do
|
||||
cbs <- StateS.get
|
||||
let ind = _cbs_index cbs
|
||||
StateS.put $ cbs { _cbs_index = ind + 1 }
|
||||
|
|
@ -460,19 +474,18 @@ layoutBriDocM = \case
|
|||
$ c { _cbs_map = IntMapS.insert ind (lastFlag, space) $ _cbs_map c }
|
||||
return info
|
||||
|
||||
processInfo :: ColMap2 -> ColInfo -> m ()
|
||||
processInfo m = \case
|
||||
processInfo :: LayoutConstraints m => ColMap2 -> ColInfo -> m ()
|
||||
processInfo m = \case
|
||||
ColInfoStart -> error "should not happen (TM)"
|
||||
ColInfoNo doc -> layoutBriDocM doc
|
||||
ColInfo ind _ list -> do
|
||||
colMax <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack
|
||||
alignMode <-
|
||||
mAsk <&> _conf_layout .> _lconfig_columnAlignMode .> confUnpack
|
||||
alignMode <- mAsk <&> _conf_layout .> _lconfig_columnAlignMode .> confUnpack
|
||||
curX <- do
|
||||
state <- mGet
|
||||
return
|
||||
$ either id (const 0) (_lstate_curYOrAddNewline state)
|
||||
+ fromMaybe 0 (_lstate_addSepSpace state)
|
||||
return $ either id (const 0) (_lstate_curYOrAddNewline state) + fromMaybe
|
||||
0
|
||||
(_lstate_addSepSpace state)
|
||||
-- tellDebugMess $ show curX
|
||||
let Just (ratio, maxCols, _colss) = IntMapS.lookup ind m
|
||||
let (maxX, posXs) = mapAccumL (\acc x -> (acc + x, acc)) curX maxCols
|
||||
|
|
@ -484,8 +497,7 @@ layoutBriDocM = \case
|
|||
-- 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 = case alignMode of
|
||||
let fixedPosXs = case alignMode of
|
||||
ColumnAlignModeAnimouslyScale i | maxX > colMax -> fixed <&> (+curX)
|
||||
where
|
||||
factor :: Float =
|
||||
|
|
@ -515,35 +527,9 @@ layoutBriDocM = \case
|
|||
ColumnAlignModeAnimously -> animousAct
|
||||
ColumnAlignModeAlways -> alignAct
|
||||
|
||||
processInfoIgnore :: ColInfo -> m ()
|
||||
processInfoIgnore = \case
|
||||
processInfoIgnore :: LayoutConstraints m => ColInfo -> m ()
|
||||
processInfoIgnore = \case
|
||||
ColInfoStart -> error "should not happen (TM)"
|
||||
ColInfoNo doc -> layoutBriDocM doc
|
||||
ColInfo _ _ list -> list `forM_` (snd .> processInfoIgnore)
|
||||
|
||||
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 ColInfoStart = "ColInfoStart"
|
||||
show ColInfoNo{} = "ColInfoNo{}"
|
||||
show (ColInfo ind sig list) = "ColInfo " ++ show ind ++ " " ++ show sig ++ " " ++ show list
|
||||
|
||||
data ColBuildState = ColBuildState
|
||||
{ _cbs_map :: ColMap1
|
||||
, _cbs_index :: ColIndex
|
||||
}
|
||||
|
|
|
|||
Loading…
Reference in New Issue