module AERN2.QA.NetLog
(ValueId(..), QANetLogItem(..), QANetLog
, formatQALog, printQALog, printQANetLogThenResult
, formatQALogJSON, printQALogJSON, writeNetLogJSON)
where
import MixedTypesNumPrelude
import qualified Prelude as P
import Text.Printf
import GHC.Generics
import qualified Data.ByteString.Lazy.Char8 as BS
import Data.Aeson as J
import Data.Aeson.Types as JT
type QANetLog = [QANetLogItem]
data QANetLogItem
= QANetLogCreate
{
qaLogCreate_newId :: ValueId
, qaLogCreate_sources :: [ValueId]
, qaLogCreate_name :: String
}
| QANetLogQuery
{
qaLogQuery_client :: (Maybe ValueId)
, qaLogQuery_provider :: ValueId
, qaLogQuery_description :: String
}
| QANetLogAnswer
{
qaLogAnswer_client :: (Maybe ValueId)
, qaLogAnswer_provider :: ValueId
, qaLogAnswer_cacheUseDescription :: String
, qaLogAnswer_description :: String
}
deriving (Generic)
instance ToJSON QANetLogItem where
toJSON = J.genericToJSON customOptions
where
customOptions = J.defaultOptions
{ JT.sumEncoding = JT.ObjectWithSingleField }
instance Show QANetLogItem where
show (QANetLogCreate valId sources name) =
printf "new (%s) %s <- %s"
(show valId) name (show sources)
show (QANetLogQuery mSrcId valId queryS) =
printf "(%s)<-(%s): ? %s"
(show valId) (showSrc mSrcId) queryS
show (QANetLogAnswer mSrcId valId cacheInfoS answerS) =
printf "(%s)->(%s): ! %s (%s)"
(show valId) (showSrc mSrcId) answerS cacheInfoS
showSrc :: (Show a) => Maybe a -> String
showSrc (Just srcId) = show srcId
showSrc Nothing = ""
data ValueId = ValueId Integer
deriving (Show, P.Eq, P.Ord, Generic, ToJSON)
instance Enum ValueId where
toEnum = ValueId . toEnum
fromEnum (ValueId n) = fromEnum n
printQANetLogThenResult :: (Show a) =>(QANetLog, a) -> IO ()
printQANetLogThenResult (lg, result) =
do
printQALog lg
putStrLn $ show result
printQALog :: QANetLog -> IO ()
printQALog = putStrLn . formatQALog 0
formatQALog :: Integer -> QANetLog -> String
formatQALog = aux
where
aux _ [] = ""
aux level (item : rest) =
(indent ++ show item ++ "\n") ++
(aux level' rest)
where
indent = replicate levelNow ' '
(levelNow, level') =
case item of
QANetLogQuery _ _ _ -> (level + 1, level + 1)
QANetLogAnswer _ _ _ _ -> (level, level 1)
_ -> (level, level)
formatQALogJSON :: QANetLog -> String
formatQALogJSON = BS.unpack . J.encode
printQALogJSON :: QANetLog -> IO ()
printQALogJSON =
BS.putStrLn . J.encode
writeNetLogJSON :: QANetLog -> IO ()
writeNetLogJSON netlog =
writeFile "netlog.js" $
"netlog='" ++ (filter goodChar $ formatQALogJSON netlog) ++ "'"
where
goodChar 'Â' = False
goodChar _ = True