Language/TCT/Debug.hs

   1 {-# LANGUAGE CPP #-}
   2 {-# LANGUAGE ConstraintKinds #-}
   3 {-# LANGUAGE DefaultSignatures #-}
   4 {-# LANGUAGE FlexibleContexts #-}
   5 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   6 {-# LANGUAGE OverloadedStrings #-}
   7 {-# LANGUAGE Rank2Types #-}
   8 {-# LANGUAGE TypeFamilies #-}
   9 module Language.TCT.Debug where
  10
  11 import Control.Monad (Monad(..), mapM)
  12 import Data.Bool
  13 import Data.Foldable (toList, null)
  14 import Data.Function (($), (.))
  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 Text.Megaparsec as P
  30
  31 -- * Debug
  32 #if DEBUG
  33 import qualified Debug.Trace as Trace
  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 <> ": " <> R.runReader (pretty a) 2) 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 <> ": " <> R.runReader (pretty r) 2) r) $
  44         (Trace.trace ("[ " <> nf <> ":\n " <> na <> " = " <> R.runReader (pretty a) 2) 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 <> " = " <> R.runReader (pretty a) 2) $
  50         Trace.trace ("] " <> nf <> ": " <> R.runReader (pretty r) 2) $
  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 <> ": " <> R.runReader (pretty r) 2) r) $
  56         Trace.trace
  57          ("[ " <> nf <> ":"
  58                  <> "\n " <> na <> " = " <> R.runReader (pretty a) 2
  59                  <> "\n " <> nb <> " = " <> R.runReader (pretty b) 2
  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 <> " = " <> R.runReader (pretty a) 2
  67                  <> "\n " <> nb <> " = " <> R.runReader (pretty b) 2
  68          ) $
  69         Trace.trace ("] " <> nf <> ": " <> R.runReader (pretty r) 2) $
  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 <> ": " <> R.runReader (pretty r) 2) r) $
  75         Trace.trace
  76          ("[ " <> nf <> ":"
  77                  <> "\n " <> na <> " = " <> R.runReader (pretty a) 2
  78                  <> "\n " <> nb <> " = " <> R.runReader (pretty b) 2
  79                  <> "\n " <> nc <> " = " <> R.runReader (pretty c) 2
  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 <> " = " <> R.runReader (pretty a) 2
  87                  <> "\n " <> nb <> " = " <> R.runReader (pretty b) 2
  88                  <> "\n " <> nc <> " = " <> R.runReader (pretty c) 2
  89          ) $
  90         Trace.trace ("] " <> nf <> ": " <> R.runReader (pretty r) 2) $
  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.Parsec e s a -> P.Parsec e s a
 101 debugParser = P.dbg
 102 #else
 103 import Data.Function (id)
 104
 105 debug :: String -> a -> a
 106 debug _m = id
 107 {-# INLINE debug #-}
 108
 109 debug0 :: Pretty a => String -> a -> a
 110 debug0 _m = id
 111 {-# INLINE debug0 #-}
 112
 113 debug1 :: (Pretty r, Pretty a) => String -> String -> (a -> r) -> (a -> r)
 114 debug1 _nf _na = id
 115 {-# INLINE debug1 #-}
 116
 117 debug1_ :: (Pretty r, Pretty a) => String -> (String,a) -> r -> r
 118 debug1_ _nf _na = id
 119 {-# INLINE debug1_ #-}
 120
 121 debug2 :: (Pretty r, Pretty a, Pretty b) => String -> String -> String -> (a -> b -> r) -> (a -> b -> r)
 122 debug2 _nf _na _nb = id
 123 {-# INLINE debug2 #-}
 124
 125 debug2_ :: (Pretty r, Pretty a, Pretty b) => String -> (String,a) -> (String,b) -> r -> r
 126 debug2_ _nf _a _b = id
 127 {-# INLINE debug2_ #-}
 128
 129 debug3 :: (Pretty r, Pretty a, Pretty b, Pretty c) => String -> String -> String -> String -> (a -> b -> c -> r) -> (a -> b -> c -> r)
 130 debug3 _nf _na _nb _nc = id
 131 {-# INLINE debug3 #-}
 132
 133 debug3_ :: (Pretty r, Pretty a, Pretty b, Pretty c) => String -> (String,a) -> (String,b) -> (String,c) -> r -> r
 134 debug3_ _nf _a _b _c = id
 135 {-# INLINE debug3_ #-}
 136
 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.Parsec e s a -> P.Parsec e s a
 145 debugParser _m = id
 146 {-# INLINE debugParser #-}
 147 #endif
 148
 149 -- * Class 'Pretty'
 150 class Pretty a where
 151         pretty :: a -> R.Reader Int String
 152         default pretty :: Show a => a -> R.Reader Int String
 153         pretty = return . show
 154 instance Pretty Bool
 155 instance Pretty Int
 156 instance Pretty Text
 157 instance Pretty TL.Text
 158 instance (Pretty a, Pretty b) => Pretty (a,b) where
 159         pretty (a,b) = do
 160                 i <- R.ask
 161                 a' <- R.local (+2) $ pretty a
 162                 b' <- R.local (+2) $ pretty b
 163                 return $
 164                         "\n" <> List.replicate i ' ' <> "( " <> a' <>
 165                         "\n" <> List.replicate i ' ' <> ", " <> b' <>
 166                         "\n" <> List.replicate i ' ' <> ") "
 167 instance Pretty a => Pretty [a] where
 168         pretty [] = return "[]"
 169         pretty as = do
 170                 i <- R.ask
 171                 s <- R.local (+2) $ mapM pretty as
 172                 return $
 173                         "\n" <> List.replicate i ' ' <> "[ " <>
 174                         List.intercalate ("\n" <> List.replicate i ' ' <> ", ") s <>
 175                         "\n" <> List.replicate i ' ' <> "] "
 176 instance Pretty a => Pretty (NonEmpty a) where
 177         pretty = pretty . toList
 178 instance Pretty a => Pretty (Seq a) where
 179         pretty ss
 180          | null ss = return "[]"
 181          | otherwise = do
 182                 let as = toList ss
 183                 i <- R.ask
 184                 s <- R.local (+2) $ mapM pretty as
 185                 return $
 186                         "\n" <> List.replicate i ' ' <> "[ " <>
 187                         List.intercalate ("\n" <> List.replicate i ' ' <> ", ") s <>
 188                         "\n" <> List.replicate i ' ' <> "] "
 189 instance Pretty a => Pretty (Maybe a) where
 190         pretty Nothing = return "Nothing"
 191         pretty (Just m) = do
 192                 s <- pretty m
 193                 return $ "Just "<>s
 194 instance Show a => Pretty (Tree a) where
 195         pretty (Tree n ts) = do
 196                 s <- R.local (+2) (pretty ts)
 197                 return $ "Tree "<>showsPrec 11 n ""<>" "<>s