{-# LANGUAGE FlexibleContexts #-}
module Fay.Types.Printer
  ( PrintReader(..)
  , defaultPrintReader
  , PrintWriter(..)
  , pwOutputString
  , PrintState(..)
  , defaultPrintState
  , Printer(..)
  , Printable(..)
  , execPrinter
  , indented
  , newline
  , write
  , askIf
  , mapping
  ) where

import Fay.Compiler.Prelude

import Control.Monad.RWS               (RWS, asks, execRWS, get, modify, put, tell)
import Data.List                       (elemIndex)
import Data.Maybe                      (fromMaybe)
import Data.String
import Language.Haskell.Exts
import SourceMap.Types
import qualified Data.Semigroup as SG

-- | Global options of the printer
data PrintReader = PrintReader
  { PrintReader -> Bool
prPretty          :: Bool      -- ^ Are we to pretty print?
  , PrintReader -> Bool
prPrettyThunks    :: Bool      -- ^ Use pretty thunk names?
  , PrintReader -> Bool
prPrettyOperators :: Bool      -- ^ Use pretty operators?
  }

-- | default printer options (non-pretty printing)
defaultPrintReader :: PrintReader
defaultPrintReader :: PrintReader
defaultPrintReader = Bool -> Bool -> Bool -> PrintReader
PrintReader Bool
False Bool
False Bool
False

-- | Output of printer
data PrintWriter = PrintWriter
  { PrintWriter -> [Mapping]
pwMappings    :: [Mapping] -- ^ Source mappings.
  , PrintWriter -> ShowS
pwOutput      :: ShowS     -- ^ The current output.
  }

pwOutputString :: PrintWriter -> String
pwOutputString :: PrintWriter -> String
pwOutputString (PrintWriter [Mapping]
_ ShowS
out) = ShowS
out String
""

instance SG.Semigroup PrintWriter where
  (PrintWriter [Mapping]
a ShowS
b) <> :: PrintWriter -> PrintWriter -> PrintWriter
<> (PrintWriter [Mapping]
x ShowS
y) = [Mapping] -> ShowS -> PrintWriter
PrintWriter ([Mapping]
a [Mapping] -> [Mapping] -> [Mapping]
forall a. [a] -> [a] -> [a]
++ [Mapping]
x) (ShowS
b ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
y)

-- | Output concatenation
instance Monoid PrintWriter where
  mempty :: PrintWriter
mempty =  [Mapping] -> ShowS -> PrintWriter
PrintWriter [] ShowS
forall a. a -> a
id
  mappend :: PrintWriter -> PrintWriter -> PrintWriter
mappend = PrintWriter -> PrintWriter -> PrintWriter
forall a. Semigroup a => a -> a -> a
(<>)

-- | The state of the pretty printer.
data PrintState = PrintState
  { PrintState -> Int
psLine        :: Int       -- ^ The current line.
  , PrintState -> Int
psColumn      :: Int       -- ^ Current column.
  , PrintState -> Int
psIndentLevel :: Int       -- ^ Current indentation level.
  , PrintState -> Bool
psNewline     :: Bool      -- ^ Just outputted a newline?
  }

-- | Default state.
defaultPrintState :: PrintState
defaultPrintState :: PrintState
defaultPrintState = Int -> Int -> Int -> Bool -> PrintState
PrintState Int
0 Int
0 Int
0 Bool
False

-- | The printer.
newtype Printer = Printer
  { Printer -> RWS PrintReader PrintWriter PrintState ()
runPrinter :: RWS PrintReader PrintWriter PrintState () }

execPrinter :: Printer -> PrintReader -> PrintWriter
execPrinter :: Printer -> PrintReader -> PrintWriter
execPrinter (Printer RWS PrintReader PrintWriter PrintState ()
p) PrintReader
r = (PrintState, PrintWriter) -> PrintWriter
forall a b. (a, b) -> b
snd ((PrintState, PrintWriter) -> PrintWriter)
-> (PrintState, PrintWriter) -> PrintWriter
forall a b. (a -> b) -> a -> b
$ RWS PrintReader PrintWriter PrintState ()
-> PrintReader -> PrintState -> (PrintState, PrintWriter)
forall r w s a. RWS r w s a -> r -> s -> (s, w)
execRWS RWS PrintReader PrintWriter PrintState ()
p PrintReader
r PrintState
defaultPrintState

instance SG.Semigroup Printer where
  (Printer RWS PrintReader PrintWriter PrintState ()
p) <> :: Printer -> Printer -> Printer
<> (Printer RWS PrintReader PrintWriter PrintState ()
q) = RWS PrintReader PrintWriter PrintState () -> Printer
Printer (RWS PrintReader PrintWriter PrintState ()
p RWS PrintReader PrintWriter PrintState ()
-> RWS PrintReader PrintWriter PrintState ()
-> RWS PrintReader PrintWriter PrintState ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> RWS PrintReader PrintWriter PrintState ()
q)

instance Monoid Printer where
  mempty :: Printer
mempty = RWS PrintReader PrintWriter PrintState () -> Printer
Printer (RWS PrintReader PrintWriter PrintState () -> Printer)
-> RWS PrintReader PrintWriter PrintState () -> Printer
forall a b. (a -> b) -> a -> b
$ () -> RWS PrintReader PrintWriter PrintState ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  mappend :: Printer -> Printer -> Printer
mappend = Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
(<>)

-- | Print some value.
class Printable a where
  printJS :: a -> Printer

-- | Print the given printer indented.
indented :: Printer -> Printer
indented :: Printer -> Printer
indented (Printer RWS PrintReader PrintWriter PrintState ()
p) = RWS PrintReader PrintWriter PrintState () -> Printer
Printer (RWS PrintReader PrintWriter PrintState () -> Printer)
-> RWS PrintReader PrintWriter PrintState () -> Printer
forall a b. (a -> b) -> a -> b
$ (PrintReader -> Bool)
-> RWST PrintReader PrintWriter PrintState Identity Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PrintReader -> Bool
prPretty RWST PrintReader PrintWriter PrintState Identity Bool
-> (Bool -> RWS PrintReader PrintWriter PrintState ())
-> RWS PrintReader PrintWriter PrintState ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
pretty ->
    Bool
-> RWS PrintReader PrintWriter PrintState ()
-> RWS PrintReader PrintWriter PrintState ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
pretty (Int -> RWS PrintReader PrintWriter PrintState ()
forall (m :: * -> *). MonadState PrintState m => Int -> m ()
addToIndentLevel Int
1) RWS PrintReader PrintWriter PrintState ()
-> RWS PrintReader PrintWriter PrintState ()
-> RWS PrintReader PrintWriter PrintState ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> RWS PrintReader PrintWriter PrintState ()
p RWS PrintReader PrintWriter PrintState ()
-> RWS PrintReader PrintWriter PrintState ()
-> RWS PrintReader PrintWriter PrintState ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool
-> RWS PrintReader PrintWriter PrintState ()
-> RWS PrintReader PrintWriter PrintState ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
pretty (Int -> RWS PrintReader PrintWriter PrintState ()
forall (m :: * -> *). MonadState PrintState m => Int -> m ()
addToIndentLevel (-Int
1))
  where addToIndentLevel :: Int -> m ()
addToIndentLevel Int
d = (PrintState -> PrintState) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\PrintState
ps -> PrintState
ps { psIndentLevel :: Int
psIndentLevel = PrintState -> Int
psIndentLevel PrintState
ps Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
d })

