Data.hs

{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE OverlappingInstances #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE NoMonomorphismRestriction #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  System.Log.Data
-- Copyright   :  (C) 2015 Flowbox
-- License     :  Apache-2.0
-- Maintainer  :  Wojciech Daniło <wojciech.danilo@gmail.com>
-- Stability   :  stable
-- Portability :  portable
-----------------------------------------------------------------------------

module System.Log.Data where

import Prelude                hiding (lookup, log)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Concurrent     (threadDelay)
import Control.Applicative    hiding (empty)
import System.Log.Log         (MonadLogger, LogFormat, Log(Log), fromLog, appendLog)
import Data.Time.Clock        (getCurrentTime, UTCTime)
import Control.Lens


----------------------------------------------------------------------
-- Logging utils
----------------------------------------------------------------------


log :: (Show pri, Enum pri, MonadRecord (Data Lvl, (Data Msg, r)) m)
    => RecordBuilder r -> pri -> String -> m ()
log rec pri msg = do
#ifdef NOLOGS
    return ()
#else
    appendRecord $ appData Lvl (mkLevel pri)
                 $ appData Msg msg
                 $ rec
#endif


----------------------------------------------------------------------
-- RecordBuilder
----------------------------------------------------------------------

newtype RecordBuilder a = RecordBuilder { fromRecordBuilder :: a } deriving (Show, Functor)
empty = RecordBuilder ()

class MonadRecord d m where
    appendRecord :: RecordBuilder d -> m ()

    default appendRecord :: (MonadLogger m, LogBuilder d m) => RecordBuilder d -> m ()
    appendRecord d = do
        l <- buildLog d
        appendLog l

appData :: (a~DataOf base) => base -> a -> RecordBuilder as -> RecordBuilder (Data base, as)
appData base a = fmap (Data base a,)


----------------------------------------------------------------------
-- Basic data wrappers
----------------------------------------------------------------------

data Data base = Data { recBase :: base
                      , recData :: DataOf base
                      }
deriving instance (Show (DataOf base), Show base) => Show (Data base)

class DataGetter base m where
    getData :: m (Data base)

type family DataOf a :: *


----------------------------------------------------------------------
-- LogBuilder
----------------------------------------------------------------------

class LogBuilderProto a m b where
    buildLogProto :: RecordBuilder a -> m (Log b)

type LogBuilder a m = LogBuilderProto a m (LogFormat m)

buildLog :: (Monad m, Applicative m, LogBuilder a m) => RecordBuilder a -> m (Log (LogFormat m))
buildLog = buildLogProto

-- === Instances ===

instance (LogBuilderProto xs m ys, Functor m) => LogBuilderProto (Data x,xs) m (Data x,ys) where
    buildLogProto b = (fmap.fmap) (x,) $ buildLogProto $ RecordBuilder xs where
        (x,xs) = fromRecordBuilder b

instance (LogBuilderProto (Data x,xs) m ys, LogBuilderProto xs m (Data y,()), Monad m) => LogBuilderProto (Data x,xs) m (Data y,ys) where
    buildLogProto b = do
        let (x,xs) = fromRecordBuilder b
        Log ys     <- buildLogProto b
        Log (y,()) <- buildLogProto $ RecordBuilder xs
        return $ Log (y, ys)
      
instance Monad m => LogBuilderProto a m () where
    buildLogProto _ = return $ Log ()

instance (Functor m, Applicative m, DataGetter y m, LogBuilderProto () m ys) => LogBuilderProto () m (Data y,ys) where
    buildLogProto b = fmap Log $ (,) <$> getData <*> (fromLog <$> buildLogProto b)


----------------------------------------------------------------------
-- Data reading
----------------------------------------------------------------------

class Lookup base s where 
    lookup :: base -> s -> Data base

readData :: Lookup a l => a -> l -> DataOf a
readData a = recData . lookup a

-- === Instances ===

instance LookupDataSet base l => Lookup base (Log l) where
    lookup b (fromLog -> s) = lookupDataSet b s

instance LookupDataSet base r => Lookup base (RecordBuilder r) where
    lookup b (fromRecordBuilder -> r) = lookupDataSet b r

---

class LookupDataSet base s where 
    lookupDataSet :: base -> s -> Data base

instance LookupDataSet base (Data base,as) where
    lookupDataSet _ (a,_) = a

instance LookupDataSet base as => LookupDataSet base (Data b,as) where
    lookupDataSet b (_, as) = lookupDataSet b as


----------------------------------------------------------------------
-- Simple data providers
----------------------------------------------------------------------

-- Time --

data Time = Time deriving (Show)
type instance DataOf Time = UTCTime

instance MonadIO m => DataGetter Time m where
    getData = do liftIO $ Data Time <$> getCurrentTime

-- Msg --

data Msg = Msg deriving (Show)
type instance DataOf Msg = String


-- Lvl -- 

data Lvl = Lvl deriving (Show)
type instance DataOf Lvl = LevelData
data LevelData = LevelData Int String deriving (Show, Ord, Eq)
mkLevel a = LevelData (fromEnum a) (show a)

-- Loc --

type Pos = (Int, Int)

data LocData = LocData { _filename :: String
                       , _package  :: String
                       , _module   :: String
                       , _start    :: Pos
                       , _end      :: Pos
                       } deriving Show

mkLoc (f,p,m,s,e) = LocData f p m s e

data Loc = Loc deriving (Show)
type instance DataOf Loc = LocData

makeLenses ''Loc