Hdoc/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 Hdoc.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.TreeSeq.Strict as TS
  31 import qualified Data.Tree as Tree
  32 import qualified Data.Text.Lazy as TL
  33 import qualified Debug.Trace as Trace
  34 import qualified Text.Megaparsec as P
  35
  36 trace :: String -> a -> a
  37 trace = Trace.trace
  38
  39 -- * Debug
  40 #if DEBUG
  41
  42 debug :: String -> a -> a
  43 debug = Trace.trace
  44
  45 debug0 :: Pretty a => String -> a -> a
  46 debug0 m a = Trace.trace (m <> ": " <> runPretty 2 a) a
  47
  48 debug1 :: (Pretty r, Pretty a) => String -> String -> (a -> r) -> (a -> r)
  49 debug1 nf na f a =
  50         (\r -> Trace.trace ("] " <> nf <> ": " <> runPretty 2 r) r) $
  51         Trace.trace ("[ " <> nf <> ":\n " <> na <> " = " <> runPretty 2 a) f
  52         a
  53
  54 debug1_ :: (Pretty r, Pretty a) => String -> (String,a) -> r -> r
  55 debug1_ nf (na,a) r =
  56         Trace.trace ("[ " <> nf <> ":\n " <> na <> " = " <> runPretty 2 a) $
  57         Trace.trace ("] " <> nf <> ": " <> runPretty 2 r) $
  58         r
  59
  60 debug2 :: (Pretty r, Pretty a, Pretty b) => String -> String -> String -> (a -> b -> r) -> (a -> b -> r)
  61 debug2 nf na nb f a b =
  62         (\r -> Trace.trace ("] " <> nf <> ": " <> runPretty 2 r) r) $
  63         Trace.trace
  64          ("[ " <> nf <> ":"
  65                  <> "\n " <> na <> " = " <> runPretty 2 a
  66                  <> "\n " <> nb <> " = " <> runPretty 2 b
  67          ) f a b
  68
  69 debug2_ :: (Pretty r, Pretty a, Pretty b) => String -> (String,a) -> (String,b) -> r -> r
  70 debug2_ nf (na,a) (nb,b) r =
  71         Trace.trace
  72          ("[ " <> nf <> ":"
  73                  <> "\n " <> na <> " = " <> runPretty 2 a
  74                  <> "\n " <> nb <> " = " <> runPretty 2 b
  75          ) $
  76         Trace.trace ("] " <> nf <> ": " <> runPretty 2 r) $
  77         r
  78
  79 debug3 :: (Pretty r, Pretty a, Pretty b, Pretty c) => String -> String -> String -> String -> (a -> b -> c -> r) -> (a -> b -> c -> r)
  80 debug3 nf na nb nc f a b c =
  81         (\r -> Trace.trace ("] " <> nf <> ": " <> runPretty 2 r) r) $
  82         Trace.trace
  83          ("[ " <> nf <> ":"
  84                  <> "\n " <> na <> " = " <> runPretty 2 a
  85                  <> "\n " <> nb <> " = " <> runPretty 2 b
  86                  <> "\n " <> nc <> " = " <> runPretty 2 c
  87          ) f a b c
  88
  89 debug3_ :: (Pretty r, Pretty a, Pretty b, Pretty c) => String -> (String,a) -> (String,b) -> (String,c) -> r -> r
  90 debug3_ nf (na,a) (nb,b) (nc,c) r =
  91         Trace.trace
  92          ("[ " <> nf <> ":"
  93                  <> "\n " <> na <> " = " <> runPretty 2 a
  94                  <> "\n " <> nb <> " = " <> runPretty 2 b
  95                  <> "\n " <> nc <> " = " <> runPretty 2 c
  96          ) $
  97         Trace.trace ("] " <> nf <> ": " <> runPretty 2 r) $
  98         r
  99
 100 #else
 101
 102 debug :: String -> a -> a
 103 debug _m = id
 104 {-# INLINE debug #-}
 105
 106 debug0 :: Pretty a => String -> a -> a
 107 debug0 _m = id
 108 {-# INLINE debug0 #-}
 109
 110 debug1 :: (Pretty r, Pretty a) => String -> String -> (a -> r) -> (a -> r)
 111 debug1 _nf _na = id
 112 {-# INLINE debug1 #-}
 113
 114 debug1_ :: (Pretty r, Pretty a) => String -> (String,a) -> r -> r
 115 debug1_ _nf _na = id
 116 {-# INLINE debug1_ #-}
 117
 118 debug2 :: (Pretty r, Pretty a, Pretty b) => String -> String -> String -> (a -> b -> r) -> (a -> b -> r)
 119 debug2 _nf _na _nb = id
 120 {-# INLINE debug2 #-}
 121
 122 debug2_ :: (Pretty r, Pretty a, Pretty b) => String -> (String,a) -> (String,b) -> r -> r
 123 debug2_ _nf _a _b = id
 124 {-# INLINE debug2_ #-}
 125
 126 debug3 :: (Pretty r, Pretty a, Pretty b, Pretty c) => String -> String -> String -> String -> (a -> b -> c -> r) -> (a -> b -> c -> r)
 127 debug3 _nf _na _nb _nc = id
 128 {-# INLINE debug3 #-}
 129
 130 debug3_ :: (Pretty r, Pretty a, Pretty b, Pretty c) => String -> (String,a) -> (String,b) -> (String,c) -> r -> r
 131 debug3_ _nf _a _b _c = id
 132 {-# INLINE debug3_ #-}
 133
 134 #endif
 135
 136 #if DEBUG && DEBUG_PARSER
 137 debugParser ::
 138  ( P.Stream s
 139  , P.ShowToken (P.Token s)
 140  , P.ShowErrorComponent e
 141  , Ord e
 142  , Show a
 143  ) =>
 144  String -> P.ParsecT e s m a -> P.ParsecT e s m a
 145 debugParser = P.dbg
 146 #else
 147 debugParser ::
 148  ( P.Stream s
 149  , P.ShowToken (P.Token s)
 150  , P.ShowErrorComponent e
 151  , Ord e
 152  , Show a
 153  ) =>
 154  String -> P.ParsecT e s m a -> P.ParsecT e s m a
 155 debugParser _m = id
 156 {-# INLINE debugParser #-}
 157 #endif
 158
 159 -- * Class 'Pretty'
 160 class Pretty a where
 161         pretty :: a -> R.Reader Int String
 162         default pretty :: Show a => a -> R.Reader Int String
 163         pretty = return . show
 164
 165 runPretty :: Pretty a => Int -> a -> String
 166 runPretty i a = pretty a `R.runReader` i
 167
 168 instance Pretty Bool
 169 instance Pretty Int
 170 instance Pretty Integer
 171 instance (Pretty a, Show a) => Pretty (Ratio a)
 172 instance Pretty Text
 173 instance Pretty TL.Text
 174 instance Pretty P.Pos
 175 instance (Pretty a, Pretty b) => Pretty (a,b) where
 176         pretty (a,b) = do
 177                 i <- R.ask
 178                 a' <- R.local (+2) $ pretty a
 179                 b' <- R.local (+2) $ pretty b
 180                 return $
 181                         (if i == 0 then "" else "\n") <>
 182                         List.replicate i ' ' <> "( " <> a' <>
 183                         "\n" <> List.replicate i ' ' <> ", " <> b' <>
 184                         "\n" <> List.replicate i ' ' <> ") "
 185 instance Pretty a => Pretty [a] where
 186         pretty [] = return "[]"
 187         pretty as = do
 188                 i <- R.ask
 189                 s <- R.local (+2) $ mapM pretty as
 190                 return $
 191                         (if i == 0 then "" else "\n") <>
 192                         List.replicate i ' ' <> "[ " <>
 193                         List.intercalate ("\n" <> List.replicate i ' ' <> ", ") s <>
 194                         "\n" <> List.replicate i ' ' <> "] "
 195 instance (Pretty k, Pretty a) => Pretty (Map.Map k a) where
 196         pretty = pretty . Map.toList
 197 instance (Pretty k, Pretty a) => Pretty (HM.HashMap k a) where
 198         pretty = pretty . HM.toList
 199 instance Pretty a => Pretty (NonEmpty a) where
 200         pretty = pretty . toList
 201 instance Pretty a => Pretty (Seq a) where
 202         pretty ss
 203          | null ss = return "[]"
 204          | otherwise = do
 205                 let as = toList ss
 206                 i <- R.ask
 207                 s <- R.local (+2) $ mapM pretty as
 208                 return $
 209                         (if i == 0 then "" else "\n") <>
 210                         List.replicate i ' ' <> "[ " <>
 211                         List.intercalate ("\n" <> List.replicate i ' ' <> ", ") s <>
 212                         "\n" <> List.replicate i ' ' <> "] "
 213 instance Pretty a => Pretty (Maybe a) where
 214         pretty Nothing = return "Nothing"
 215         pretty (Just m) = do
 216                 s <- pretty m
 217                 return $ "Just "<>s
 218 instance Show a => Pretty (Tree.Tree a) where
 219         pretty (Tree.Node n ts) = do
 220                 s <- R.local (+2) (pretty ts)
 221                 return $ "Tree "<>showsPrec 11 n ""<>" "<>s
 222 instance Show a => Pretty (TS.Tree a) where
 223         pretty (TS.Tree n ts) = do
 224                 s <- R.local (+2) (pretty ts)
 225                 return $ "Tree "<>showsPrec 11 n ""<>" "<>s