{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
module Igor2.Logging.Logger
(
    tp,ts,

    runLM, -- unLM, -- noLog,
    LM, ELT, mkLogState,
    waypointS, waypointM, waypointL,
    logDE,logIN,logNO,logWA,logER,
    LogState(),

    module Control.Monad ,
    module Control.Monad.State,
    module Control.Monad.Trans,
    module Igor2.Logging.Log,     -- logging
--    module Logging.MockLog, -- no logging
    module Debug.Trace
    ) 
    where

import Prelude hiding ((<$>))

import Data.Monoid (Monoid(..))
import Data.List (isPrefixOf, intersperse, foldl')
import Data.Maybe (isJust)
import Data.Function (on)
import Control.Applicative (Applicative, pure, (<*>))
import Control.Monad (liftM, liftM2, liftM3,when)
import Control.Monad.State(MonadState(put, get, state), StateT, evalStateT, gets, modify)
import Control.Monad.Trans (MonadTrans (..))
import Control.Monad.Error
import Control.Monad.Reader (MonadReader(ask, local, reader))
import qualified System.IO as SIO

import Syntax.Context
import Debug.Trace
import Igor2.Ppr
import Igor2.Logging.Log      -- logging
--import Logging.MockLog  -- no logging


tp :: (Show a, Pretty a) => String -> a -> a
tp s = \x -> (trace $ s ++ (show.pretty $ x)) x

ts :: (Show a, Pretty a) => String -> a -> a
ts s = \x -> (trace $ s ++ show x) x

data LogState = LS {verbosity :: Priority  -- ^Priority
                   ,verbose  :: Bool     -- ^be verbose
                   ,dumpLog  :: Maybe SIO.Handle} -- ^dump to log file

class Monad m => MonadLog m where
  handle :: LogEntry -> m ()

mkLogState vl v d = LS vl v d

logDE,logIN,logNO,logWA,logER :: MonadLog m => Doc -> m ()
logDE = logging DEBUG
logIN = logging INFO
logNO = logging NOTICE
logWA = logging WARNING
logER = logging ERROR

instance MonadLog m => MonadLog (StateT a m) where
  handle = lift . handle

waypointS, waypointM, waypointL :: MonadLog m => Doc -> m ()
waypointS s = logNO $ linebreak <> text "- -" <$>
              text "- -" <+> s <$>
              text "- -" <> linebreak
waypointM s = logNO $ linebreak <>
              text "- - - - - - - - - - - - - - - - - - - - - - - -" <$>
              text "- -" <+> s <+> fill 39 (text "- -") <$>
              text "- - - - - - - - - - - - - - - - - - - - - - - -" <>
              linebreak
waypointL s = logNO $ linebreak <>
              text "***********************************************" <$>
              text "***" <+> s <+> fill 39 (text "***") <$>
              text "***********************************************"  <>
              linebreak

logEnterDE, logEnterIN :: MonadLog m => m ()
logEnterDE = logDE $ text "\n - - - - - - Function entered - - - - - - "
logEnterIN = logIN $ text "\n - - - - - - Function entered - - - - - - "

logEntered :: MonadLog m => Priority -> m ()
logEntered = flip logging $ text "\n - - - - - - Function entered - - - - - - "

getPriority ::  (MonadState LogState m) => m Priority
getPriority = gets verbosity

setPriority ::  (MonadState LogState m) =>Priority -> m ()
setPriority p = modify (\l -> l{verbosity = p})

isVerbose :: (MonadState LogState m) =>m Bool
isVerbose = gets verbose

setVerbose ::  (MonadState LogState m) =>Bool -> m ()
setVerbose d = modify (\l -> l{verbose = d})

isDumping :: (MonadState LogState m) => m Bool
isDumping = liftM isJust $ gets dumpLog

setDumping ::  (MonadState LogState m) => Maybe (SIO.Handle) -> m ()
setDumping d = modify (\l -> l{dumpLog = d})


logging :: MonadLog m => Priority -> Doc -> m ()
logging = (handle .) . LE

instance MonadIO m => MonadLog (ELT m) where
  handle le@(LE p msg) = ELT $
      liftM2 (||) isDumping isVerbose >>=
      flip when (
          liftM (p <=) getPriority >>=
          flip when (
              isVerbose >>= flip when (liftIO . print $ msg) >>
              gets dumpLog >>= maybe (return ()) (\h -> liftIO $ displayIO h (renderPretty 0.5 140 msg))))

{-

Another method, which is guaranteed to work, is to implement a minuscule
custom logging monad like this:

   module Logger where

   type Logger m a = WriterT Log m a

   runLogger = runWriterT
   logging   = tell

and replace it with

   module MockLogger where

   type Logger m a = m a

   runLogger = fmap  $ \a -> (a,emptyLog)
   logging   = const $ return ()

when you don't want to log anything.
-}


newtype ELT m a = ELT { unELT :: (StateT LogState (ErrorT String m) a) }

instance (Functor m, Monad m) => Applicative (ELT m) where
    pure = ELT . pure
    ELT f <*> ELT m = ELT (f <*> m)

instance Monad m => Monad (ELT m) where
    return = ELT . return
    (ELT m) >>= f = ELT (m >>= unELT . f)

instance MonadTrans ELT where
    lift = ELT . lift . lift

instance MonadIO m => MonadIO (ELT m) where
    liftIO = ELT . liftIO

instance Functor m => Functor (ELT m) where
    fmap f = ELT . fmap f . unELT

instance Monad m => MonadError String (ELT m) where
    throwError = ELT . throwError
    catchError x f = ELT $ catchError (unELT x) (unELT . f)

instance MonadReader Context (ELT (C IO)) where
    ask = ELT ask
    local f = ELT . local f . unELT
    reader f = ELT (reader f)

runELT :: (Monad m) => ELT m a -> LogState -> m (Either String a)
runELT m s = runErrorT (evalStateT (unELT m) s)

type LM = ELT (C IO) -- (ReaderT IO)
runLM :: ELT (C IO) a -> LogState -> C IO (Either String a)
runLM = runELT


-- DEAD CODE     
---- | Strips away the monadic ErrorLogging context. This is unsafe, because if
----   an error occurred in the Monad it is propagated.       
---- TODO: Should rather be something with `catchError`                
--unLM :: LM a -> IO a 
--unLM m = do 
--    r <- runLM ERROR False m
--    case fst r of 
--        Left s  -> fail s
--        Right a -> return a
--   
-- DEAD CODE     
--noLog :: (Monad m)=> LM a -> m a
--noLog m =  
--    case fst (runLM m) of 
--        Left s  -> fail s
--        Right a -> return a        

-- TODO:
-- This is a LoggingMonad transformer which uses the Q monad instead of the 
-- Identity Monad as inner monad. This is needed, when reification should be 
-- used, as well as interpretation of Exp or unique identifier (?? is this 
-- really a topic??). I don't know if this entails a lot of rewriting. At the 
-- moment I see only those functions which use unLM to be included in LM.
--type LM = ELT Q
--runLM :: -- (Language.Haskell.TH.Syntax.Quasi m) =>
--               ELT Q a -> Q (Either String a, Log)
--runLM = runELT
                    
--unLM :: LM a -> Q a 
--unLM m = do 
--    unlm <- liftM fst (runLM m) 
--    case unlm  of 
--        Left s  -> error s
--        Right a -> return a
