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 debugParser ::
  73  ( P.Stream s
  74  , P.ShowToken (P.Token s)
  75  , P.ShowErrorComponent e
  76  , Ord e
  77  , Show a
  78  ) =>
  79  String -> P.Parsec e s a -> P.Parsec e s a
  80 debugParser = P.dbg
  81 #else
  82 import Data.Function (id)
  83
  84 debug :: String -> a -> a
  85 debug _m = id
  86 {-# INLINE debug #-}
  87
  88 debug0 :: Pretty a => String -> a -> a
  89 debug0 _m = id
  90 {-# INLINE debug0 #-}
  91
  92 debug1 :: (Pretty r, Pretty a) => String -> String -> (a -> r) -> (a -> r)
  93 debug1 _nf _na = id
  94 {-# INLINE debug1 #-}
  95
  96 debug2 :: (Pretty r, Pretty a, Pretty b) => String -> String -> String -> (a -> b -> r) -> (a -> b -> r)
  97 debug2 _nf _na _nb = id
  98 {-# INLINE debug2 #-}
  99
 100 debug2_ :: (Pretty r, Pretty a, Pretty b) => String -> (String,a) -> (String,b) -> r -> r
 101 debug2_ _nf _a _b = id
 102 {-# INLINE debug2_ #-}
 103
 104 debugParser ::
 105  ( P.Stream s
 106  , P.ShowToken (P.Token s)
 107  , P.ShowErrorComponent e
 108  , Ord e
 109  , Show a
 110  ) =>
 111  String -> P.Parsec e s a -> P.Parsec e s a
 112 debugParser _m = id
 113 {-# INLINE debugParser #-}
 114 #endif
 115
 116 -- * Class 'Pretty'
 117 class Pretty a where
 118         pretty :: a -> R.Reader Int String
 119         default pretty :: Show a => a -> R.Reader Int String
 120         pretty = return . show
 121 instance Pretty Bool
 122 instance Pretty Int
 123 instance Pretty Text
 124 instance Pretty TL.Text
 125 instance (Pretty a, Pretty b) => Pretty (a,b) where
 126         pretty (a,b) = do
 127                 i <- R.ask
 128                 a' <- R.local (+2) $ pretty a
 129                 b' <- R.local (+2) $ pretty b
 130                 return $
 131                         "\n" <> List.replicate i ' ' <> "( " <> a' <>
 132                         "\n" <> List.replicate i ' ' <> ", " <> b' <>
 133                         "\n" <> List.replicate i ' ' <> ") "
 134 instance Pretty a => Pretty [a] where
 135         pretty [] = return "[]"
 136         pretty as = do
 137                 i <- R.ask
 138                 s <- R.local (+2) $ mapM pretty as
 139                 return $
 140                         "\n" <> List.replicate i ' ' <> "[ " <>
 141                         List.intercalate ("\n" <> List.replicate i ' ' <> ", ") s <>
 142                         "\n" <> List.replicate i ' ' <> "] "
 143 instance Pretty a => Pretty (NonEmpty a) where
 144         pretty = pretty . toList
 145 instance Pretty a => Pretty (Seq a) where
 146         pretty ss
 147          | null ss = return "[]"
 148          | otherwise = do
 149                 let as = toList ss
 150                 i <- R.ask
 151                 s <- R.local (+2) $ mapM pretty as
 152                 return $
 153                         "\n" <> List.replicate i ' ' <> "[ " <>
 154                         List.intercalate ("\n" <> List.replicate i ' ' <> ", ") s <>
 155                         "\n" <> List.replicate i ' ' <> "] "
 156 instance Pretty a => Pretty (Maybe a) where
 157         pretty Nothing = return "Nothing"
 158         pretty (Just m) = do
 159                 s <- pretty m
 160                 return $ "Just "<>s
 161 instance Show a => Pretty (Tree a) where
 162         pretty (Tree n ts) = do
 163                 s <- R.local (+2) (pretty ts)
 164                 return $ "Tree "<>showsPrec 11 n ""<>" "<>s