-- | Output a newline and makes next line indented when prPretty is True.
--   Does nothing when prPretty is False
newline :: Printer
newline :: Printer
newline = RWS PrintReader PrintWriter PrintState () -> Printer
Printer (RWS PrintReader PrintWriter PrintState () -> Printer)
-> RWS PrintReader PrintWriter PrintState () -> Printer
forall a b. (a -> b) -> a -> b
$ (PrintReader -> Bool)
-> RWST PrintReader PrintWriter PrintState Identity Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PrintReader -> Bool
prPretty RWST PrintReader PrintWriter PrintState Identity Bool
-> (Bool -> RWS PrintReader PrintWriter PrintState ())
-> RWS PrintReader PrintWriter PrintState ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Bool
 -> RWS PrintReader PrintWriter PrintState ()
 -> RWS PrintReader PrintWriter PrintState ())
-> RWS PrintReader PrintWriter PrintState ()
-> Bool
-> RWS PrintReader PrintWriter PrintState ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Bool
-> RWS PrintReader PrintWriter PrintState ()
-> RWS PrintReader PrintWriter PrintState ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when RWS PrintReader PrintWriter PrintState ()
writeNewline
  where writeNewline :: RWS PrintReader PrintWriter PrintState ()
writeNewline = String -> RWS PrintReader PrintWriter PrintState ()
writeRWS String
"\n" RWS PrintReader PrintWriter PrintState ()
-> RWS PrintReader PrintWriter PrintState ()
-> RWS PrintReader PrintWriter PrintState ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (PrintState -> PrintState)
-> RWS PrintReader PrintWriter PrintState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\PrintState
s -> PrintState
s { psNewline :: Bool
psNewline = Bool
True })

-- | Write out a raw string, respecting the indentation
--   Note: if you pass a string with newline characters, it will print them
--   out even if prPretty is set to False. Also next line won't be indented.
--   If you want write a smart newline (that is the one which will be written
--   out only if prPretty is true, and after which the line will be indented)
--   use `newline`)
write :: String -> Printer
write :: String -> Printer
write = RWS PrintReader PrintWriter PrintState () -> Printer
Printer (RWS PrintReader PrintWriter PrintState () -> Printer)
-> (String -> RWS PrintReader PrintWriter PrintState ())
-> String
-> Printer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> RWS PrintReader PrintWriter PrintState ()
writeRWS

