module Text.Pretty.Simple.Internal.Printer
where
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
#endif
import Control.Lens (Lens', (%=), (<>=), (.=), (+=), lens, use, view)
import Control.Lens.TH (makeLenses)
import Control.Monad (when)
import Control.Monad.State (MonadState, execState)
import Data.Data (Data)
import Data.Foldable (traverse_)
import Data.MonoTraversable (headEx)
import Data.Semigroup ((<>))
import Data.Sequences (intersperse, tailEx)
import Data.Typeable (Typeable)
import Debug.Trace (traceM)
import GHC.Generics (Generic)
import Text.Pretty.Simple.Internal.Expr (CommaSeparated(..), Expr(..))
data PrinterState = PrinterState
{ _currLine :: Int
, _currCharOnLine :: Int
, _indentStack :: [Int]
, _printerString :: String
} deriving (Eq, Data, Generic, Show, Typeable)
makeLenses ''PrinterState
printerState :: Int -> Int -> [Int] -> String -> PrinterState
printerState currLineNum currCharNum stack string =
PrinterState
{ _currLine = currLineNum
, _currCharOnLine = currCharNum
, _indentStack = stack
, _printerString = string
}
initPrinterState :: PrinterState
initPrinterState = printerState 0 0 [0] ""
_headEx :: Lens' [Int] Int
_headEx = lens headEx f
where
f :: [Int] -> Int -> [Int]
f [] _ = []
f (_:t) a = a:t
latestIndent :: Lens' PrinterState Int
latestIndent = indentStack . _headEx
popIndent :: MonadState PrinterState m => m ()
popIndent = indentStack %= tailEx
setIndentAtCurrChar
:: MonadState PrinterState m
=> m ()
setIndentAtCurrChar = do
currChar <- use currCharOnLine
indents <- use indentStack
indentStack .= currChar : indents
putOpeningSymbol :: MonadState PrinterState m => String -> m ()
putOpeningSymbol symbol = do
setIndentAtCurrChar
let symbolWithSpace = symbol <> " "
currCharOnLine += length symbolWithSpace
printerString <>= symbolWithSpace
putClosingSymbol :: MonadState PrinterState m => String -> m ()
putClosingSymbol symbol = do
popIndent
currCharOnLine += length symbol
printerString <>= symbol
putComma
:: MonadState PrinterState m
=> m ()
putComma = do
newLineAndDoIndent
let symbolWithSpace = ", " :: String
currCharOnLine += length symbolWithSpace
printerString <>= symbolWithSpace
putCommaSep
:: forall m.
MonadState PrinterState m
=> CommaSeparated [Expr] -> m ()
putCommaSep (CommaSeparated expressionsList) =
sequence_ $ intersperse putComma evaledExpressionList
where
evaledExpressionList :: [m ()]
evaledExpressionList =
fmap (traverse_ putExpression) expressionsList
putString :: MonadState PrinterState m => String -> m ()
putString string = do
currCharOnLine += length string
printerString <>= string
putSurroundExpr
:: MonadState PrinterState m
=> String
-> String
-> CommaSeparated [Expr]
-> m ()
putSurroundExpr startMarker endMarker (CommaSeparated []) =
putString $ startMarker <> endMarker
putSurroundExpr startMarker endMarker (CommaSeparated [[]]) =
putString $ startMarker <> endMarker
putSurroundExpr startMarker endMarker (CommaSeparated [exprs]) = do
putString $ startMarker <> " "
startingLineNum <- use currLine
traverse_ putExpression exprs
endingLineNum <- use currLine
if endingLineNum > startingLineNum
then do
newLineAndDoIndent
putString endMarker
else putString $ " " <> endMarker
putSurroundExpr startMarker endMarker commaSeparated = do
charOnLine <- use currCharOnLine
when (charOnLine /= 0) $ do
newLineAndDoIndent
putString " "
putOpeningSymbol startMarker
putCommaSep commaSeparated
newLineAndDoIndent
putClosingSymbol endMarker
doIndent :: MonadState PrinterState m => m ()
doIndent = do
indent <- use latestIndent
currCharOnLine .= indent
printerString <>= replicate indent ' '
newLine
:: MonadState PrinterState m
=> m ()
newLine = do
printerString <>= "\n"
currCharOnLine .= 0
currLine += 1
newLineAndDoIndent
:: MonadState PrinterState m
=> m ()
newLineAndDoIndent = newLine >> doIndent
putExpression :: MonadState PrinterState m => Expr -> m ()
putExpression (Brackets commaSeparated) = putSurroundExpr "[" "]" commaSeparated
putExpression (Braces commaSeparated) = putSurroundExpr "{" "}" commaSeparated
putExpression (Parens commaSeparated) = putSurroundExpr "(" ")" commaSeparated
putExpression (StringLit string) = putString $ "\"" <> string <> "\""
putExpression (Other string) = putString string
expressionPrint :: [Expr] -> String
expressionPrint expressions =
view printerString $ execState (traverse putExpression expressions) initPrinterState