-- |
-- Common pretty-printing utility functions
--
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 qualified Data.Text as T

import Language.PureScript.AST (SourcePos(..), SourceSpan(..), nullSourceSpan)
import Language.PureScript.CST.Lexer (isUnquotedKey)

import Text.PrettyPrint.Boxes hiding ((<>))
import qualified Text.PrettyPrint.Boxes 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
")"

-- |
-- Generalize intercalate slightly for monoids
--
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

-- |
-- String with length and source-map entries
--
newtype StrPos = StrPos (SourcePos, Text, [SMap])

-- |
-- Make a monoid where append consists of concatenating the string part, adding the lengths
-- appropriately and advancing source mappings on the right hand side to account for
-- the length of the left.
--
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
  -- |
  -- Augment a string with its length (rows/column)
  --
  emit :: Text -> StrPos
emit Text
str =
    -- TODO(Christoph): get rid of T.unpack
    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, [])

  -- |
  -- Add a new mapping entry for given source position with initially zero generated position
  --
  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 }

-- |
-- Number of characters per indentation level
--
blockIndent :: Int
blockIndent :: Int
blockIndent = Int
4

-- |
-- Pretty print with a new indentation level
--
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

-- |
-- Get the current indentation level
--
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

-- | Place a box before another, vertically when the first box takes up multiple lines.
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
" ")

-- | Place a Box on the bottom right of another
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]