Refactor Backend.hs (Move stuff to top-level)

src/Language/Haskell/Brittany/Backend.hs

@@ -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
+type ColIndex  = 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
 
-briDocIsMultiLine :: BriDoc -> Bool
+data ColumnSpacing
-briDocIsMultiLine briDoc = rec briDoc
+  = ColumnSpacingLeaf Int
- where
+  | ColumnSpacingRef Int Int
-  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
 
-layoutBriDocM
+type ColumnBlock  a = [a]
-  :: forall w m
+type ColumnBlocks a = Seq [a]
-   . ( m ~ MultiRWSS.MultiRWST
+type ColMap1 = IntMapL.IntMap {- ColIndex -} (Bool, ColumnBlocks ColumnSpacing)
-             '[Config, ExactPrint.Anns]
+type ColMap2 = IntMapL.IntMap {- ColIndex -} (Float, ColumnBlock Int, ColumnBlocks Int)
-             w
+                                          -- (ratio of hasSpace, maximum, raw)
-             '[LayoutState]
+
-             Identity
+data ColInfo
-     , ContainsType Text.Builder.Builder w
+  = ColInfoStart -- start value to begin the mapAccumL.
-     , ContainsType [LayoutError] w
+  | ColInfoNo BriDoc
-     , ContainsType (Seq String) w
+  | 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,15 +271,78 @@ 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]
+  rec = \case
-    --           -> m ()
+    BDEmpty                 -> return $ 0
-    -- alignColsPar l = colInfos `forM_` \colInfo -> do
+    BDLit t                 -> StateS.put False $> Text.length t
-    --     layoutWriteNewlineBlock
+    BDSeq bds               -> sum <$> rec `mapM` bds
-    --     processInfo (_cbs_map finalState) colInfo
+    BDCols _ bds            -> sum <$> rec `mapM` bds
-    --   where
+    BDSeparator -> StateS.get >>= \b -> StateS.put True $> if b then 0 else 1
-    --     (colInfos, finalState) = StateS.runState (mergeBriDocs l) (ColBuildState IntMapS.empty 0)
+    BDAddBaseY _ bd         -> rec bd
-  alignColsLines :: [BriDoc] -> m ()
+    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
@@ -360,9 +376,7 @@ layoutBriDocM = \case
             colss = colSpacingss <&> \spss -> case reverse spss of
               [] -> []
               (xN:xR) ->
-                  reverse $ (if lastFlag then fLast else fInit) xN : fmap
+                reverse $ (if lastFlag then fLast else fInit) xN : fmap fInit xR
-                    fInit
-                    xR
              where
               fLast (ColumnSpacingLeaf len ) = len
               fLast (ColumnSpacingRef len _) = len
@@ -460,19 +474,18 @@ layoutBriDocM = \case
     $ c { _cbs_map = IntMapS.insert ind (lastFlag, space) $ _cbs_map c }
   return info
 
-  processInfo :: ColMap2 -> ColInfo -> m ()
+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 <-
+    alignMode <- mAsk <&> _conf_layout .> _lconfig_columnAlignMode .> confUnpack
-        mAsk <&> _conf_layout .> _lconfig_columnAlignMode .> confUnpack
     curX      <- do
       state <- mGet
-        return
+      return $ either id (const 0) (_lstate_curYOrAddNewline state) + fromMaybe
-          $ either id (const 0) (_lstate_curYOrAddNewline state)
+        0
-          + fromMaybe 0 (_lstate_addSepSpace state)
+        (_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
+    let fixedPosXs = case alignMode of
-        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 :: 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
-  }