{-# LANGUAGE BlockArguments, LambdaCase, OverloadedStrings #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}

module Data.Log (
	-- * LOG
	-- ** DATA LOG
	Log, logVar, (.+.), intersperse, unwords,
	-- ** CLASS
	Loggable(..), Message(..),
	-- * SDOC
	IsSDoc(..), SDocStr ) where

import Prelude hiding (unwords, log)

import Outputable (Outputable, SDoc, empty, ppr, text, ($$))
import Data.String (IsString(..))

import qualified Outputable as O ((<>))

---------------------------------------------------------------------------

-- * LOG
--	+ NEWTYPE LOG
--	+ INSTANCE
--	+ FUNCTION
--	+ CLASS
-- * SDOC

---------------------------------------------------------------------------
-- LOG
---------------------------------------------------------------------------

-- NEWTYPE LOG

newtype Log s v = Log ([[Either s v]] -> [[Either s v]])

-- INSTANCE

instance Semigroup (Log s v) where Log [[Either s v]] -> [[Either s v]]
l <> :: Log s v -> Log s v -> Log s v
<> Log [[Either s v]] -> [[Either s v]]
r = ([[Either s v]] -> [[Either s v]]) -> Log s v
forall s v. ([[Either s v]] -> [[Either s v]]) -> Log s v
Log (([[Either s v]] -> [[Either s v]]) -> Log s v)
-> ([[Either s v]] -> [[Either s v]]) -> Log s v
forall a b. (a -> b) -> a -> b
$ [[Either s v]] -> [[Either s v]]
l ([[Either s v]] -> [[Either s v]])
-> ([[Either s v]] -> [[Either s v]])
-> [[Either s v]]
-> [[Either s v]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Either s v]] -> [[Either s v]]
r
instance Monoid (Log s v) where mempty :: Log s v
mempty = ([[Either s v]] -> [[Either s v]]) -> Log s v
forall s v. ([[Either s v]] -> [[Either s v]]) -> Log s v
Log [[Either s v]] -> [[Either s v]]
forall a. a -> a
id

instance (Show s, Show v) => Show (Log s v) where
	show :: Log s v -> String
show (Log [[Either s v]] -> [[Either s v]]
k) = String
"(Log (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [[Either s v]] -> String
forall a. Show a => a -> String
show ([[Either s v]] -> [[Either s v]]
k []) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" ++))"

instance (Outputable s, Outputable v) => Outputable (Log s v) where
	ppr :: Log s v -> SDoc
ppr (Log [[Either s v]] -> [[Either s v]]
k) = (SDoc -> SDoc -> SDoc) -> SDoc -> [SDoc] -> SDoc
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr SDoc -> SDoc -> SDoc
($$) SDoc
empty ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ [Either s v] -> SDoc
forall s v. (Outputable s, Outputable v) => [Either s v] -> SDoc
pprLog1 ([Either s v] -> SDoc) -> [[Either s v]] -> [SDoc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Either s v]] -> [[Either s v]]
k []

pprLog1 :: (Outputable s, Outputable v) => [Either s v] -> SDoc
pprLog1 :: [Either s v] -> SDoc
pprLog1 = (SDoc -> SDoc -> SDoc) -> SDoc -> [SDoc] -> SDoc
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr SDoc -> SDoc -> SDoc
(O.<>) SDoc
empty ([SDoc] -> SDoc)
-> ([Either s v] -> [SDoc]) -> [Either s v] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((s -> SDoc) -> (v -> SDoc) -> Either s v -> SDoc
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either s -> SDoc
forall a. Outputable a => a -> SDoc
ppr v -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Either s v -> SDoc) -> [Either s v] -> [SDoc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)

instance (Message s, Show v) => Message (Log s v) where
	message :: Log s v -> String
message (Log [[Either s v]] -> [[Either s v]]
k) = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [Either s v] -> String
forall s v. (Message s, Show v) => [Either s v] -> String
messageLog1 ([Either s v] -> String) -> [[Either s v]] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Either s v]] -> [[Either s v]]
k []

