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 debug2 :: (Pretty r, Pretty a, Pretty b) => String -> String -> String -> (a -> b -> r) -> (a -> b -> r)
 118 debug2 _nf _na _nb = id
 119 {-# INLINE debug2 #-}
 120
 121 debug2_ :: (Pretty r, Pretty a, Pretty b) => String -> (String,a) -> (String,b) -> r -> r
 122 debug2_ _nf _a _b = id
 123 {-# INLINE debug2_ #-}
 124
 125 debug3 :: (Pretty r, Pretty a, Pretty b, Pretty c) => String -> String -> String -> String -> (a -> b -> c -> r) -> (a -> b -> c -> r)
 126 debug3 _nf _na _nb _nc = id
 127 {-# INLINE debug3 #-}
 128
 129 debug3_ :: (Pretty r, Pretty a, Pretty b, Pretty c) => String -> (String,a) -> (String,b) -> (String,c) -> r -> r
 130 debug3_ _nf _a _b _c = id
 131 {-# INLINE debug3_ #-}
 132
 133 debugParser ::
 134  ( P.Stream s
 135  , P.ShowToken (P.Token s)
 136  , P.ShowErrorComponent e
 137  , Ord e
 138  , Show a
 139  ) =>
 140  String -> P.Parsec e s a -> P.Parsec e s a
 141 debugParser _m = id
 142 {-# INLINE debugParser #-}
 143 #endif
 144
 145 -- * Class 'Pretty'
 146 class Pretty a where
 147         pretty :: a -> R.Reader Int String
 148         default pretty :: Show a => a -> R.Reader Int String
 149         pretty = return . show
 150 instance Pretty Bool
 151 instance Pretty Int
 152 instance Pretty Text
 153 instance Pretty TL.Text
 154 instance (Pretty a, Pretty b) => Pretty (a,b) where
 155         pretty (a,b) = do
 156                 i <- R.ask
 157                 a' <- R.local (+2) $ pretty a
 158                 b' <- R.local (+2) $ pretty b
 159                 return $
 160                         "\n" <> List.replicate i ' ' <> "( " <> a' <>
 161                         "\n" <> List.replicate i ' ' <> ", " <> b' <>
 162                         "\n" <> List.replicate i ' ' <> ") "
 163 instance Pretty a => Pretty [a] where
 164         pretty [] = return "[]"
 165         pretty as = do
 166                 i <- R.ask
 167                 s <- R.local (+2) $ mapM pretty as
 168                 return $
 169                         "\n" <> List.replicate i ' ' <> "[ " <>
 170                         List.intercalate ("\n" <> List.replicate i ' ' <> ", ") s <>
 171                         "\n" <> List.replicate i ' ' <> "] "
 172 instance Pretty a => Pretty (NonEmpty a) where
 173         pretty = pretty . toList
 174 instance Pretty a => Pretty (Seq a) where
 175         pretty ss
 176          | null ss = return "[]"
 177          | otherwise = do
 178                 let as = toList ss
 179                 i <- R.ask
 180                 s <- R.local (+2) $ mapM pretty as
 181                 return $
 182                         "\n" <> 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 a) where
 191         pretty (Tree n ts) = do
 192                 s <- R.local (+2) (pretty ts)
 193                 return $ "Tree "<>showsPrec 11 n ""<>" "<>s