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