messageLog1 :: (Message s, Show v) => [Either s v] -> String
messageLog1 :: [Either s v] -> String
messageLog1 = (Either s v -> String) -> [Either s v] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Either s v -> String) -> [Either s v] -> String)
-> (Either s v -> String) -> [Either s v] -> String
forall a b. (a -> b) -> a -> b
$ (s -> String) -> (v -> String) -> Either s v -> String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either s -> String
forall s. Message s => s -> String
message v -> String
forall a. Show a => a -> String
show

instance IsString s => IsString (Log s v) where
	fromString :: String -> Log s v
fromString = ([[Either s v]] -> [[Either s v]]) -> Log s v
forall s v. ([[Either s v]] -> [[Either s v]]) -> Log s v
Log (([[Either s v]] -> [[Either s v]]) -> Log s v)
-> (String -> [[Either s v]] -> [[Either s v]])
-> String
-> Log s v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Either s v]] -> [[Either s v]] -> [[Either s v]]
forall a. [a] -> [a] -> [a]
(++) ([[Either s v]] -> [[Either s v]] -> [[Either s v]])
-> (String -> [[Either s v]])
-> String
-> [[Either s v]]
-> [[Either s v]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Either s v -> [Either s v] -> [Either s v]
forall a. a -> [a] -> [a]
: []) (Either s v -> [Either s v])
-> (String -> Either s v) -> String -> [Either s v]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> Either s v
forall a b. a -> Either a b
Left (s -> Either s v) -> (String -> s) -> String -> Either s v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> s
forall a. IsString a => String -> a
fromString (String -> [Either s v]) -> [String] -> [[Either s v]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) ([String] -> [[Either s v]])
-> (String -> [String]) -> String -> [[Either s v]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines

instance IsSDoc s => IsSDoc (Log s v) where
	fromSDoc :: SDoc -> Log s v
fromSDoc = ([[Either s v]] -> [[Either s v]]) -> Log s v
forall s v. ([[Either s v]] -> [[Either s v]]) -> Log s v
Log (([[Either s v]] -> [[Either s v]]) -> Log s v)
-> (SDoc -> [[Either s v]] -> [[Either s v]]) -> SDoc -> Log s v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:) ([Either s v] -> [[Either s v]] -> [[Either s v]])
-> (SDoc -> [Either s v])
-> SDoc
-> [[Either s v]]
-> [[Either s v]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either s v -> [Either s v] -> [Either s v]
forall a. a -> [a] -> [a]
: []) (Either s v -> [Either s v])
-> (SDoc -> Either s v) -> SDoc -> [Either s v]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> Either s v
forall a b. a -> Either a b
Left (s -> Either s v) -> (SDoc -> s) -> SDoc -> Either s v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> s
forall s. IsSDoc s => SDoc -> s
fromSDoc

-- FUNCTION

logVar :: v -> Log s v
logVar :: v -> Log s v
logVar v
v = ([[Either s v]] -> [[Either s v]]) -> Log s v
forall s v. ([[Either s v]] -> [[Either s v]]) -> Log s v
Log ([v -> Either s v
forall a b. b -> Either a b
Right v
v] [Either s v] -> [[Either s v]] -> [[Either s v]]
forall a. a -> [a] -> [a]
:)

infixr 7 .+.

(.+.) :: Log s v -> Log s v -> Log s v
Log [[Either s v]] -> [[Either s v]]
l .+. :: Log s v -> Log s v -> Log s v
.+. Log [[Either s v]] -> [[Either s v]]
r = ([[Either s v]] -> [[Either s v]]) -> Log s v
forall s v. ([[Either s v]] -> [[Either s v]]) -> Log s v
Log (([[Either s v]] -> [[Either s v]]) -> Log s v)
-> ([[Either s v]] -> [[Either s v]]) -> Log s v
forall a b. (a -> b) -> a -> b
$ ([[Either s v]] -> [[Either s v]]
l [] [[Either s v]] -> [[Either s v]] -> [[Either s v]]
forall a. [[a]] -> [[a]] -> [[a]]
%) ([[Either s v]] -> [[Either s v]])
-> ([[Either s v]] -> [[Either s v]])
-> [[Either s v]]
-> [[Either s v]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Either s v]] -> [[Either s v]]
r where
	[] % :: [[a]] -> [[a]] -> [[a]]
