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