src/Textphile/TCT/Debug.hs

   1 {-# LANGUAGE CPP #-}
   2 {-# LANGUAGE ConstraintKinds #-}
   3 {-# LANGUAGE DefaultSignatures #-}
   4 {-# LANGUAGE FlexibleContexts #-}
   5 {-# LANGUAGE OverloadedStrings #-}
   6 {-# LANGUAGE Rank2Types #-}
   7 {-# LANGUAGE TypeFamilies #-}
   8 module Textphile.TCT.Debug where
   9
  10 import Control.Monad (Monad(..), mapM)
  11 import Data.Bool
  12 import Data.Eq (Eq(..))
  13 import Data.Foldable (toList, null)
  14 import Data.Function (($), (.), id)
  15 import Data.Int (Int)
  16 import Data.Ratio (Ratio)
  17 import Data.List.NonEmpty (NonEmpty(..))
  18 import Data.Maybe (Maybe(..))
  19 import Data.Ord (Ord)
  20 import Data.Semigroup (Semigroup(..))
  21 import Data.Sequence (Seq)
  22 import Data.String (String)
  23 import Data.Text (Text)
  24 import Prelude ((+), Integer)
  25 import Text.Show (Show(..))
  26 import qualified Control.Monad.Trans.Reader as R
  27 import qualified Data.HashMap.Strict as HM
  28 import qualified Data.List as List
  29 import qualified Data.Map.Strict as Map
  30 import qualified Data.Text.Lazy as TL
  31 import qualified Data.Tree as Tree
  32 import qualified Data.TreeSeq.Strict as TS
  33 import qualified Debug.Trace as Trace
  34 import qualified Symantic.XML as XML
  35 import qualified Text.Megaparsec as P
  36 #if DEBUG && DEBUG_PARSER
  37 import qualified Text.Megaparsec.Debug as P
  38 #endif
  39
  40 trace :: String -> a -> a
  41 trace = Trace.trace
  42
  43 debug   :: String -> a -> a
  44 debug0  :: Pretty a => String -> a -> a
  45 debug1  :: (Pretty r, Pretty a) => String -> String -> (a -> r) -> (a -> r)
  46 debug1_ :: (Pretty r, Pretty a) => String -> (String,a) -> r -> r
  47 debug2  :: (Pretty r, Pretty a, Pretty b) => String -> String -> String -> (a -> b -> r) -> (a -> b -> r)
  48 debug2_ :: (Pretty r, Pretty a, Pretty b) => String -> (String,a) -> (String,b) -> r -> r
  49 debug3  :: (Pretty r, Pretty a, Pretty b, Pretty c) => String -> String -> String -> String -> (a -> b -> c -> r) -> (a -> b -> c -> r)
  50 debug3_ :: (Pretty r, Pretty a, Pretty b, Pretty c) => String -> (String,a) -> (String,b) -> (String,c) -> r -> r
  51 debugParser ::
  52  ( P.Stream s
  53  , P.ShowErrorComponent e
  54  , Ord e
  55  , Show a
  56  ) =>
  57  String -> P.ParsecT e s m a -> P.ParsecT e s m a
  58
  59 -- * Debug
  60 #if DEBUG
  61
  62 debug = Trace.trace
  63 debug0 m a = Trace.trace (m <> ": " <> runPretty 2 a) a
  64 debug1 nf na f a =
  65         (\r -> Trace.trace ("] " <> nf <> ": " <> runPretty 2 r) r) $
  66         Trace.trace ("[ " <> nf <> ":\n " <> na <> " = " <> runPretty 2 a) f
  67         a
  68 debug1_ nf (na,a) r =
  69         Trace.trace ("[ " <> nf <> ":\n " <> na <> " = " <> runPretty 2 a) $
  70         Trace.trace ("] " <> nf <> ": " <> runPretty 2 r) $
  71         r
  72 debug2 nf na nb f a b =
  73         (\r -> Trace.trace ("] " <> nf <> ": " <> runPretty 2 r) r) $
  74         Trace.trace
  75          ("[ " <> nf <> ":"
  76                  <> "\n " <> na <> " = " <> runPretty 2 a
  77                  <> "\n " <> nb <> " = " <> runPretty 2 b
  78          ) f a b
  79 debug2_ nf (na,a) (nb,b) r =
  80         Trace.trace
  81          ("[ " <> nf <> ":"
  82                  <> "\n " <> na <> " = " <> runPretty 2 a
  83                  <> "\n " <> nb <> " = " <> runPretty 2 b
  84          ) $
  85         Trace.trace ("] " <> nf <> ": " <> runPretty 2 r) $
  86         r
  87 debug3 nf na nb nc f a b c =
  88         (\r -> Trace.trace ("] " <> nf <> ": " <> runPretty 2 r) r) $
  89         Trace.trace
  90          ("[ " <> nf <> ":"
  91                  <> "\n " <> na <> " = " <> runPretty 2 a
  92                  <> "\n " <> nb <> " = " <> runPretty 2 b
  93                  <> "\n " <> nc <> " = " <> runPretty 2 c
  94          ) f a b c
  95 debug3_ nf (na,a) (nb,b) (nc,c) r =
  96         Trace.trace
  97          ("[ " <> nf <> ":"
  98                  <> "\n " <> na <> " = " <> runPretty 2 a
  99                  <> "\n " <> nb <> " = " <> runPretty 2 b
 100                  <> "\n " <> nc <> " = " <> runPretty 2 c
 101          ) $
 102         Trace.trace ("] " <> nf <> ": " <> runPretty 2 r) $
 103         r
 104
 105 #else
 106
 107 debug _m = id
 108 {-# INLINE debug #-}
 109 debug0 _m = id
 110 {-# INLINE debug0 #-}
 111 debug1 _nf _na = id
 112 {-# INLINE debug1 #-}
 113 debug1_ _nf _na = id
 114 {-# INLINE debug1_ #-}
 115 debug2 _nf _na _nb = id
 116 {-# INLINE debug2 #-}
 117 debug2_ _nf _a _b = id
 118 {-# INLINE debug2_ #-}
 119 debug3 _nf _na _nb _nc = id
 120 {-# INLINE debug3 #-}
 121 debug3_ _nf _a _b _c = id
 122 {-# INLINE debug3_ #-}
 123
 124 #endif
 125
 126 #if DEBUG && DEBUG_PARSER
 127 debugParser = P.dbg
 128 #else
 129 debugParser _m = id
 130 {-# INLINE debugParser #-}
 131 #endif
 132
 133 -- * Class 'Pretty'
 134 class Pretty a where
 135         pretty :: a -> R.Reader Int String
 136         default pretty :: Show a => a -> R.Reader Int String
 137         pretty = return . show
 138
 139 runPretty :: Pretty a => Int -> a -> String
 140 runPretty i a = pretty a `R.runReader` i
 141
 142 instance Pretty Bool
 143 instance Pretty Int
 144 instance Pretty Integer
 145 instance (Pretty a, Show a) => Pretty (Ratio a)
 146 instance Pretty Text
 147 instance Pretty TL.Text
 148 instance Pretty P.Pos
 149 instance (Pretty a, Pretty b) => Pretty (a,b) where
 150         pretty (a,b) = do
 151                 i <- R.ask
 152                 a' <- R.local (+2) $ pretty a
 153                 b' <- R.local (+2) $ pretty b
 154                 return $
 155                         (if i == 0 then "" else "\n") <>
 156                         List.replicate i ' ' <> "( " <> a' <>
 157                         "\n" <> List.replicate i ' ' <> ", " <> b' <>
 158                         "\n" <> List.replicate i ' ' <> ") "
 159 instance Pretty a => Pretty [a] where
 160         pretty [] = return "[]"
 161         pretty as = do
 162                 i <- R.ask
 163                 s <- R.local (+2) $ mapM pretty as
 164                 return $
 165                         (if i == 0 then "" else "\n") <>
 166                         List.replicate i ' ' <> "[ " <>
 167                         List.intercalate ("\n" <> List.replicate i ' ' <> ", ") s <>
 168                         "\n" <> List.replicate i ' ' <> "] "
 169 instance (Pretty k, Pretty a) => Pretty (Map.Map k a) where
 170         pretty = pretty . Map.toList
 171 instance (Pretty k, Pretty a) => Pretty (HM.HashMap k a) where
 172         pretty = pretty . HM.toList
 173 instance Pretty a => Pretty (NonEmpty a) where
 174         pretty = pretty . toList
 175 instance Pretty a => Pretty (Seq a) where
 176         pretty ss
 177          | null ss = return "[]"
 178          | otherwise = do
 179                 let as = toList ss
 180                 i <- R.ask
 181                 s <- R.local (+2) $ mapM pretty as
 182                 return $
 183                         (if i == 0 then "" else "\n") <>
 184                         List.replicate i ' ' <> "[ " <>
 185                         List.intercalate ("\n" <> List.replicate i ' ' <> ", ") s <>
 186                         "\n" <> List.replicate i ' ' <> "] "
 187 instance Pretty a => Pretty (Maybe a) where
 188         pretty Nothing = return "Nothing"
 189         pretty (Just m) = do
 190                 s <- pretty m
 191                 return $ "Just "<>s
 192 instance Show a => Pretty (Tree.Tree a) where
 193         pretty (Tree.Node n ts) = do
 194                 s <- R.local (+2) (pretty ts)
 195                 return $ "Tree "<>showsPrec 11 n ""<>" "<>s
 196 instance Show a => Pretty (TS.Tree a) where
 197         pretty (TS.Tree n ts) = do
 198                 s <- R.local (+2) (pretty ts)
 199                 return $ "Tree "<>showsPrec 11 n ""<>" "<>s
 200 instance (Show src, Show a) => Pretty (XML.Sourced src a) where