{-# 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.Printer
Copyright   : (c) Dennis Gosnell, 2016
License     : BSD-style (see LICENSE file)
Maintainer  : cdep.illabout@gmail.com
Stability   : experimental
Portability : POSIX

-}
module Text.Pretty.Simple.Internal.ExprToOutput
  where

#if __GLASGOW_HASKELL__ < 710
-- We don't need this import for GHC 7.10 as it exports all required functions
-- from Prelude
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)

-- $setup
-- >>> :set -XOverloadedStrings
-- >>> import Control.Monad.State (State)
-- >>> :{
-- let test :: PrinterState -> State PrinterState [Output] -> [Output]
--     test initState state = evalState state initState
--     testInit :: State PrinterState [Output] -> [Output]
--     testInit = test initPrinterState
-- :}

-- | Newtype around 'Int' to represent a line number.  After a newline, the
-- 'LineNum' will increase by 1.
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)

-- | Smart-constructor for 'PrinterState'.
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)

-- | Print a surrounding expression (like @\[\]@ or @\{\}@ or @\(\)@).
--
-- If the 'CommaSeparated' expressions are empty, just print the start and end
-- markers.
--
-- >>> testInit $ putSurroundExpr "[" "]" (CommaSeparated [])
-- [Output {outputNestLevel = NestLevel {unNestLevel = 0}, outputOutputType = OutputOpenBracket},Output {outputNestLevel = NestLevel {unNestLevel = 0}, outputOutputType = OutputCloseBracket}]
--
-- If there is only one expression, and it will print out on one line, then
-- just print everything all on one line, with spaces around the expressions.
--
-- >>> testInit $ putSurroundExpr "{" "}" (CommaSeparated [[Other "hello"]])
-- [Output {outputNestLevel = NestLevel {unNestLevel = 0}, outputOutputType = OutputOpenBrace},Output {outputNestLevel = NestLevel {unNestLevel = 0}, outputOutputType = OutputOther " "},Output {outputNestLevel = NestLevel {unNestLevel = 0}, outputOutputType = OutputOther "hello"},Output {outputNestLevel = NestLevel {unNestLevel = 0}, outputOutputType = OutputOther " "},Output {outputNestLevel = NestLevel {unNestLevel = 0}, outputOutputType = OutputCloseBrace}]
--
-- If there is only one expression, but it will print out on multiple lines,
-- then go to newline and print out on multiple lines.
--
-- >>> 1 + 1  -- TODO: Example here.
-- 2
--
-- If there are multiple expressions, then first go to a newline.
-- Print out on multiple lines.
--
-- >>> 1 + 1  -- TODO: Example here.
-- 2
putSurroundExpr
  :: MonadState PrinterState m
  => OutputType
  -> OutputType
  -> CommaSeparated [Expr] -- ^ comma separated inner expression.
  -> 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 (CharLit string) = do
  nest <- gets nestLevel
  when (nest < 0) $ addToNestLevel 1
  addOutputs [OutputCharLit 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

-- | A function that performs optimizations and modifications to a list of
-- input 'Expr's.
--
-- An sample of an optimization is 'removeEmptyInnerCommaSeparatedExprList'
-- which removes empty inner lists in a 'CommaSeparated' value.
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

-- | Remove empty lists from a list of lists.
--
-- >>> removeEmptyList [[1,2,3], [], [4,5]]
-- [[1,2,3],[4,5]]
--
-- >>> removeEmptyList [[]]
-- []
--
-- >>> removeEmptyList [[1]]
-- [[1]]
--
-- >>> removeEmptyList [[1,2], [10,20], [100,200]]
-- [[1,2],[10,20],[100,200]]
removeEmptyList :: forall a . [[a]] -> [[a]]
removeEmptyList = foldr f []
  where
    f :: [a] -> [[a]] -> [[a]]
    f [] accum = accum
    f a accum = [a] <> accum