writeRWS :: String -> RWS PrintReader PrintWriter PrintState ()
writeRWS :: String -> RWS PrintReader PrintWriter PrintState ()
writeRWS String
x = do
  PrintState
ps <- RWST PrintReader PrintWriter PrintState Identity PrintState
forall s (m :: * -> *). MonadState s m => m s
get
  let out :: String
out = if PrintState -> Bool
psNewline PrintState
ps
               then Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* PrintState -> Int
psIndentLevel PrintState
ps) Char
' ' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
x
               else String
x
  PrintWriter -> RWS PrintReader PrintWriter PrintState ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell PrintWriter
forall a. Monoid a => a
mempty { pwOutput :: ShowS
pwOutput = (String
outString -> ShowS
forall a. [a] -> [a] -> [a]
++) }

  let newLines :: Int
newLines = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n') String
x)
  PrintState -> RWS PrintReader PrintWriter PrintState ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put PrintState
ps { psLine :: Int
psLine    = PrintState -> Int
psLine PrintState
ps Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
newLines
         , psColumn :: Int
psColumn  = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe (PrintState -> Int
psColumn PrintState
ps Int -> Int -> Int
forall a. Num a => a -> a -> a
+ String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
x) (Maybe Int -> Int) -> (String -> Maybe Int) -> String -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex Char
'\n' (String -> Int) -> String -> Int
forall a b. (a -> b) -> a -> b
$ ShowS
forall a. [a] -> [a]
reverse String
x
         , psNewline :: Bool
psNewline = Bool
False
         }

-- | Write out a string, updating the current position information.
instance IsString Printer where
  fromString :: String -> Printer
fromString = String -> Printer
write

-- | exec one of Printers depending on PrintReader property.
askIf :: (PrintReader -> Bool) -> Printer -> Printer -> Printer
askIf :: (PrintReader -> Bool) -> Printer -> Printer -> Printer
askIf PrintReader -> Bool
f (Printer RWS PrintReader PrintWriter PrintState ()
p) (Printer RWS PrintReader PrintWriter PrintState ()
q) = RWS PrintReader PrintWriter PrintState () -> Printer
Printer (RWS PrintReader PrintWriter PrintState () -> Printer)
-> RWS PrintReader PrintWriter PrintState () -> Printer
forall a b. (a -> b) -> a -> b
$ (PrintReader -> Bool)
-> RWST PrintReader PrintWriter PrintState Identity Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PrintReader -> Bool
f RWST PrintReader PrintWriter PrintState Identity Bool
-> (Bool -> RWS PrintReader PrintWriter PrintState ())
-> RWS PrintReader PrintWriter PrintState ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\Bool
b -> if Bool
b then RWS PrintReader PrintWriter PrintState ()
p else RWS PrintReader PrintWriter PrintState ()
q)

-- | Generate a mapping from the Haskell location to the current point in the output.
mapping :: SrcSpan -> Printer
mapping :: SrcSpan -> Printer
mapping SrcSpan
srcSpan = RWS PrintReader PrintWriter PrintState () -> Printer
Printer (RWS PrintReader PrintWriter PrintState () -> Printer)
-> RWS PrintReader PrintWriter PrintState () -> Printer
forall a b. (a -> b) -> a -> b
$ RWST PrintReader PrintWriter PrintState Identity PrintState
forall s (m :: * -> *). MonadState s m => m s
get RWST PrintReader PrintWriter PrintState Identity PrintState
-> (PrintState -> RWS PrintReader PrintWriter PrintState ())
-> RWS PrintReader PrintWriter PrintState ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \PrintState
ps ->
    let m :: Mapping
m = Mapping :: Pos -> Maybe Pos -> Maybe String -> Maybe Text -> Mapping
Mapping { mapGenerated :: Pos
mapGenerated = Int32 -> Int32 -> Pos
Pos (Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (PrintState -> Int
psLine PrintState
ps))
                                         (Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (PrintState -> Int
psColumn PrintState
ps))
                    , mapOriginal :: Maybe Pos
mapOriginal = Pos -> Maybe Pos
forall a. a -> Maybe a
Just (Int32 -> Int32 -> Pos
Pos (Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (SrcSpan -> Int
srcSpanStartLine SrcSpan
srcSpan))
                                              (Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (SrcSpan -> Int
srcSpanStartColumn SrcSpan
srcSpan) Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
- Int32
1))
                    , mapSourceFile :: Maybe String
mapSourceFile = String -> Maybe String
forall a. a -> Maybe a
Just (SrcSpan -> String
srcSpanFilename SrcSpan
srcSpan)
                    , mapName :: Maybe Text
mapName = Maybe Text
forall a. Maybe a
Nothing
                    }
    in PrintWriter -> RWS PrintReader PrintWriter PrintState ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (PrintWriter -> RWS PrintReader PrintWriter PrintState ())
-> PrintWriter -> RWS PrintReader PrintWriter PrintState ()
forall a b. (a -> b) -> a -> b
$ PrintWriter
forall a. Monoid a => a
mempty { pwMappings :: [Mapping]
pwMappings = [Mapping
m] }