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

import Control.Monad (Monad(..), mapM)
import Data.Bool
import Data.Eq (Eq(..))
import Data.Foldable (toList, null)
import Data.Function (($), (.), id)
import Data.Int (Int)
import Data.Ratio (Ratio)
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 Prelude ((+), Integer)
import Text.Show (Show(..))
import qualified Control.Monad.Trans.Reader as R
import qualified Data.HashMap.Strict as HM
import qualified Data.List as List
import qualified Data.Map.Strict as Map
import qualified Data.Text.Lazy as TL
import qualified Data.Tree as Tree
import qualified Data.TreeSeq.Strict as TS
import qualified Debug.Trace as Trace
import qualified Symantic.XML as XML
import qualified Text.Megaparsec as P
import qualified Text.Megaparsec.Debug as P

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

debug   :: String -> a -> a
debug0  :: Pretty a => String -> a -> a
debug1  :: (Pretty r, Pretty a) => String -> String -> (a -> r) -> (a -> r)
debug1_ :: (Pretty r, Pretty a) => String -> (String,a) -> r -> r
debug2  :: (Pretty r, Pretty a, Pretty b) => String -> String -> String -> (a -> b -> r) -> (a -> b -> r)
debug2_ :: (Pretty r, Pretty a, Pretty b) => String -> (String,a) -> (String,b) -> r -> r
debug3  :: (Pretty r, Pretty a, Pretty b, Pretty c) => String -> String -> String -> String -> (a -> b -> c -> r) -> (a -> b -> c -> r)
debug3_ :: (Pretty r, Pretty a, Pretty b, Pretty c) => String -> (String,a) -> (String,b) -> (String,c) -> r -> r
debugParser ::
 ( P.Stream s
 , P.ShowErrorComponent e
 , Ord e
 , Show a
 ) =>
 String -> P.ParsecT e s m a -> P.ParsecT e s m a

-- * Debug
#if DEBUG

debug = Trace.trace
debug0 m a = Trace.trace (m <> ": " <> runPretty 2 a) a
debug1 nf na f a =
	(\r -> Trace.trace ("] " <> nf <> ": " <> runPretty 2 r) r) $
	Trace.trace ("[ " <> nf <> ":\n " <> na <> " = " <> runPretty 2 a) f
	a
debug1_ nf (na,a) r =
	Trace.trace ("[ " <> nf <> ":\n " <> na <> " = " <> runPretty 2 a) $
	Trace.trace ("] " <> nf <> ": " <> runPretty 2 r) $
	r
debug2 nf na nb f a b =
	(\r -> Trace.trace ("] " <> nf <> ": " <> runPretty 2 r) r) $
	Trace.trace
	 ("[ " <> nf <> ":"
		 <> "\n " <> na <> " = " <> runPretty 2 a
		 <> "\n " <> nb <> " = " <> runPretty 2 b
	 ) f a b
debug2_ nf (na,a) (nb,b) r =
	Trace.trace
	 ("[ " <> nf <> ":"
		 <> "\n " <> na <> " = " <> runPretty 2 a
		 <> "\n " <> nb <> " = " <> runPretty 2 b
	 ) $
	Trace.trace ("] " <> nf <> ": " <> runPretty 2 r) $
	r
debug3 nf na nb nc f a b c =
	(\r -> Trace.trace ("] " <> nf <> ": " <> runPretty 2 r) r) $
	Trace.trace
	 ("[ " <> nf <> ":"
		 <> "\n " <> na <> " = " <> runPretty 2 a
		 <> "\n " <> nb <> " = " <> runPretty 2 b
		 <> "\n " <> nc <> " = " <> runPretty 2 c
	 ) f a b c
debug3_ nf (na,a) (nb,b) (nc,c) r =
	Trace.trace
	 ("[ " <> nf <> ":"
		 <> "\n " <> na <> " = " <> runPretty 2 a
		 <> "\n " <> nb <> " = " <> runPretty 2 b
		 <> "\n " <> nc <> " = " <> runPretty 2 c
	 ) $
	Trace.trace ("] " <> nf <> ": " <> runPretty 2 r) $
	r

#else

debug _m = id
{-# INLINE debug #-}
debug0 _m = id
{-# INLINE debug0 #-}
debug1 _nf _na = id
{-# INLINE debug1 #-}
debug1_ _nf _na = id
{-# INLINE debug1_ #-}
debug2 _nf _na _nb = id
{-# INLINE debug2 #-}
debug2_ _nf _a _b = id
{-# INLINE debug2_ #-}
debug3 _nf _na _nb _nc = id
{-# INLINE debug3 #-}
debug3_ _nf _a _b _c = id
{-# INLINE debug3_ #-}

#endif

#if DEBUG && DEBUG_PARSER
debugParser = P.dbg
#else
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

runPretty :: Pretty a => Int -> a -> String
runPretty i a = pretty a `R.runReader` i

instance Pretty Bool
instance Pretty Int
instance Pretty Integer
instance (Pretty a, Show a) => Pretty (Ratio a)
instance Pretty Text
instance Pretty TL.Text
instance Pretty P.Pos
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 $
			(if i == 0 then "" else "\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 $
			(if i == 0 then "" else "\n") <>
			List.replicate i ' ' <> "[ " <>
			List.intercalate ("\n" <> List.replicate i ' ' <> ", ") s <>
			"\n" <> List.replicate i ' ' <> "] "
instance (Pretty k, Pretty a) => Pretty (Map.Map k a) where
	pretty = pretty . Map.toList
instance (Pretty k, Pretty a) => Pretty (HM.HashMap k a) where
	pretty = pretty . HM.toList
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 $
			(if i == 0 then "" else "\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.Tree a) where
	pretty (Tree.Node n ts) = do
		s <- R.local (+2) (pretty ts)
		return $ "Tree "<>showsPrec 11 n ""<>" "<>s
instance Show a => Pretty (TS.Tree a) where
	pretty (TS.Tree n ts) = do
		s <- R.local (+2) (pretty ts)
		return $ "Tree "<>showsPrec 11 n ""<>" "<>s
instance (Show src, Show a) => Pretty (XML.Sourced src a) where