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