module Language.PureScript.Pretty.Common where
import Prelude
import Control.Monad.State (StateT, modify, get)
import Data.List (elemIndices, intersperse)
import Data.Text (Text)
import Data.Text qualified as T
import Language.PureScript.AST (SourcePos(..), SourceSpan(..), nullSourceSpan)
import Language.PureScript.CST.Lexer (isUnquotedKey)
import Text.PrettyPrint.Boxes (Box(..), emptyBox, text, top, vcat, (//))
import Text.PrettyPrint.Boxes qualified as Box
parensT :: Text -> Text
parensT :: Text -> Text
parensT Text
s = Text
"(" forall a. Semigroup a => a -> a -> a
<> Text
s forall a. Semigroup a => a -> a -> a
<> Text
")"
parensPos :: (Emit gen) => gen -> gen
parensPos :: forall gen. Emit gen => gen -> gen
parensPos gen
s = forall gen. Emit gen => Text -> gen
emit Text
"(" forall a. Semigroup a => a -> a -> a
<> gen
s forall a. Semigroup a => a -> a -> a
<> forall gen. Emit gen => Text -> gen
emit Text
")"
intercalate :: Monoid m => m -> [m] -> m
intercalate :: forall m. Monoid m => m -> [m] -> m
intercalate m
x [m]
xs = forall a. Monoid a => [a] -> a
mconcat (forall a. a -> [a] -> [a]
intersperse m
x [m]
xs)
class (Monoid gen) => Emit gen where
emit :: Text -> gen
addMapping :: SourceSpan -> gen
data SMap = SMap Text SourcePos SourcePos
newtype StrPos = StrPos (SourcePos, Text, [SMap])
instance Semigroup StrPos where
StrPos (SourcePos
a,Text
b,[SMap]
c) <> :: StrPos -> StrPos -> StrPos
<> StrPos (SourcePos
a',Text
b',[SMap]
c') = (SourcePos, Text, [SMap]) -> StrPos
StrPos (SourcePos
a SourcePos -> SourcePos -> SourcePos
`addPos` SourcePos
a', Text
b forall a. Semigroup a => a -> a -> a
<> Text
b', [SMap]
c forall a. [a] -> [a] -> [a]
++ (SourcePos -> SMap -> SMap
bumpPos SourcePos
a forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [SMap]
c'))
instance Monoid StrPos where
mempty :: StrPos
mempty = (SourcePos, Text, [SMap]) -> StrPos
StrPos (Int -> Int -> SourcePos
SourcePos Int
0 Int
0, Text
"", [])
mconcat :: [StrPos] -> StrPos
mconcat [StrPos]
ms =
let s' :: Text
s' = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\(StrPos(SourcePos
_, Text
s, [SMap]
_)) -> Text
s) [StrPos]
ms
(SourcePos
p, [[SMap]]
maps) = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (SourcePos, [[SMap]]) -> StrPos -> (SourcePos, [[SMap]])
plus (Int -> Int -> SourcePos
SourcePos Int
0 Int
0, []) [StrPos]
ms
in
(SourcePos, Text, [SMap]) -> StrPos
StrPos (SourcePos
p, Text
s', forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [[SMap]]
maps)
where
plus :: (SourcePos, [[SMap]]) -> StrPos -> (SourcePos, [[SMap]])
plus :: (SourcePos, [[SMap]]) -> StrPos -> (SourcePos, [[SMap]])
plus (SourcePos
a, [[SMap]]
c) (StrPos (SourcePos
a', Text
_, [SMap]
c')) = (SourcePos
a SourcePos -> SourcePos -> SourcePos
`addPos` SourcePos
a', (SourcePos -> SMap -> SMap
bumpPos SourcePos
a forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [SMap]
c') forall a. a -> [a] -> [a]
: [[SMap]]
c)
instance Emit StrPos where
emit :: Text -> StrPos
emit Text
str =
let newlines :: [Int]
newlines = forall a. Eq a => a -> [a] -> [Int]
elemIndices Char
'\n' (Text -> String
T.unpack Text
str)
index :: Int
index = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
newlines then Int
0 else forall a. [a] -> a
last [Int]
newlines forall a. Num a => a -> a -> a
+ Int
1
in
(SourcePos, Text, [SMap]) -> StrPos
StrPos (SourcePos { sourcePosLine :: Int
sourcePosLine = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
newlines, sourcePosColumn :: Int
sourcePosColumn = Text -> Int
T.length Text
str forall a. Num a => a -> a -> a
- Int
index }, Text
str, [])
addMapping :: SourceSpan -> StrPos
addMapping ss :: SourceSpan
ss@SourceSpan { spanName :: SourceSpan -> String
spanName = String
file, spanStart :: SourceSpan -> SourcePos
spanStart = SourcePos
startPos } = (SourcePos, Text, [SMap]) -> StrPos
StrPos (SourcePos
zeroPos, forall a. Monoid a => a
mempty, [ SMap
mapping | SourceSpan
ss forall a. Eq a => a -> a -> Bool
/= SourceSpan
nullSourceSpan ])
where
mapping :: SMap
mapping = Text -> SourcePos -> SourcePos -> SMap
SMap (String -> Text
T.pack String
file) SourcePos
startPos SourcePos
zeroPos
zeroPos :: SourcePos
zeroPos = Int -> Int -> SourcePos
SourcePos Int
0 Int
0
newtype PlainString = PlainString Text deriving (NonEmpty PlainString -> PlainString
PlainString -> PlainString -> PlainString
forall b. Integral b => b -> PlainString -> PlainString
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> PlainString -> PlainString
$cstimes :: forall b. Integral b => b -> PlainString -> PlainString
sconcat :: NonEmpty PlainString -> PlainString
$csconcat :: NonEmpty PlainString -> PlainString
<> :: PlainString -> PlainString -> PlainString
$c<> :: PlainString -> PlainString -> PlainString
Semigroup, Semigroup PlainString
PlainString
[PlainString] -> PlainString
PlainString -> PlainString -> PlainString
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [PlainString] -> PlainString
$cmconcat :: [PlainString] -> PlainString
mappend :: PlainString -> PlainString -> PlainString
$cmappend :: PlainString -> PlainString -> PlainString
mempty :: PlainString
$cmempty :: PlainString
Monoid)
runPlainString :: PlainString -> Text
runPlainString :: PlainString -> Text
runPlainString (PlainString Text
s) = Text
s
instance Emit PlainString where
emit :: Text -> PlainString
emit = Text -> PlainString
PlainString
addMapping :: SourceSpan -> PlainString
addMapping SourceSpan
_ = forall a. Monoid a => a
mempty
addMapping' :: (Emit gen) => Maybe SourceSpan -> gen
addMapping' :: forall gen. Emit gen => Maybe SourceSpan -> gen
addMapping' (Just SourceSpan
ss) = forall gen. Emit gen => SourceSpan -> gen
addMapping SourceSpan
ss
addMapping' Maybe SourceSpan
Nothing = forall a. Monoid a => a
mempty
bumpPos :: SourcePos -> SMap -> SMap
bumpPos :: SourcePos -> SMap -> SMap
bumpPos SourcePos
p (SMap Text
f SourcePos
s SourcePos
g) = Text -> SourcePos -> SourcePos -> SMap
SMap Text
f SourcePos
s forall a b. (a -> b) -> a -> b
$ SourcePos
p SourcePos -> SourcePos -> SourcePos
`addPos` SourcePos
g
addPos :: SourcePos -> SourcePos -> SourcePos
addPos :: SourcePos -> SourcePos -> SourcePos
addPos (SourcePos Int
n Int
m) (SourcePos Int
0 Int
m') = Int -> Int -> SourcePos
SourcePos Int
n (Int
m forall a. Num a => a -> a -> a
+ Int
m')
addPos (SourcePos Int
n Int
_) (SourcePos Int
n' Int
m') = Int -> Int -> SourcePos
SourcePos (Int
n forall a. Num a => a -> a -> a
+ Int
n') Int
m'
data PrinterState = PrinterState { PrinterState -> Int
indent :: Int }
blockIndent :: Int
blockIndent :: Int
blockIndent = Int
4
withIndent :: StateT PrinterState Maybe gen -> StateT PrinterState Maybe gen
withIndent :: forall gen.
StateT PrinterState Maybe gen -> StateT PrinterState Maybe gen
withIndent StateT PrinterState Maybe gen
action = do
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \PrinterState
st -> PrinterState
st { indent :: Int
indent = PrinterState -> Int
indent PrinterState
st forall a. Num a => a -> a -> a
+ Int
blockIndent }
gen
result <- StateT PrinterState Maybe gen
action
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \PrinterState
st -> PrinterState
st { indent :: Int
indent = PrinterState -> Int
indent PrinterState
st forall a. Num a => a -> a -> a
- Int
blockIndent }
forall (m :: * -> *) a. Monad m => a -> m a
return gen
result
currentIndent :: (Emit gen) => StateT PrinterState Maybe gen
currentIndent :: forall gen. Emit gen => StateT PrinterState Maybe gen
currentIndent = do
PrinterState
current <- forall s (m :: * -> *). MonadState s m => m s
get
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall gen. Emit gen => Text -> gen
emit forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.replicate (PrinterState -> Int
indent PrinterState
current) Text
" "
objectKeyRequiresQuoting :: Text -> Bool
objectKeyRequiresQuoting :: Text -> Bool
objectKeyRequiresQuoting = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
isUnquotedKey
before :: Box -> Box -> Box
before :: Box -> Box -> Box
before Box
b1 Box
b2 | Box -> Int
rows Box
b1 forall a. Ord a => a -> a -> Bool
> Int
1 = Box
b1 Box -> Box -> Box
// Box
b2
| Bool
otherwise = Box
b1 Box -> Box -> Box
Box.<> Box
b2
beforeWithSpace :: Box -> Box -> Box
beforeWithSpace :: Box -> Box -> Box
beforeWithSpace Box
b1 = Box -> Box -> Box
before (Box
b1 Box -> Box -> Box
Box.<> String -> Box
text String
" ")
endWith :: Box -> Box -> Box
endWith :: Box -> Box -> Box
endWith Box
l Box
r = Box
l Box -> Box -> Box
Box.<> forall (f :: * -> *). Foldable f => Alignment -> f Box -> Box
vcat Alignment
top [Int -> Int -> Box
emptyBox (Box -> Int
rows Box
l forall a. Num a => a -> a -> a
- Int
1) (Box -> Int
cols Box
r), Box
r]