module Language.PureScript.Pretty.Common where
import Prelude ()
import Prelude.Compat
import Control.Monad.State (StateT, modify, get)
import Data.List (elemIndices, intersperse)
import Language.PureScript.Parser.Lexer (reservedPsNames, isSymbolChar)
import Language.PureScript.AST (SourcePos(..), SourceSpan(..))
import Text.PrettyPrint.Boxes
parens :: String -> String
parens s = '(':s ++ ")"
parensPos :: (Emit gen) => gen -> gen
parensPos s = emit "(" `mappend` s `mappend` emit ")"
intercalate :: Monoid m => m -> [m] -> m
intercalate x xs = mconcat (intersperse x xs)
class (Monoid gen) => Emit gen where
emit :: String -> gen
addMapping :: SourceSpan -> gen
data SMap = SMap String SourcePos SourcePos
newtype StrPos = StrPos (SourcePos, String, [SMap])
instance Monoid StrPos where
mempty = StrPos (SourcePos 0 0, "", [])
StrPos (a,b,c) `mappend` StrPos (a',b',c') = StrPos (a `addPos` a', b ++ b', c ++ (bumpPos a <$> c'))
mconcat ms =
let s' = concatMap (\(StrPos(_, s, _)) -> s) ms
(p, maps) = foldl plus (SourcePos 0 0, []) ms
in
StrPos (p, s', concat $ reverse maps)
where
plus :: (SourcePos, [[SMap]]) -> StrPos -> (SourcePos, [[SMap]])
plus (a, c) (StrPos (a', _, c')) = (a `addPos` a', (bumpPos a <$> c') : c)
instance Emit StrPos where
emit str =
let newlines = elemIndices '\n' str
index = if null newlines then 0 else last newlines + 1
in
StrPos (SourcePos { sourcePosLine = length newlines, sourcePosColumn = length str index }, str, [])
addMapping (SourceSpan { spanName = file, spanStart = startPos }) = StrPos (zeroPos, mempty, [mapping])
where
mapping = SMap file startPos zeroPos
zeroPos = SourcePos 0 0
newtype PlainString = PlainString String deriving Monoid
runPlainString :: PlainString -> String
runPlainString (PlainString s) = s
instance Emit PlainString where
emit = PlainString
addMapping _ = mempty
addMapping' :: (Emit gen) => Maybe SourceSpan -> gen
addMapping' (Just ss) = addMapping ss
addMapping' Nothing = mempty
bumpPos :: SourcePos -> SMap -> SMap
bumpPos p (SMap f s g) = SMap f s $ p `addPos` g
addPos :: SourcePos -> SourcePos -> SourcePos
addPos (SourcePos n m) (SourcePos 0 m') = SourcePos n (m+m')
addPos (SourcePos n _) (SourcePos n' m') = SourcePos (n+n') m'
data PrinterState = PrinterState { indent :: Int }
emptyPrinterState :: PrinterState
emptyPrinterState = PrinterState { indent = 0 }
blockIndent :: Int
blockIndent = 4
withIndent :: (Emit gen) => StateT PrinterState Maybe gen -> StateT PrinterState Maybe gen
withIndent action = do
modify $ \st -> st { indent = indent st + blockIndent }
result <- action
modify $ \st -> st { indent = indent st blockIndent }
return result
currentIndent :: (Emit gen) => StateT PrinterState Maybe gen
currentIndent = do
current <- get
return $ emit $ replicate (indent current) ' '
prettyPrintMany :: (Emit gen) => (a -> StateT PrinterState Maybe gen) -> [a] -> StateT PrinterState Maybe gen
prettyPrintMany f xs = do
ss <- mapM f xs
indentString <- currentIndent
return $ intercalate (emit "\n") $ map (\s -> mappend indentString s) ss
prettyPrintObjectKey :: String -> String
prettyPrintObjectKey s | s `elem` reservedPsNames = show s
| any isSymbolChar s = show s
| otherwise = s
before :: Box -> Box -> Box
before b1 b2 | rows b1 > 1 = b1 // b2
| otherwise = b1 <> b2
beforeWithSpace :: Box -> Box -> Box
beforeWithSpace b1 = before (b1 <> text " ")