% [[a]]
yss = [[a]]
yss
	[[a]
xs] % ([a]
ys : [[a]]
yss) = ([a]
xs [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
ys) [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [[a]]
yss
	([a]
xs : [[a]]
xss) % [[a]]
yss = [a]
xs [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: ([[a]]
xss [[a]] -> [[a]] -> [[a]]
% [[a]]
yss)

intersperse :: Log s v -> [Log s v] -> Log s v
intersperse :: Log s v -> [Log s v] -> Log s v
intersperse Log s v
s = \case [] -> Log s v
forall a. Monoid a => a
mempty; [Log s v]
ls -> (Log s v -> Log s v -> Log s v) -> [Log s v] -> Log s v
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\Log s v
l -> (Log s v
l Log s v -> Log s v -> Log s v
forall s v. Log s v -> Log s v -> Log s v
.+.) (Log s v -> Log s v) -> (Log s v -> Log s v) -> Log s v -> Log s v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Log s v
s Log s v -> Log s v -> Log s v
forall s v. Log s v -> Log s v -> Log s v
.+.)) [Log s v]
ls

unwords :: IsString s => [Log s v] -> Log s v
unwords :: [Log s v] -> Log s v
unwords = Log s v -> [Log s v] -> Log s v
forall s v. Log s v -> [Log s v] -> Log s v
intersperse Log s v
" "

-- CLASS

class Loggable s v a where log :: a -> Log s v

class Message s where
	message :: s -> String
	messageList :: [s] -> String
	messageList = [String] -> String
unlines ([String] -> String) -> ([s] -> [String]) -> [s] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (s -> String
forall s. Message s => s -> String
message (s -> String) -> [s] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)

instance Message s => Message [s] where message :: [s] -> String
message = [s] -> String
forall s. Message s => [s] -> String
messageList
instance Message Char where message :: Char -> String
message = (Char -> ShowS
forall a. a -> [a] -> [a]
: []); messageList :: ShowS
messageList = ShowS
forall a. a -> a
id

---------------------------------------------------------------------------
-- SDOC STRING
---------------------------------------------------------------------------

class IsSDoc s where fromSDoc :: SDoc -> s

data SDocStr = SDocStrEmpty | SDocStr SDoc

instance Semigroup SDocStr where
	SDocStr
SDocStrEmpty <> :: SDocStr -> SDocStr -> SDocStr
<> SDocStr
r = SDocStr
r; SDocStr
l <> SDocStr
SDocStrEmpty = SDocStr
l
	SDocStr SDoc
l <> SDocStr SDoc
r = SDoc -> SDocStr
SDocStr (SDoc -> SDocStr) -> SDoc -> SDocStr
forall a b. (a -> b) -> a -> b
$ SDoc
l SDoc -> SDoc -> SDoc
$$ SDoc
r

instance Monoid SDocStr where mempty :: SDocStr
mempty = SDocStr
SDocStrEmpty
instance Outputable SDocStr where ppr :: SDocStr -> SDoc
ppr SDocStr
SDocStrEmpty = SDoc
empty; ppr (SDocStr SDoc
s) = SDoc
s
instance IsString SDocStr where fromString :: String -> SDocStr
fromString = SDoc -> SDocStr
SDocStr (SDoc -> SDocStr) -> (String -> SDoc) -> String -> SDocStr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> SDoc
text
instance IsSDoc SDocStr where fromSDoc :: SDoc -> SDocStr
fromSDoc = SDoc -> SDocStr
SDocStr