{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE OverloadedStrings #-}

module Thermoprint.Server.Printer.Generic
       ( genericPrint
       ) where

import Thermoprint.Printout
import Thermoprint.API (PrintingError(..))
import Thermoprint.Server.Printer

import System.FileLock
import System.IO

import Data.Sequence (Seq, (|>), (<|), ViewL(..), viewl)
import qualified Data.Sequence as Seq

import qualified Data.ByteString.Lazy as Lazy (ByteString)
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Lazy.Char8 as CLBS

import qualified Data.Text.Lazy as Lazy (Text)
import qualified Data.Text.Lazy as TL
       
import Data.Encoding
import Data.Encoding.CP437
import Data.Word

import Control.Monad
import Control.Monad.Reader
import Control.Monad.Trans.State
import Control.Monad.IO.Class

import Control.Monad.Trans.Resource
import Data.Acquire

import Control.Exception.Base (IOException)
import Control.Monad.Catch

import Data.Foldable

import Data.List (genericReplicate, intercalate)

import Data.Int (Int64)

import Prelude hiding (mapM_, sequence_)

genericPrint :: FilePath -> PrinterMethod
genericPrint path = PM $ genericPrint' path

genericPrint' :: (MonadIO m, MonadMask m) => FilePath -> Printout -> m (Maybe PrintingError)
genericPrint' path = flip catches handlers . withLockedFile path . print
  where
    print printout handle = liftIO $ runReaderT (bracket_ initialize (render printout) finalize) handle >> return Nothing
    handlers = [ Handler $ return . Just . IOError . (show :: IOException -> String)
               , Handler $ return . Just . EncError
               , Handler $ return . Just
               ]

withLockedFile :: (MonadIO m, MonadMask m) => FilePath -> (Handle -> m a) -> m a
withLockedFile path f = withEx (lockedFile path) (f . snd)

lockedFile :: FilePath -> Acquire (FileLock, Handle)
lockedFile f = mkAcquire ((,) <$> lockFile f Exclusive <*> openFile f WriteMode) (\(lock, h) -> () <$ hClose h <* unlockFile lock)

type Render = ReaderT Handle IO ()

encode' :: ByteSink m => String -> m ()
encode' = encode CP437

width :: Int64
width = 32

esc :: Word8
esc = 27

escSequence :: [Word8] -> Render
escSequence = mapM_ pushWord8 . (esc:)

initialize :: Render
initialize = replicateM_ 2 $ escSequence [64]

newl :: Lazy.ByteString
newl = "\r\n"

newls :: Integer -> Lazy.ByteString
newls i = mconcat $ genericReplicate i newl

newls' :: Integer -> Render
newls' = mapM_ pushWord8 . LBS.unpack . newls

finalize :: Render -- TODO: adjust this to produce proper padding
finalize = newls' 2

intersperse :: b -> (a -> b) -> Seq a -> Seq b
intersperse _ _ (viewl -> EmptyL)                 = Seq.empty
intersperse _ f (viewl -> x :< (viewl -> EmptyL)) = Seq.singleton $ f x
intersperse b f (viewl -> x :< xs)                = f x <| b <| intersperse b f xs

intersperse' :: Monad m => m b -> (a -> m b) -> Seq a -> m ()
intersperse' b f = sequence_ . intersperse b f

render :: Printout -> Render
render = intersperse' (newls' 1) renderPar

renderPar :: Paragraph -> Render
renderPar = mapM_ renderChunk
  where
    renderChunk (Raw bs)       = mapM_ pushWord8 $ LBS.unpack bs
    renderChunk (Cooked block) = renderBlock block

renderBlock :: Block -> Render
renderBlock (VSpace n)   = newls' n
renderBlock (NewlSep xs) = intersperse' (newls' 1) renderBlock xs
renderBlock (Line x)     = undefined