{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE TypeFamilies #-}
module Language.TCT.Debug where

import Control.Monad (Monad(..), mapM)
import Data.Bool
import Data.Foldable (toList, null)
import Data.Function (($), (.))
import Data.Int (Int)
import Data.List.NonEmpty (NonEmpty(..))
import Data.Maybe (Maybe(..))
import Data.Ord (Ord)
import Data.Semigroup (Semigroup(..))
import Data.Sequence (Seq)
import Data.String (String)
import Data.Text (Text)
import Data.TreeSeq.Strict (Tree(..))
import Prelude ((+))
import Text.Show (Show(..))
import qualified Control.Monad.Trans.Reader as R
import qualified Data.List as List
import qualified Data.Text.Lazy as TL
import qualified Text.Megaparsec as P

-- * Debug
#if DEBUG
import qualified Debug.Trace as Trace

debug :: String -> a -> a
debug = Trace.trace

debug0 :: Pretty a => String -> a -> a
debug0 m a = Trace.trace (m <> ": " <> R.runReader (pretty a) 2) a

debug1 :: (Pretty r, Pretty a) => String -> String -> (a -> r) -> (a -> r)
debug1 nf na f a =
	(\r -> Trace.trace ("] " <> nf <> ": " <> R.runReader (pretty r) 2) r) $
	(Trace.trace ("[ " <> nf <> ":\n " <> na <> " = " <> R.runReader (pretty a) 2) f)
	a

debug1_ :: (Pretty r, Pretty a) => String -> (String,a) -> r -> r
debug1_ nf (na,a) r =
	Trace.trace ("[ " <> nf <> ":\n " <> na <> " = " <> R.runReader (pretty a) 2) $
	Trace.trace ("] " <> nf <> ": " <> R.runReader (pretty r) 2) $
	r

debug2 :: (Pretty r, Pretty a, Pretty b) => String -> String -> String -> (a -> b -> r) -> (a -> b -> r)
debug2 nf na nb f a b =
	(\r -> Trace.trace ("] " <> nf <> ": " <> R.runReader (pretty r) 2) r) $
	Trace.trace
	 ("[ " <> nf <> ":"
		 <> "\n " <> na <> " = " <> R.runReader (pretty a) 2
		 <> "\n " <> nb <> " = " <> R.runReader (pretty b) 2
	 ) f a b

debug2_ :: (Pretty r, Pretty a, Pretty b) => String -> (String,a) -> (String,b) -> r -> r
debug2_ nf (na,a) (nb,b) r =
	Trace.trace
	 ("[ " <> nf <> ":"
		 <> "\n " <> na <> " = " <> R.runReader (pretty a) 2
		 <> "\n " <> nb <> " = " <> R.runReader (pretty b) 2
	 ) $
	Trace.trace ("] " <> nf <> ": " <> R.runReader (pretty r) 2) $
	r

debug3 :: (Pretty r, Pretty a, Pretty b, Pretty c) => String -> String -> String -> String -> (a -> b -> c -> r) -> (a -> b -> c -> r)
debug3 nf na nb nc f a b c =
	(\r -> Trace.trace ("] " <> nf <> ": " <> R.runReader (pretty r) 2) r) $
	Trace.trace
	 ("[ " <> nf <> ":"
		 <> "\n " <> na <> " = " <> R.runReader (pretty a) 2
		 <> "\n " <> nb <> " = " <> R.runReader (pretty b) 2
		 <> "\n " <> nc <> " = " <> R.runReader (pretty c) 2
	 ) f a b c

debug3_ :: (Pretty r, Pretty a, Pretty b, Pretty c) => String -> (String,a) -> (String,b) -> (String,c) -> r -> r
debug3_ nf (na,a) (nb,b) (nc,c) r =
	Trace.trace
	 ("[ " <> nf <> ":"
		 <> "\n " <> na <> " = " <> R.runReader (pretty a) 2
		 <> "\n " <> nb <> " = " <> R.runReader (pretty b) 2
		 <> "\n " <> nc <> " = " <> R.runReader (pretty c) 2
	 ) $
	Trace.trace ("] " <> nf <> ": " <> R.runReader (pretty r) 2) $
	r

debugParser ::
 ( P.Stream s
 , P.ShowToken (P.Token s)
 , P.ShowErrorComponent e
 , Ord e
 , Show a
 ) =>
 String -> P.Parsec e s a -> P.Parsec e s a
debugParser = P.dbg
#else
import Data.Function (id)

debug :: String -> a -> a
debug _m = id
{-# INLINE debug #-}

debug0 :: Pretty a => String -> a -> a
debug0 _m = id
{-# INLINE debug0 #-}

debug1 :: (Pretty r, Pretty a) => String -> String -> (a -> r) -> (a -> r)
debug1 _nf _na = id
{-# INLINE debug1 #-}

debug1_ :: (Pretty r, Pretty a) => String -> (String,a) -> r -> r
debug1_ _nf _na = id
{-# INLINE debug1_ #-}

debug2 :: (Pretty r, Pretty a, Pretty b) => String -> String -> String -> (a -> b -> r) -> (a -> b -> r)
debug2 _nf _na _nb = id
{-# INLINE debug2 #-}

debug2_ :: (Pretty r, Pretty a, Pretty b) => String -> (String,a) -> (String,b) -> r -> r
debug2_ _nf _a _b = id
{-# INLINE debug2_ #-}

debug3 :: (Pretty r, Pretty a, Pretty b, Pretty c) => String -> String -> String -> String -> (a -> b -> c -> r) -> (a -> b -> c -> r)
debug3 _nf _na _nb _nc = id
{-# INLINE debug3 #-}

debug3_ :: (Pretty r, Pretty a, Pretty b, Pretty c) => String -> (String,a) -> (String,b) -> (String,c) -> r -> r
debug3_ _nf _a _b _c = id
{-# INLINE debug3_ #-}

debugParser ::
 ( P.Stream s
 , P.ShowToken (P.Token s)
 , P.ShowErrorComponent e
 , Ord e
 , Show a
 ) =>
 String -> P.Parsec e s a -> P.Parsec e s a
debugParser _m = id
{-# INLINE debugParser #-}
#endif

-- * Class 'Pretty'
class Pretty a where
	pretty :: a -> R.Reader Int String
	default pretty :: Show a => a -> R.Reader Int String
	pretty = return . show
instance Pretty Bool
instance Pretty Int
instance Pretty Text
instance Pretty TL.Text
instance (Pretty a, Pretty b) => Pretty (a,b) where
	pretty (a,b) = do
		i <- R.ask
		a' <- R.local (+2) $ pretty a
		b' <- R.local (+2) $ pretty b
		return $
			"\n" <> List.replicate i ' ' <> "( " <> a' <>
			"\n" <> List.replicate i ' ' <> ", " <> b' <>
			"\n" <> List.replicate i ' ' <> ") "
instance Pretty a => Pretty [a] where
	pretty [] = return "[]"
	pretty as = do
		i <- R.ask
		s <- R.local (+2) $ mapM pretty as
		return $
			"\n" <> List.replicate i ' ' <> "[ " <>
			List.intercalate ("\n" <> List.replicate i ' ' <> ", ") s <>
			"\n" <> List.replicate i ' ' <> "] "
instance Pretty a => Pretty (NonEmpty a) where
	pretty = pretty . toList
instance Pretty a => Pretty (Seq a) where
	pretty ss
	 | null ss = return "[]"
	 | otherwise = do
		let as = toList ss
		i <- R.ask
		s <- R.local (+2) $ mapM pretty as
		return $
			"\n" <> List.replicate i ' ' <> "[ " <>
			List.intercalate ("\n" <> List.replicate i ' ' <> ", ") s <>
			"\n" <> List.replicate i ' ' <> "] "
instance Pretty a => Pretty (Maybe a) where
	pretty Nothing = return "Nothing"
	pretty (Just m) = do
		s <- pretty m
		return $ "Just "<>s
instance Show a => Pretty (Tree a) where
	pretty (Tree n ts) = do
		s <- R.local (+2) (pretty ts)
		return $ "Tree "<>showsPrec 11 n ""<>" "<>s