{-# 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 Language.Symantic.XML as XML import qualified Text.Megaparsec as P trace :: String -> a -> a trace = Trace.trace -- * Debug #if DEBUG debug :: String -> a -> a debug = Trace.trace debug0 :: Pretty a => String -> a -> a debug0 m a = Trace.trace (m <> ": " <> runPretty 2 a) a debug1 :: (Pretty r, Pretty a) => String -> String -> (a -> r) -> (a -> r) debug1 nf na f a = (\r -> Trace.trace ("] " <> nf <> ": " <> runPretty 2 r) r) $ Trace.trace ("[ " <> nf <> ":\n " <> na <> " = " <> runPretty 2 a) f a debug1_ :: (Pretty r, Pretty a) => String -> (String,a) -> r -> r debug1_ nf (na,a) r = Trace.trace ("[ " <> nf <> ":\n " <> na <> " = " <> runPretty 2 a) $ Trace.trace ("] " <> nf <> ": " <> runPretty 2 r) $ 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 <> ": " <> runPretty 2 r) r) $ Trace.trace ("[ " <> nf <> ":" <> "\n " <> na <> " = " <> runPretty 2 a <> "\n " <> nb <> " = " <> runPretty 2 b ) 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 <> " = " <> runPretty 2 a <> "\n " <> nb <> " = " <> runPretty 2 b ) $ Trace.trace ("] " <> nf <> ": " <> runPretty 2 r) $ 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 <> ": " <> 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_ :: (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 <> " = " <> runPretty 2 a <> "\n " <> nb <> " = " <> runPretty 2 b <> "\n " <> nc <> " = " <> runPretty 2 c ) $ Trace.trace ("] " <> nf <> ": " <> runPretty 2 r) $ r #else 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_ #-} #endif #if DEBUG && DEBUG_PARSER debugParser :: ( P.Stream s , P.ShowToken (P.Token s) , P.ShowErrorComponent e , Ord e , Show a ) => String -> P.ParsecT e s m a -> P.ParsecT e s m a debugParser = P.dbg #else debugParser :: ( P.Stream s , P.ShowToken (P.Token s) , P.ShowErrorComponent e , Ord e , Show a ) => String -> P.ParsecT e s m a -> P.ParsecT e s m 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 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 Pretty XML.FilePos