{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module Text.Pretty.Simple.Internal.ExprToOutput
where
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
#endif
import Control.Monad (when)
import Control.Monad.State (MonadState, evalState, gets, modify)
import Data.Data (Data)
import Data.Monoid ((<>))
import Data.List (intersperse)
import Data.Typeable (Typeable)
import GHC.Generics (Generic)
import Text.Pretty.Simple.Internal.Expr (CommaSeparated(..), Expr(..))
import Text.Pretty.Simple.Internal.Output
(NestLevel(..), Output(..), OutputType(..), unNestLevel)
newtype LineNum = LineNum { unLineNum :: Int }
deriving (Data, Eq, Generic, Num, Ord, Read, Show, Typeable)
data PrinterState = PrinterState
{ currLine :: {-# UNPACK #-} !LineNum
, nestLevel :: {-# UNPACK #-} !NestLevel
} deriving (Eq, Data, Generic, Show, Typeable)
printerState :: LineNum -> NestLevel -> PrinterState
printerState currLineNum nestNum =
PrinterState
{ currLine = currLineNum
, nestLevel = nestNum
}
addOutput
:: MonadState PrinterState m
=> OutputType -> m Output
addOutput outputType = do
nest <- gets nestLevel
return $ Output nest outputType
addOutputs
:: MonadState PrinterState m
=> [OutputType] -> m [Output]
addOutputs outputTypes = do
nest <- gets nestLevel
return $ Output nest <$> outputTypes
initPrinterState :: PrinterState
initPrinterState = printerState 0 (-1)
putSurroundExpr
:: MonadState PrinterState m
=> OutputType
-> OutputType
-> CommaSeparated [Expr]
-> m [Output]
putSurroundExpr startOutputType endOutputType (CommaSeparated []) = do
addToNestLevel 1
outputs <- addOutputs [startOutputType, endOutputType]
addToNestLevel (-1)
return outputs
putSurroundExpr startOutputType endOutputType (CommaSeparated [exprs]) = do
addToNestLevel 1
let (thisLayerMulti, nextLayerMulti) = thisAndNextMulti exprs
maybeNL <- if thisLayerMulti
then newLineAndDoIndent
else return []
start <- addOutputs [startOutputType, OutputOther " "]
middle <- concat <$> traverse putExpression exprs
nlOrSpace <- if nextLayerMulti
then newLineAndDoIndent
else (:[]) <$> (addOutput $ OutputOther " ")
end <- addOutput endOutputType
addToNestLevel (-1)
return $ maybeNL <> start <> middle <> nlOrSpace <> [end]
where
thisAndNextMulti = (\(a,b) -> (or a, or b)) . unzip . map isMultiLine
isMultiLine (Brackets commaSeparated) = isMultiLine' commaSeparated
isMultiLine (Braces commaSeparated) = isMultiLine' commaSeparated
isMultiLine (Parens commaSeparated) = isMultiLine' commaSeparated
isMultiLine _ = (False, False)
isMultiLine' (CommaSeparated []) = (False, False)
isMultiLine' (CommaSeparated [es]) = (True, fst $ thisAndNextMulti es)
isMultiLine' _ = (True, True)
putSurroundExpr startOutputType endOutputType commaSeparated = do
addToNestLevel 1
nl <- newLineAndDoIndent
start <- addOutputs [startOutputType, OutputOther " "]
middle <- putCommaSep commaSeparated
nl2 <- newLineAndDoIndent
end <- addOutput endOutputType
addToNestLevel (-1)
endSpace <- addOutput $ OutputOther " "
return $ nl <> start <> middle <> nl2 <> [end, endSpace]
putCommaSep
:: forall m.
MonadState PrinterState m
=> CommaSeparated [Expr] -> m [Output]
putCommaSep (CommaSeparated expressionsList) =
concat <$> (sequence $ intersperse putComma evaledExpressionList)
where
evaledExpressionList :: [m [Output]]
evaledExpressionList =
(concat <.> traverse putExpression) <$> expressionsList
(f <.> g) x = f <$> g x
putComma
:: MonadState PrinterState m
=> m [Output]
putComma = do
nl <- newLineAndDoIndent
outputs <- addOutputs [OutputComma, OutputOther " "]
return $ nl <> outputs
doIndent :: MonadState PrinterState m => m [Output]
doIndent = do
nest <- gets $ unNestLevel . nestLevel
addOutputs $ replicate nest OutputIndent
newLine
:: MonadState PrinterState m
=> m Output
newLine = do
output <- addOutput OutputNewLine
addToCurrentLine 1
return output
newLineAndDoIndent
:: MonadState PrinterState m
=> m [Output]
newLineAndDoIndent = do
nl <- newLine
indent <- doIndent
return $ nl:indent
addToNestLevel
:: MonadState PrinterState m
=> NestLevel -> m ()
addToNestLevel diff =
modify (\printState -> printState {nestLevel = nestLevel printState + diff})
addToCurrentLine
:: MonadState PrinterState m
=> LineNum -> m ()
addToCurrentLine diff =
modify (\printState -> printState {currLine = currLine printState + diff})
putExpression :: MonadState PrinterState m => Expr -> m [Output]
putExpression (Brackets commaSeparated) =
putSurroundExpr OutputOpenBracket OutputCloseBracket commaSeparated
putExpression (Braces commaSeparated) =
putSurroundExpr OutputOpenBrace OutputCloseBrace commaSeparated
putExpression (Parens commaSeparated) =
putSurroundExpr OutputOpenParen OutputCloseParen commaSeparated
putExpression (StringLit string) = do
nest <- gets nestLevel
when (nest < 0) $ addToNestLevel 1
addOutputs [OutputStringLit string, OutputOther " "]
putExpression (NumberLit integer) = do
nest <- gets nestLevel
when (nest < 0) $ addToNestLevel 1
(:[]) <$> (addOutput $ OutputNumberLit integer)
putExpression (Other string) = do
nest <- gets nestLevel
when (nest < 0) $ addToNestLevel 1
(:[]) <$> (addOutput $ OutputOther string)
runPrinterState :: PrinterState -> [Expr] -> [Output]
runPrinterState initState expressions =
concat $ evalState (traverse putExpression expressions) initState
runInitPrinterState :: [Expr] -> [Output]
runInitPrinterState = runPrinterState initPrinterState
expressionsToOutputs :: [Expr] -> [Output]
expressionsToOutputs = runInitPrinterState . modificationsExprList
modificationsExprList :: [Expr] -> [Expr]
modificationsExprList = removeEmptyInnerCommaSeparatedExprList
removeEmptyInnerCommaSeparatedExprList :: [Expr] -> [Expr]
removeEmptyInnerCommaSeparatedExprList = fmap removeEmptyInnerCommaSeparatedExpr
removeEmptyInnerCommaSeparatedExpr :: Expr -> Expr
removeEmptyInnerCommaSeparatedExpr (Brackets commaSeparated) =
Brackets $ removeEmptyInnerCommaSeparated commaSeparated
removeEmptyInnerCommaSeparatedExpr (Braces commaSeparated) =
Braces $ removeEmptyInnerCommaSeparated commaSeparated
removeEmptyInnerCommaSeparatedExpr (Parens commaSeparated) =
Parens $ removeEmptyInnerCommaSeparated commaSeparated
removeEmptyInnerCommaSeparatedExpr other = other
removeEmptyInnerCommaSeparated :: CommaSeparated [Expr] -> CommaSeparated [Expr]
removeEmptyInnerCommaSeparated (CommaSeparated commaSeps) =
CommaSeparated . fmap removeEmptyInnerCommaSeparatedExprList $
removeEmptyList commaSeps
removeEmptyList :: forall a . [[a]] -> [[a]]
removeEmptyList = foldr f []
where
f :: [a] -> [[a]] -> [[a]]
f [] accum = accum
f a accum = [a] <> accum